No OneTemporary
Actions

Size

6 MB

Subscribers

None

View Options

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

	diff --git a/admin/sitegen-lib/templates.py b/admin/sitegen-lib/templates.py
	--- a/admin/sitegen-lib/templates.py
	+++ b/admin/sitegen-lib/templates.py
	@@ -1,228 +1,228 @@
	from collections import OrderedDict
	from itertools import groupby
	import os
	import datetime
	from jinja2 import Environment, FileSystemLoader

	import terminal

	### topics

	class Tree(object):
	def __init__(self):
	self.subtopics = OrderedDict()
	self.entries = []

	def add_topic(self, topic):
	if len(topic) > 0:
	if topic[0] not in self.subtopics:
	tree = Tree()
	self.subtopics[topic[0]] = tree
	else:
	tree = self.subtopics[topic[0]]
	tree.add_topic(topic[1:])

	def add_to_topic(self, topic, entry):
	if len(topic) > 0:
	if topic[0] not in self.subtopics:
	terminal.error(u"In entry {0}: unknown (sub)topic {1}".format(entry, topic), abort=True)
	else:
	self.subtopics[topic[0]].add_to_topic(topic[1:], entry)
	else:
	self.entries.append(entry)

	def __str__(self):
	return self._to_str()

	def _to_str(self, indent=0):
	indent_str = ' ' * indent
	result = indent_str + str(self.entries) + "\n"
	for subtopic, tree in self.subtopics.items():
	result += indent_str
	result += subtopic
	result += "\n"
	result += tree._to_str(indent + 2)
	return result

	def read_topics(filename):
	tree = Tree()
	stack = []
	with open(filename) as f:
	for line in f:
	count = 0
	while line[count] == ' ':
	count += 1
	if count % 2:
	raise Exception(u"Illegal indentation at line '{0}'".format(line))
	level = count // 2
	if level <= len(stack):
	stack = stack[0:level]
	else:
	raise Exception(u"Illegal indentation at line '{0}'".format(line))
	stack.append(line[count:len(line)-1])
	tree.add_topic(stack)
	return tree

	# for topics page: group entries by topic
	def collect_topics(entries, metadata_dir):
	tree = read_topics(os.path.join(metadata_dir, "topics"))
	for entry, attributes in entries.items():
	for topic in attributes['topic']:
	tree.add_to_topic([s.strip() for s in topic.split('/')], entry)
	return tree


	class Builder():
	"""Contains environment for building webpages from templates"""

	def __init__(self, options, entries, afp_entries):
	self.j2_env = Environment(loader=FileSystemLoader(options.templates_dir),
	trim_blocks=True)
	# pass functions to environment for use in templates
	self.prepare_env()
	self.options = options
	#TODO: use only afp_entries
	self.entries = entries
	self.afp_entries = afp_entries

	def prepare_env(self):
	def startswith(value, beginning):
	return value.startswith(beginning)
	def datetimeformat(value, format_str='%Y-%m-%d'):
	return value.strftime(format_str)
	def rfc822(value):
	# Locale could be something different than english, to prevent printing
	# non english months, we use this fix
	month = "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec".split(" ")[value.month - 1]
	return value.strftime("%d " + month + " %Y %T %z")
	def split(value):
	return value.split()
	def short_month(value):
	return "jan feb mar apr may jun jul aug sep oct nov dec".split(" ")[value - 1]
	self.j2_env.filters['startswith'] = startswith
	self.j2_env.filters['datetimeformat'] = datetimeformat
	self.j2_env.filters['rfc822'] = rfc822
	self.j2_env.filters['split'] = split
	self.j2_env.filters['short_month'] = short_month

	def write_file(self, filename, template, values):
	# UTF-8 hack because of different string handling in python 2 vs 3
	with open(os.path.join(self.options.dest_dir, filename), 'wb') as f:
	f.write(template.render(values).encode('utf8'))

	def generate_standard(self, filename, template_name):
	template = self.j2_env.get_template(template_name)
	self.write_file(filename, template, {})
	terminal.success("Generated {}".format(filename))

	def generate_topics(self):
	tree = collect_topics(self.entries, self.options.metadata_dir)
	template = self.j2_env.get_template("topics.tpl")
	self.write_file("topics.html", template, {'tree': tree})
	terminal.success("Generated topics.html")

	def generate_index(self):
	data = {'is_devel': self.options.is_devel}
	by_year = groupby(sorted(self.afp_entries.values(),
	key=lambda e: (e.publish_date, e.name),
	reverse=True),
	key=lambda e: e.publish_date.year)
	data['by_year'] = [(year, list(entries)) for year, entries in by_year]
	template = self.j2_env.get_template("index.tpl")
	self.write_file("index.html", template, data)
	terminal.success("Generated index.html")

	def generate_entries(self):
	counter = 0
	template = self.j2_env.get_template("entry.tpl")
	for name, entry in self.afp_entries.items():
	self.write_file(os.path.join("entries", name + ".html"), template,
	{'entry': entry, 'is_devel': self.options.is_devel})
	counter += 1
	for name, entry in self.afp_entries.no_index.items():
	self.write_file(os.path.join("entries", name + ".html"), template,
	{'entry': entry, 'is_devel': self.options.is_devel})
	counter += 1
	terminal.success("Generated html files for {:d} entries".format(counter))

	def generate_download(self):
	template = self.j2_env.get_template("download.tpl")
	self.write_file("download.html", template,
	{'is_devel': self.options.is_devel})
	terminal.success("Generated download.html")

	def generate_statistics(self):
	#TODO: simplify with itertools
	# Count loc and articles per year
	articles_years = dict()
	loc_years = dict()
	for article in self.afp_entries.values():
	try:
	articles_years[article.publish_date.year] += 1
	loc_years[article.publish_date.year] += article.loc
	except KeyError:
	articles_years[article.publish_date.year] = 1
	loc_years[article.publish_date.year] = article.loc
	# Count new authors per year
	- author_years = dict()
	+ author_years = dict.fromkeys(articles_years.keys(), 0)
	for author in self.afp_entries.authors.values():
	first_year = min([e.publish_date.year for e in author.articles])
	try:
	author_years[first_year] += 1
	except KeyError:
	author_years[first_year] = 1
	# Build cumulative values
	author_years_cumulative = author_years.copy()
	for y in sorted(articles_years)[1:]:
	articles_years[y] += articles_years[y - 1]
	loc_years[y] += loc_years[y - 1]
	author_years_cumulative[y] += author_years_cumulative[y - 1]
	data = {'entries': self.afp_entries}
	data['num_lemmas'] = sum([a.lemmas for a in self.afp_entries.values()])
	data['num_loc'] = sum([a.loc for a in self.afp_entries.values()])
	data['years'] = sorted(articles_years)
	data['articles_year'] = [articles_years[y] for y
	in sorted(articles_years)]
	data['loc_years'] = [round(loc_years[y], -2) for y in sorted(loc_years)]
	data['author_years'] = [author_years[y] for y in sorted(author_years)]
	data['author_years_cumulative'] = [author_years_cumulative[y] for y in
	sorted(author_years_cumulative)]
	# Find 10 most imported entries, entries with the same number of
	# imports share one place.
	most_used = sorted([a for a in self.afp_entries.values()],
	key=lambda x: (-len(x.used), x.name))
	# Show more than 10 articles but not more than necessary
	i = 0
	while (i < 10 or (i + 1 < len(most_used) and
	len(most_used[i].used) == len(most_used[i + 1].used))):
	i += 1
	# Groupby iterators trigger some obscure bug in jinja2
	# https://github.com/pallets/jinja/issues/555
	# So don't use groupby iterator directly and convert to list of lists
	data['most_used'] = [(len_used, list(articles)) for (len_used, articles)
	in groupby(most_used[:i + 1],
	key=lambda x: len(x.used))]
	data['articles_by_time'] = sorted(self.afp_entries.values(),
	key=lambda x: x.publish_date)
	data['articles_per_year'] = [(year, list(articles)) for (year, articles)
	in groupby(data['articles_by_time'],
	key=lambda x: x.publish_date.year)]
	template = self.j2_env.get_template("statistics.tpl")
	self.write_file("statistics.html", template, data)
	terminal.success("Generated statistics.html")

	def generate_status(self, build_data):
	template = self.j2_env.get_template("status.tpl")
	self.write_file("status.html", template,
	{'entries': [self.afp_entries[e] for e
	in sorted(self.afp_entries)],
	'build_data': build_data})
	terminal.success("Generated status.html")

	def generate_rss(self, num_entries):
	entries = sorted(self.afp_entries.values(),
	key=lambda e: (e.publish_date, e.name),
	reverse=True)
	template = self.j2_env.get_template("rss.tpl")
	self.write_file("rss.xml", template, {'entries': entries[:num_entries]})
	terminal.success("Generated rss.xml")
	diff --git a/metadata/metadata b/metadata/metadata
	--- a/metadata/metadata
	+++ b/metadata/metadata
	@@ -1,8743 +1,8905 @@
	+[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?
	+
	+[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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Number Theory
	date = 2018-06-23
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Geometry, Mathematics/Number Theory
	date = 2017-07-13
	notify = eberlm@in.tum.de
	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
	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.

	[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://www21.in.tum.de/~eberlm>, 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://www21.in.tum.de/~eberlm>
	topic = Computer Science/Algorithms
	date = 2017-03-15
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Computer Science/Algorithms
	date = 2017-03-15
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Computer Science/Data Structures
	date = 2017-04-04
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Computer Science/Data Structures
	date = 2018-10-19
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Analysis, Mathematics/Number Theory
	date = 2017-01-12
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Number Theory
	date = 2018-09-28
	notify = eberlm@in.tum.de
	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>

	[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 =
	This article attempts to develop a usable framework for doing category
	theory in Isabelle/HOL. Our point of view, which to some extent
	differs from that of the previous AFP articles on the subject, is to
	try to explore how category theory can be done efficaciously within
	HOL, rather than trying to match exactly the way things are done using
	a traditional approach. To this end, we define the notion of category
	in an "object-free" style, in which a category is represented by a
	single partial composition operation on arrows. This way of defining
	categories provides some advantages in the context of HOL, including
	the ability to avoid the use of records and the possibility of
	defining functors and natural transformations simply as certain
	functions on arrows, rather than as composite objects. We define
	various constructions associated with the basic notions, including:
	dual category, product category, functor category, discrete category,
	free category, functor composition, and horizontal and vertical
	composite of natural transformations. A "set category" locale is
	defined that axiomatizes the notion "category of all sets at a type
	and all functions between them," and a fairly extensive set of
	properties of set categories is derived from the locale assumptions.
	The notion of a set category is used to prove the Yoneda Lemma in a
	general setting of a category equipped with a "hom embedding," which
	maps arrows of the category to the "universe" of the set category. We
	also give a treatment of adjunctions, defining adjunctions via left
	and right adjoint functors, natural bijections between hom-sets, and
	unit and counit natural transformations, and showing the equivalence
	of these definitions. We also develop the theory of limits, including
	representations of functors, diagrams and cones, and diagonal
	functors. We show that right adjoint functors preserve limits, and
	that limits can be constructed via products and equalizers. We
	characterize the conditions under which limits exist in a set
	category. We also examine the case of limits in a functor category,
	ultimately culminating in a proof that the Yoneda embedding preserves
	limits.
	extra-history =
	Change history:
	[2018-05-29]:
	Revised axioms for the category locale. Introduced notation for composition and "in hom".
	(revision 8318366d4575)<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 =
	Building on the formalization of basic category theory set out in the
	author's previous AFP article, the present article formalizes
	some basic aspects of the theory of monoidal categories. Among the
	notions defined here are monoidal category, monoidal functor, and
	equivalence of monoidal categories. The main theorems formalized are
	MacLane's coherence theorem and the constructions of the free
	monoidal category and free strict monoidal category generated by a
	given category. The coherence theorem is proved syntactically, using
	a structurally recursive approach to reduction of terms that might
	have some novel aspects. We also give proofs of some results given by
	Etingof et al, which may prove useful in a formal setting. In
	particular, we show that the left and right unitors need not be taken
	as given data in the definition of monoidal category, nor does the
	definition of monoidal functor need to take as given a specific
	isomorphism expressing the preservation of the unit object. Our
	definitions of monoidal category and monoidal functor are stated so as
	to take advantage of the economy afforded by these facts.
	extra-history =
	Change history:
	[2017-05-18]:
	Integrated material from MonoidalCategory/Category3Adapter into Category3/ and deleted adapter.
	(revision 015543cdd069)<br>
	[2018-05-29]:
	Modifications required due to 'Category3' changes. Introduced notation for "in hom".
	(revision 8318366d4575)<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 operations on discrete distributions from finite version of the max-flow min-cut theorem
	(revision a7a198f5bab0)<br>


	[Liouville_Numbers]
	title = Liouville numbers
	author = Manuel Eberl <https://www21.in.tum.de/~eberlm>
	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 = eberlm@in.tum.de

	[Triangle]
	title = Basic Geometric Properties of Triangles
	author = Manuel Eberl <https://www21.in.tum.de/~eberlm>
	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 = eberlm@in.tum.de

	[Prime_Harmonic_Series]
	title = The Divergence of the Prime Harmonic Series
	author = Manuel Eberl <https://www21.in.tum.de/~eberlm>
	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 = eberlm@in.tum.de

	[Descartes_Sign_Rule]
	title = Descartes' Rule of Signs
	author = Manuel Eberl <https://www21.in.tum.de/~eberlm>
	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 = eberlm@in.tum.de

	[Euler_MacLaurin]
	title = The Euler–MacLaurin Formula
	author = Manuel Eberl <https://www21.in.tum.de/~eberlm>
	topic = Mathematics/Analysis
	date = 2017-03-10
	notify = eberlm@in.tum.de
	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 =

	[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<https://home.in.tum.de/~haslbecm/>
	+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

	[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://www21.in.tum.de/~eberlm>
	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 <mailto:traytel@in.tum.de>
	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 <mailto:traytel@in.tum.de>, Tobias Nipkow <http://www21.in.tum.de/~nipkow>
	topic = Computer Science/Automata and Formal Languages, Logic
	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 <http://www21.in.tum.de/~traytel>
	topic = Computer Science/Automata and Formal Languages, Logic
	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://www21.in.tum.de/~eberlm>
	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 <http://sjcjoosten.nl/>
	topic = Logic, 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
	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
	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 <mailto:traytel@in.tum.de>
	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.
	notify = c.sternagel@gmail.com

	[SATSolverVerification]
	title = Formal Verification of Modern SAT Solvers
	-author = Filip Maric <http://poincare.matf.bg.ac.rs/~filip/>
	+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

	[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 <mailto:uuomul@yahoo.com>, 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 = grewe@cs.tu-darmstadt.de

	[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)

	[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 = grewe@cs.tu-darmstadt.de

	[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 = grewe@cs.tu-darmstadt.de

	[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
	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
	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
	abstract = This development defines a well-ordered type of countable ordinals. It includes notions of continuous and normal functions, recursively defined functions over ordinals, least fixed-points, and derivatives. Much of ordinal arithmetic is formalized, including exponentials and logarithms. The development concludes with formalizations of Cantor Normal Form and Veblen hierarchies over normal functions.
	notify = lcp@cl.cam.ac.uk

	[Ordinals_and_Cardinals]
	title = Ordinals and Cardinals
	author = Andrei Popescu <>
	date = 2009-09-01
	topic = Logic
	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 <http://www.student.dtu.dk/~s144442/>
	date = 2007-08-02
	topic = Logic
	abstract = We present a formalization of parts of Melvin Fitting's book "First-Order Logic and Automated Theorem Proving". The formalization covers the syntax of first-order logic, its semantics, the model existence theorem, a natural deduction proof calculus together with a proof of correctness and completeness, as well as the Löwenheim-Skolem theorem.
	extra-history =
	Change history:
	[2018-07-21]: Proved completeness theorem for open formulas. Proofs are now written in the declarative style. Enumeration of pairs and datatypes is automated using the Countable theory.
	notify = berghofe@in.tum.de

	[Epistemic_Logic]
	title = Epistemic Logic
	author = Asta Halkjær From <http://www.student.dtu.dk/~s144442/>
	topic = Logic
	date = 2018-10-29
	notify = s144442@student.dtu.dk
	abstract =
	This work is a formalization of epistemic logic with countably many
	agents. It includes proofs of soundness and completeness for the axiom
	system K. The completeness proof is based on the textbook
	"Reasoning About Knowledge" by Fagin, Halpern, Moses and
	Vardi (MIT Press 1995).

	[SequentInvertibility]
	title = Invertibility in Sequent Calculi
	author = Peter Chapman <>
	date = 2009-08-28
	topic = Logic
	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
	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
	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
	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
	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 <http://www21.in.tum.de/~popescua>
	date = 2013-06-27
	topic = Logic
	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 <mailto:traytel@inf.ethz.ch>
	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

	[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://www21.in.tum.de/~eberlm>
	date = 2014-01-11
	topic = Mathematics/Analysis
	abstract = Sturm's Theorem states that polynomial sequences with certain
	properties, so-called Sturm sequences, can be used to count the number
	of real roots of a real polynomial. This work contains a proof of
	Sturm's Theorem and code for constructing Sturm sequences efficiently.
	It also provides the “sturm” proof method, which can decide certain
	statements about the roots of real polynomials, such as “the polynomial
	P has exactly n roots in the interval I” or “P(x) > Q(x) for all x
	∈ ℝ”.
	notify = eberlm@in.tum.de

	[Sturm_Tarski]
	title = The Sturm-Tarski Theorem
	author = Wenda Li <mailto:wl302@cam.ac.uk>
	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

	[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 <http://www21.in.tum.de/~traytel>
	date = 2015-05-27
	topic = Computer Science/Automata and Formal Languages
	abstract =
	Numerous models of probabilistic systems are studied in the literature.
	Coalgebra has been used to classify them into system types and compare their
	expressiveness. We formalize the resulting hierarchy of probabilistic system
	types by modeling the semantics of the different systems as codatatypes.
	This approach yields simple and concise proofs, as bisimilarity coincides
	with equality for codatatypes.
	<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://www21.in.tum.de/~eberlm>, 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, 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

	[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://bitbucket.org/isa-afp/afp-devel/commits/8c2b5b3c995f">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 <mailto:wl302@cam.ac.uk>
	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
	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
	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/Philosophy
	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/Philosophy
	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/Philosophy
	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/Philosophy
	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/Philosophy
	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://bitbucket.org/isa-afp/afp-devel/commits/ea3b38fc54d68535bcfafd40357b6ff8f1092057">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://bitbucket.org/isa-afp/afp-devel/commits/9091ce05cb20d4ad3dc1961c18f1846d85e87f8e">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 <http://www21.in.tum.de/~popescua>, 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 <http://www21.in.tum.de/~popescua>
	date = 2014-04-16
	topic = Computer Science/Security, 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 <http://www21.in.tum.de/~popescua>, Peter Lammich <http://www21.in.tum.de/~lammich>
	date = 2014-04-22
	topic = Computer Science/Security
	abstract = This is a formalization of bounded-deducibility security (BD
	security), a flexible notion of information-flow security applicable
	to arbitrary input-output automata. It generalizes Sutherland's
	classic notion of nondeducibility by factoring in declassification
	bounds and trigger, whereas nondeducibility states that, in a
	system, information cannot flow between specified sources and sinks,
	BD security indicates upper bounds for the flow and triggers under
	which these upper bounds are no longer guaranteed.
	notify = uuomul@yahoo.com, lammich@in.tum.de

	[Network_Security_Policy_Verification]
	title = Network Security Policy Verification
	author = Cornelius Diekmann <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 <http://www21.in.tum.de/~popescua>, Dmitriy Traytel <http://www21.in.tum.de/~traytel>
	date = 2014-04-16
	topic = Logic
	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://www21.in.tum.de/~eberlm>
	date = 2015-07-14
	topic = Mathematics/Analysis
	abstract = This entry provides Landau symbols to describe and reason about the asymptotic growth of functions for sufficiently large inputs. A number of simplification procedures are provided for additional convenience: cancelling of dominated terms in sums under a Landau symbol, cancelling of common factors in products, and a decision procedure for Landau expressions containing products of powers of functions like x, ln(x), ln(ln(x)) etc.
	notify = eberlm@in.tum.de

	[Error_Function]
	title = The Error Function
	author = Manuel Eberl <https://www21.in.tum.de/~eberlm>
	topic = Mathematics/Analysis
	date = 2018-02-06
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	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 = eberlm@in.tum.de

	[Dirichlet_Series]
	title = Dirichlet Series
	author = Manuel Eberl <https://www21.in.tum.de/~eberlm>
	topic = Mathematics/Number Theory
	date = 2017-10-12
	notify = eberlm@in.tum.de
	abstract =
	This entry is a formalisation of much of Chapters 2, 3, and 11 of
	Apostol's “Introduction to Analytic Number
	Theory”. This includes: <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://www21.in.tum.de/~eberlm>
	+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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Number Theory, Mathematics/Analysis
	date = 2017-10-12
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Analysis
	date = 2017-10-12
	notify = eberlm@in.tum.de
	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>

	[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>
	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

	[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>
	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

	[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
	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
	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 <https://home.in.tum.de/~haslbecm/>, Peter Lammich <http://www21.in.tum.de/~lammich>, Lars Hupel <https://www21.in.tum.de/~hupel/>
	+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

	[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:eberlm@in.tum.de>
	date = 2016-05-05
	topic = Mathematics/Games and Economics
	abstract =
	This work contains a formalisation of basic Randomised Social Choice,
	including Stochastic Dominance and Social Decision Schemes (SDSs)
	along with some of their most important properties (Anonymity,
	Neutrality, ex-post- and SD-Efficiency, SD-Strategy-Proofness) and two
	particular SDSs – Random Dictatorship and Random Serial Dictatorship
	(with proofs of the properties that they satisfy). Many important
	properties of these concepts are also proven – such as the two
	equivalent characterisations of Stochastic Dominance and the fact that
	SD-efficiency of a lottery only depends on the support. The entry
	also provides convenient commands to define Preference Profiles, prove
	their well-formedness, and automatically derive restrictions that
	sufficiently nice SDSs need to satisfy on the defined profiles.
	Currently, the formalisation focuses on weak preferences and
	Stochastic Dominance, but it should be easy to extend it to other
	domains – such as strict preferences – or other lottery extensions –
	such as Bilinear Dominance or Pairwise Comparison.
	notify = eberlm@in.tum.de

	[SDS_Impossibility]
	title = The Incompatibility of SD-Efficiency and SD-Strategy-Proofness
	author = Manuel Eberl <mailto:eberlm@in.tum.de>
	date = 2016-05-04
	topic = Mathematics/Games and Economics
	abstract =
	This formalisation contains the proof that there is no anonymous and
	neutral Social Decision Scheme for at least four voters and
	alternatives that fulfils both SD-Efficiency and SD-Strategy-
	Proofness. The proof is a fully structured and quasi-human-redable
	one. It was derived from the (unstructured) SMT proof of the case for
	exactly four voters and alternatives by Brandl et al. Their proof
	relies on an unverified translation of the original problem to SMT,
	and the proof that lifts the argument for exactly four voters and
	alternatives to the general case is also not machine-checked. In this
	Isabelle proof, on the other hand, all of these steps are fully
	proven and machine-checked. This is particularly important seeing as a
	previously published informal proof of a weaker statement contained a
	mistake in precisely this lifting step.
	notify = eberlm@in.tum.de

	[Median_Of_Medians_Selection]
	title = The Median-of-Medians Selection Algorithm
	author = Manuel Eberl <https://www21.in.tum.de/~eberlm>
	topic = Computer Science/Algorithms
	date = 2017-12-21
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Algebra
	date = 2017-12-21
	notify = eberlm@in.tum.de
	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, Computer Science/Data Structures
	+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
	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://www21.in.tum.de/~eberlm>
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	contributors = Lawrence C. Paulson <http://www.cl.cam.ac.uk/~lp15/>
	topic = Mathematics/Number Theory
	date = 2017-01-17
	notify = eberlm@in.tum.de
	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
	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
	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://www21.in.tum.de/~eberlm>
	notify = eberlm@in.tum.de
	date = 2016-09-01
	topic = Mathematics/Analysis
	abstract =
	This work contains a proof of Stirling's formula both for the
	factorial n! &sim; √<span style="text-decoration:
	overline">2πn</span> (n/e)<sup>n</sup> on natural numbers and the
	real Gamma function Γ(x) &sim; √<span
	style="text-decoration: overline">2π/x</span> (x/e)<sup>x</sup>.
	The proof is based on work by <a
	href="http://www.maths.lancs.ac.uk/~jameson/stirlgamma.pdf">Graham
	Jameson</a>.

	[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, 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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Probability Theory, Mathematics/Geometry
	date = 2017-06-06
	notify = eberlm@in.tum.de
	abstract =
	In the 18th century, Georges-Louis Leclerc, Comte de Buffon posed and
	later solved the following problem, which is often called the first
	problem ever solved in geometric probability: Given a floor divided
	into vertical strips of the same width, what is the probability that a
	needle thrown onto the floor randomly will cross two strips? This
	entry formally defines the problem in the case where the needle's
	position is chosen uniformly at random in a single strip around the
	origin (which is equivalent to larger arrangements due to symmetry).
	It then provides proofs of the simple solution in the case where the
	needle's length is no greater than the width of the strips and
	the more complicated solution in the opposite case.

	[SPARCv8]
	title = A formal model for the SPARCv8 ISA and a proof of non-interference for the LEON3 processor
	author = Zhe Hou <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
	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
	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
	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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Analysis, Mathematics/Number Theory
	date = 2017-01-24
	notify = eberlm@in.tum.de
	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.

	[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 <mailto:uuomul@yahoo.com>, Dmitriy Traytel <mailto:traytel@inf.ethz.ch>
	topic = Logic
	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, Computer Science/Programming Languages/Logics
	date = 2017-02-13
	notify = bbohrer@cs.cmu.edu
	abstract =
	We formalize differential dynamic logic, a logic for proving
	properties of hybrid systems. The proof calculus in this formalization
	is based on the uniform substitution principle. We show it is sound
	with respect to our denotational semantics, which provides increased
	confidence in the correctness of the KeYmaera X theorem prover based
	on this calculus. As an application, we include a proof term checker
	embedded in Isabelle/HOL with several example proofs. Published in:
	Brandon Bohrer, Vincent Rahli, Ivana Vukotic, Marcus Völp, André
	Platzer: Formally verified differential dynamic logic. CPP 2017.

	[Elliptic_Curves_Group_Law]
	title = The Group Law for Elliptic Curves
	author = Stefan Berghofer <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 =
	This is an example submission to the Archive of Formal Proofs. It shows
	submission requirements and explains the structure of a simple typical
	submission.
	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
	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/Philosophy
	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>.

	+[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.
	+
	+[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/>
	+topic = Computer Science/Algorithms/Approximation
	+date = 2020-01-16
	+notify = nipkow@in.tum.de
	+abstract =
	+ We present the first formal verification of approximation algorithms
	+ for NP-complete optimization problems: vertex cover, independent set,
	+ load balancing, and bin packing. The proofs correct incompletenesses
	+ in existing proofs and improve the approximation ratio in one case.

	[Diophantine_Eqns_Lin_Hom]
	title = Homogeneous Linear Diophantine Equations
	author = Florian Messner <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 a rectangle box or a
	half-plane. Potential applications of this entry include certified
	complex root isolation (of a polynomial) and testing the Routh-Hurwitz
	stability criterion (i.e., to check whether all the roots of some
	characteristic polynomial have negative real parts).

	[Buchi_Complementation]
	title = Büchi Complementation
	author = Julian Brunner <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
	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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Number Theory, Mathematics/Algebra
	date = 2017-12-21
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Algebra
	date = 2018-09-25
	notify = eberlm@in.tum.de
	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 <mailto:mohammad.abdulaziz8@gmail.com>, 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.

	[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 <mailto:andschl@dtu.dk>, Jasmin Christian Blanchette <mailto:j.c.blanchette@vu.nl>, Dmitriy Traytel <mailto:traytel@inf.ethz.ch>, Uwe Waldmann <mailto:uwe@mpi-inf.mpg.de>
	topic = Logic
	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.

	[BNF_Operations]
	title = Operations on Bounded Natural Functors
	author = Jasmin Christian Blanchette <mailto:jasmin.blanchette@gmail.com>, Andrei Popescu <mailto:uuomul@yahoo.com>, Dmitriy Traytel <mailto:traytel@inf.ethz.ch>
	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 <>, Sebastiaan Joosten <http://sjcjoosten.nl/>, René Thiemann <http://cl-informatik.uibk.ac.at/users/thiemann/>, Akihisa Yamada<>
	+author = Ralph Bottesch <>, Jose Divasón <http://www.unirioja.es/cu/jodivaso/>, Maximilian Haslbeck <http://cl-informatik.uibk.ac.at/users/mhaslbeck/>, Sebastiaan Joosten <http://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 <http://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 <https://home.in.tum.de/~haslbecm>, Manuel Eberl <https://www.in.tum.de/~eberlm>, Tobias Nipkow <https://www.in.tum.de/~nipkow>
	+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 = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm/>
	+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://www21.in.tum.de/~eberlm>
	+topic = Mathematics/Number Theory
	+date = 2020-01-17
	+notify = eberlm@in.tum.de
	+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://www21.in.tum.de/~eberlm>, 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 = eberlm@in.tum.de
	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
	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.

	[Prime_Number_Theorem]
	title = The Prime Number Theorem
	author = Manuel Eberl <https://www21.in.tum.de/~eberlm>, Lawrence C. Paulson <https://www.cl.cam.ac.uk/~lp15/>
	topic = Mathematics/Number Theory
	date = 2018-09-19
	notify = eberlm@in.tum.de
	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 = eberlm@in.tum.de
	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 <mailto:andschl@dtu.dk>, Jasmin Christian Blanchette <mailto:j.c.blanchette@vu.nl>, Dmitriy Traytel <mailto:traytel@inf.ethz.ch>
	topic = Logic
	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.

	[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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Number Theory
	date = 2019-02-11
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Computer Science/Algorithms
	date = 2019-02-01
	notify = eberlm@in.tum.de
	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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Number Theory
	date = 2019-02-21
	notify = eberlm@in.tum.de
	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 <mailto:a.popescu@mdx.ac.uk>
	topic = Computer Science/Programming Languages/Lambda Calculi, Computer Science/Functional Programming, Logic
	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 <http://people.inf.ethz.ch/trayteld/>
	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 a <a
	href="http://people.inf.ethz.ch/trayteld/papers/lambdaauth/lambdaauth.pdf">paper
	draft</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.

	[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 <http://people.inf.ethz.ch/trayteld/>
	topic = Computer Science/Algorithms, 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 forthcoming <a
	href="http://people.inf.ethz.ch/trayteld/papers/rv19-verimon/verimon.pdf">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.

	[FOL_Seq_Calc1]
	title = A Sequent Calculus for First-Order Logic
	author = Asta Halkjær From <http://www.student.dtu.dk/~s144442/>
	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
	date = 2019-07-18
	notify = s144442@student.dtu.dk
	abstract =
	This work formalizes soundness and completeness of a one-sided sequent
	calculus for first-order logic. The completeness is shown via a
	translation from a complete semantic tableau calculus, the proof of
	which is based on the First-Order Logic According to Fitting theory.
	The calculi and proof techniques are taken from Ben-Ari's
	Mathematical Logic for Computer Science.

	[Szpilrajn]
	title = Szpilrajn Extension Theorem
	author = Peter Zeller <mailto:p_zeller@cs.uni-kl.de>
	topic = Mathematics/Order
	date = 2019-07-27
	notify = p_zeller@cs.uni-kl.de
	abstract =
	We formalize the Szpilrajn extension theorem, also known as
	order-extension principal: Every strict partial order can be extended
	to a strict linear order.

	[TESL_Language]
	title = A Formal Development of a Polychronous Polytimed Coordination Language
	author = Hai Nguyen Van <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://www21.in.tum.de/~eberlm>
	topic = Mathematics/Misc
	date = 2019-08-05
	notify = eberlm@in.tum.de
	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.

	[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/Philosophy
	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 = Mathematics/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://www21.in.tum.de/~eberlm>
	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 <http://www.student.dtu.dk/~s144442/>
	topic = Logic
	date = 2019-12-20
	notify = andro.from@gmail.com
	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 the cited 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 derivable 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 derivable. Similarly, I start from simpler
	versions of the @-rules and derive the general ones. These
	restrictions are imposed to rule out some means of nontermination.
	+
	+[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 =
	+ 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.
	+
	+[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.
	+
	diff --git a/thys/Approximation_Algorithms/Approx_BP_Hoare.thy b/thys/Approximation_Algorithms/Approx_BP_Hoare.thy
	new file mode 100755
	--- /dev/null
	+++ b/thys/Approximation_Algorithms/Approx_BP_Hoare.thy
	@@ -0,0 +1,1706 @@
	+section \<open>Bin Packing\<close>
	+
	+theory Approx_BP_Hoare
	+ imports Complex_Main "HOL-Hoare.Hoare_Logic" "HOL-Library.Disjoint_Sets"
	+begin
	+
	+text \<open>The algorithm and proofs are based on the work by Berghammer and Reuter @{cite BerghammerR03}.\<close>
	+
	+subsection \<open>Formalization of a Correct Bin Packing\<close>
	+
	+text \<open>Definition of the unary operator \<open>\<lbrakk>\<cdot>\<rbrakk>\<close> from the article.
	+ \<open>B\<close> will only be wrapped into a set if it is non-empty.\<close>
	+definition wrap :: "'a set \<Rightarrow> 'a set set" where
	+ "wrap B = (if B = {} then {} else {B})"
	+
	+lemma wrap_card:
	+ "card (wrap B) \<le> 1"
	+ unfolding wrap_def by auto
	+
	+text \<open>If \<open>M\<close> and \<open>N\<close> are pairwise disjoint with \<open>V\<close> and not yet contained in V,
	+ then the union of \<open>M\<close> and \<open>N\<close> is also pairwise disjoint with \<open>V\<close>.\<close>
	+lemma pairwise_disjnt_Un:
	+ assumes "pairwise disjnt ({M} \<union> {N} \<union> V)" "M \<notin> V" "N \<notin> V"
	+ shows "pairwise disjnt ({M \<union> N} \<union> V)"
	+ using assms unfolding pairwise_def by auto
	+
	+text \<open>A Bin Packing Problem is defined like in the article:\<close>
	+locale BinPacking =
	+ fixes U :: "'a set" \<comment> \<open>A finite, non-empty set of objects\<close>
	+ and w :: "'a \<Rightarrow> real" \<comment> \<open>A mapping from objects to their respective weights (positive real numbers)\<close>
	+ and c :: nat \<comment> \<open>The maximum capacity of a bin (a natural number)\<close>
	+ and S :: "'a set" \<comment> \<open>The set of \<open>small\<close> objects (weight no larger than \<open>1/2\<close> of \<open>c\<close>)\<close>
	+ and L :: "'a set" \<comment> \<open>The set of \<open>large\<close> objects (weight larger than \<open>1/2\<close> of \<open>c\<close>)\<close>
	+ assumes weight: "\<forall>u \<in> U. 0 < w(u) \<and> w(u) \<le> c"
	+ and U_Finite: "finite U"
	+ and U_NE: "U \<noteq> {}"
	+ and S_def: "S = {u \<in> U. w(u) \<le> c / 2}"
	+ and L_def: "L = U - S"
	+begin
	+
	+text \<open>In the article, this is defined as \<open>w\<close> as well. However, to avoid ambiguity,
	+ we will abbreviate the weight of a bin as \<open>W\<close>.\<close>
	+abbreviation W :: "'a set \<Rightarrow> real" where
	+ "W B \<equiv> (\<Sum>u \<in> B. w(u))"
	+
	+text \<open>\<open>P\<close> constitutes as a correct bin packing if \<open>P\<close> is a partition of \<open>U\<close>
	+ (as defined in @{thm [source] partition_on_def}) and the weights of
	+ the bins do not exceed their maximum capacity \<open>c\<close>.\<close>
	+definition bp :: "'a set set \<Rightarrow> bool" where
	+ "bp P \<longleftrightarrow> partition_on U P \<and> (\<forall>B \<in> P. W(B) \<le> c)"
	+
	+lemma bpE:
	+ assumes "bp P"
	+ shows "pairwise disjnt P" "{} \<notin> P" "\<Union>P = U" "\<forall>B \<in> P. W(B) \<le> c"
	+ using assms unfolding bp_def partition_on_def by blast+
	+
	+lemma bpI:
	+ assumes "pairwise disjnt P" "{} \<notin> P" "\<Union>P = U" "\<forall>B \<in> P. W(B) \<le> c"
	+ shows "bp P"
	+ using assms unfolding bp_def partition_on_def by blast
	+
	+text \<open>Although we assume the \<open>S\<close> and \<open>L\<close> sets as given, manually obtaining them from \<open>U\<close> is trivial
	+ and can be achieved in linear time. Proposed by the article @{cite "BerghammerR03"}.\<close>
	+lemma S_L_set_generation:
	+"VARS S L W u
	+ {True}
	+ S := {}; L := {}; W := U;
	+ WHILE W \<noteq> {}
	+ INV {W \<subseteq> U \<and> S = {v \<in> U - W. w(v) \<le> c / 2} \<and> L = {v \<in> U - W. w(v) > c / 2}} DO
	+ u := (SOME u. u \<in> W);
	+ IF 2 * w(u) \<le> c
	+ THEN S := S \<union> {u}
	+ ELSE L := L \<union> {u} FI;
	+ W := W - {u}
	+ OD
	+ {S = {v \<in> U. w(v) \<le> c / 2} \<and> L = {v \<in> U. w(v) > c / 2}}"
	+ by vcg (auto simp: some_in_eq)
	+
	+subsection \<open>The Proposed Approximation Algorithm\<close>
	+
	+subsubsection \<open>Functional Correctness\<close>
	+
	+text \<open>According to the article, \<open>inv\<^sub>1\<close> holds if \<open>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}\<close>
	+ is a correct solution for the bin packing problem @{cite BerghammerR03}. However, various
	+ assumptions made in the article seem to suggest that more information is demanded from this
	+ invariant and, indeed, mere correctness (as defined in @{thm [source] bp_def}) does not appear to suffice.
	+ To amend this, four additional conjuncts have been added to this invariant, whose necessity
	+ will be explained in the following proofs. It should be noted that there may be other (shorter) ways to amend this invariant.
	+ This approach, however, makes for rather straight-forward proofs, as these conjuncts can be utilized and proved in relatively few steps.\<close>
	+definition inv\<^sub>1 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+ "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<longleftrightarrow> bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}) \<comment> \<open>A correct solution to the bin packing problem\<close>
	+ \<and> \<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V \<comment> \<open>The partial solution does not contain objects that have not yet been assigned\<close>
	+ \<and> B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<comment> \<open>\<open>B\<^sub>1\<close> is distinct from all the other bins\<close>
	+ \<and> B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2) \<comment> \<open>\<open>B\<^sub>2\<close> is distinct from all the other bins\<close>
	+ \<and> (P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {} \<comment> \<open>The first and second partial solutions are disjoint from each other.\<close>"
	+(*
	+lemma "partition_on U (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}) \<Longrightarrow> u \<in> V \<Longrightarrow>
	+partition_on U (P\<^sub>1 \<union> wrap (insert u B\<^sub>1) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> (V-{u})})"
	+ nitpick*)
	+lemma inv\<^sub>1E:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
	+ shows "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V})"
	+ and "\<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V"
	+ and "B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ and "B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2)"
	+ and "(P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
	+ using assms unfolding inv\<^sub>1_def by auto
	+
	+lemma inv\<^sub>1I:
	+ assumes "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V})"
	+ and "\<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V"
	+ and "B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ and "B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2)"
	+ and "(P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
	+ shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
	+ using assms unfolding inv\<^sub>1_def by blast
	+
	+lemma wrap_Un [simp]: "wrap (M \<union> {x}) = {M \<union> {x}}" unfolding wrap_def by simp
	+lemma wrap_empty [simp]: "wrap {} = {}" unfolding wrap_def by simp
	+lemma wrap_not_empty [simp]: "M \<noteq> {} \<longleftrightarrow> wrap M = {M}" unfolding wrap_def by simp
	+
	+text \<open>If \<open>inv\<^sub>1\<close> holds for the current partial solution, and the weight of an object \<open>u \<in> V\<close> added to \<open>B\<^sub>1\<close> does
	+ not exceed its capacity, then \<open>inv\<^sub>1\<close> also holds if \<open>B\<^sub>1\<close> and \<open>{u}\<close> are replaced by \<open>B\<^sub>1 \<union> {u}\<close>.\<close>
	+lemma inv\<^sub>1_stepA:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V" "W(B\<^sub>1) + w(u) \<le> c"
	+ shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
	+
	+ text \<open>In the proof for \<open>Theorem 3.2\<close> of the article it is erroneously argued that
	+ if \<open>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}\<close> is a partition of \<open>U\<close>,
	+ then the same holds if \<open>B\<^sub>1\<close> is replaced by \<open>B\<^sub>1 \<union> {u}\<close>.
	+ This is, however, not necessarily the case if \<open>B\<^sub>1\<close> or \<open>{u}\<close> are already contained in the partial solution.
	+ Suppose \<open>P\<^sub>1\<close> contains the non-empty bin \<open>B\<^sub>1\<close>, then \<open>P\<^sub>1 \<union> wrap B\<^sub>1\<close> would still be pairwise disjoint, provided \<open>P\<^sub>1\<close> was pairwise disjoint before, as the union simply ignores the duplicate \<open>B\<^sub>1\<close>. Now, if the algorithm modifies \<open>B\<^sub>1\<close> by adding an element from \<open>V\<close> such that \<open>B\<^sub>1\<close> becomes some non-empty \<open>B\<^sub>1'\<close> with \<open>B\<^sub>1 \<inter> B\<^sub>1' \<noteq> \<emptyset>\<close> and \<open>B\<^sub>1' \<notin> P\<^sub>1\<close>, one can see that this property would no longer be preserved.
	+ To avoid such a situation, we will use the first additional conjunct in \<open>inv\<^sub>1\<close> to ensure that \<open>{u}\<close>
	+ is not yet contained in the partial solution, and the second additional conjunct to ensure that \<open>B\<^sub>1\<close>
	+ is not yet contained in the partial solution.\<close>
	+
	+ \<comment> \<open>Rule 1: Pairwise Disjoint\<close>
	+ have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. u \<notin> M"
	+ using invrules(2) assms(2) by blast
	+ have "{{v} \|v. v \<in> V} = {{u}} \<union> {{v} \|v. v \<in> V - {u}}"
	+ using assms(2) by blast
	+ then have "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> ({{u}} \<union> {{v} \|v. v \<in> V - {u}}))"
	+ using bprules(1) assms(2) by simp
	+ then have "pairwise disjnt (wrap B\<^sub>1 \<union> {{u}} \<union> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}})" by (simp add: Un_commute)
	+ then have assm: "pairwise disjnt (wrap B\<^sub>1 \<union> {{u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))" by (simp add: Un_assoc)
	+ have "pairwise disjnt ({B\<^sub>1 \<union> {u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))"
	+ proof (cases \<open>B\<^sub>1 = {}\<close>)
	+ case True with assm show ?thesis by simp
	+ next
	+ case False
	+ with assm have assm: "pairwise disjnt ({B\<^sub>1} \<union> {{u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))" by simp
	+ from NOTIN have "{u} \<notin> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}" by blast
	+ from pairwise_disjnt_Un[OF assm _ this] invrules(2,3) show ?thesis
	+ using False by auto
	+ qed
	+ then have 1: "pairwise disjnt (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}})"
	+ unfolding wrap_Un by simp
	+
	+ \<comment> \<open>Rule 2: No empty sets\<close>
	+ from bprules(2) have 2: "{} \<notin> P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}"
	+ unfolding wrap_def by simp
	+
	+ \<comment> \<open>Rule 3: Union preserved\<close>
	+ from bprules(3) have "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} \|v. v \<in> V - {u}}) = U"
	+ using assms(2) by blast
	+ then have 3: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}) = U"
	+ unfolding wrap_def by force
	+
	+ \<comment> \<open>Rule 4: Weights below capacity\<close>
	+ have "0 < w u" using weight assms(2) bprules(3) by blast
	+ have "finite B\<^sub>1" using bprules(3) U_Finite by (cases \<open>B\<^sub>1 = {}\<close>) auto
	+ then have "W (B\<^sub>1 \<union> {u}) \<le> W B\<^sub>1 + w u" using \<open>0 < w u\<close> by (cases \<open>u \<in> B\<^sub>1\<close>) (auto simp: insert_absorb)
	+ also have "... \<le> c" using assms(3) .
	+ finally have "W (B\<^sub>1 \<union> {u}) \<le> c" .
	+ then have "\<forall>B \<in> wrap (B\<^sub>1 \<union> {u}). W B \<le> c" unfolding wrap_Un by blast
	+ moreover have "\<forall>B\<in>P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. W B \<le> c"
	+ using bprules(4) by blast
	+ ultimately have 4: "\<forall>B\<in>P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. W B \<le> c" by blast
	+ from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}})" .
	+
	+ \<comment> \<open>Auxiliary information is preserved\<close>
	+ have "u \<in> U" using assms(2) bprules(3) by blast
	+ then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
	+ have L: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<union> {u}"
	+ unfolding wrap_def using NOTIN by auto
	+ have 2: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - (V - {u})"
	+ unfolding L R invrules(2) ..
	+ have 3: "B\<^sub>1 \<union> {u} \<notin> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2"
	+ using NOTIN by auto
	+ have 4: "B\<^sub>2 \<notin> P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2"
	+ using invrules(4) NOTIN unfolding wrap_def by fastforce
	+ have 5: "(P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u})) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
	+ using invrules(5) NOTIN unfolding wrap_Un by auto
	+
	+ from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
	+qed
	+
	+text \<open>If \<open>inv\<^sub>1\<close> holds for the current partial solution, and the weight of an object \<open>u \<in> V\<close> added to \<open>B\<^sub>2\<close> does
	+ not exceed its capacity, then \<open>inv\<^sub>1\<close> also holds if \<open>B\<^sub>2\<close> and \<open>{u}\<close> are replaced by \<open>B\<^sub>2 \<union> {u}\<close>.\<close>
	+lemma inv\<^sub>1_stepB:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V" "W B\<^sub>2 + w u \<le> c"
	+ shows "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
	+
	+text \<open>The argumentation here is similar to the one in @{thm [source] inv\<^sub>1_stepA} with
	+ \<open>B\<^sub>1\<close> replaced with \<open>B\<^sub>2\<close> and using the first and third additional conjuncts of \<open>inv\<^sub>1\<close>
	+ to amend the issue, instead of the first and second.\<close>
	+ \<comment> \<open>Rule 1: Pairwise Disjoint\<close>
	+ have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. u \<notin> M"
	+ using invrules(2) assms(2) by blast
	+ have "{{v} \|v. v \<in> V} = {{u}} \<union> {{v} \|v. v \<in> V - {u}}"
	+ using assms(2) by blast
	+ then have "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} \|v. v \<in> V - {u}})"
	+ using bprules(1) assms(2) by simp
	+ then have assm: "pairwise disjnt (wrap B\<^sub>2 \<union> {{u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))"
	+ by (simp add: Un_assoc Un_commute)
	+ have "pairwise disjnt ({B\<^sub>2 \<union> {u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))"
	+ proof (cases \<open>B\<^sub>2 = {}\<close>)
	+ case True with assm show ?thesis by simp
	+ next
	+ case False
	+ with assm have assm: "pairwise disjnt ({B\<^sub>2} \<union> {{u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))" by simp
	+ from NOTIN have "{u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}" by blast
	+ from pairwise_disjnt_Un[OF assm _ this] invrules(2,4) show ?thesis
	+ using False by auto
	+ qed
	+ then have 1: "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} \|v. v \<in> V - {u}})"
	+ unfolding wrap_Un by simp
	+
	+ \<comment> \<open>Rule 2: No empty sets\<close>
	+ from bprules(2) have 2: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} \|v. v \<in> V - {u}}"
	+ unfolding wrap_def by simp
	+
	+ \<comment> \<open>Rule 3: Union preserved\<close>
	+ from bprules(3) have "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} \|v. v \<in> V - {u}}) = U"
	+ using assms(2) by blast
	+ then have 3: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} \|v. v \<in> V - {u}}) = U"
	+ unfolding wrap_def by force
	+
	+ \<comment> \<open>Rule 4: Weights below capacity\<close>
	+ have "0 < w u" using weight assms(2) bprules(3) by blast
	+ have "finite B\<^sub>2" using bprules(3) U_Finite by (cases \<open>B\<^sub>2 = {}\<close>) auto
	+ then have "W (B\<^sub>2 \<union> {u}) \<le> W B\<^sub>2 + w u" using \<open>0 < w u\<close> by (cases \<open>u \<in> B\<^sub>2\<close>) (auto simp: insert_absorb)
	+ also have "... \<le> c" using assms(3) .
	+ finally have "W (B\<^sub>2 \<union> {u}) \<le> c" .
	+ then have "\<forall>B \<in> wrap (B\<^sub>2 \<union> {u}). W B \<le> c" unfolding wrap_Un by blast
	+ moreover have "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. W B \<le> c"
	+ using bprules(4) by blast
	+ ultimately have 4: "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} \|v. v \<in> V - {u}}. W B \<le> c"
	+ by auto
	+ from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} \|v. v \<in> V - {u}})" .
	+
	+ \<comment> \<open>Auxiliary information is preserved\<close>
	+ have "u \<in> U" using assms(2) bprules(3) by blast
	+ then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
	+ have L: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<union> {u}"
	+ unfolding wrap_def using NOTIN by auto
	+ have 2: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = U - (V - {u})"
	+ unfolding L R using invrules(2) by simp
	+ have 3: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})"
	+ using bpE(2)[OF 1] by simp
	+ have 4: "B\<^sub>2 \<union> {u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2"
	+ using NOTIN by auto
	+ have 5: "(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}) \<inter> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = {}"
	+ using invrules(5) NOTIN unfolding wrap_empty wrap_Un by auto
	+
	+ from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
	+qed
	+
	+text \<open>If \<open>inv\<^sub>1\<close> holds for the current partial solution, then \<open>inv\<^sub>1\<close> also holds if \<open>B\<^sub>1\<close> and \<open>B\<^sub>2\<close> are
	+ added to \<open>P\<^sub>1\<close> and \<open>P\<^sub>2\<close> respectively, \<open>B\<^sub>1\<close> is emptied and \<open>B\<^sub>2\<close> initialized with \<open>u \<in> V\<close>.\<close>
	+lemma inv\<^sub>1_stepC:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V"
	+ shows "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(1)]
	+ \<comment> \<open>Rule 1-4: Correct Bin Packing\<close>
	+ have "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} \|v. v \<in> V - {u}}
	+ = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} \|v. v \<in> V - {u}}"
	+ by (metis (no_types, lifting) Un_assoc Un_empty_right insert_not_empty wrap_empty wrap_not_empty)
	+ also have "... = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}"
	+ using assms(2) by auto
	+ finally have EQ: "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} \|v. v \<in> V - {u}}
	+ = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}" .
	+ from invrules(1) have 1: "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} \|v. v \<in> V - {u}})"
	+ unfolding EQ .
	+
	+ \<comment> \<open>Auxiliary information is preserved\<close>
	+ have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. u \<notin> M"
	+ using invrules(2) assms(2) by blast
	+ have "u \<in> U" using assms(2) bpE(3)[OF invrules(1)] by blast
	+ then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
	+ have L: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}"
	+ unfolding wrap_def using NOTIN by auto
	+ have 2: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}) = U - (V - {u})"
	+ unfolding L R using invrules(2) by auto
	+ have 3: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}"
	+ using bpE(2)[OF 1] by simp
	+ have 4: "{u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using NOTIN by auto
	+ have 5: "(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}) = {}"
	+ using invrules(5) NOTIN unfolding wrap_def by force
	+
	+ from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
	+qed
	+
	+text \<open>A simplified version of the bin packing algorithm proposed in the article.
	+ It serves as an introduction into the approach taken, and, while it does not provide the desired
	+ approximation factor, it does ensure that \<open>P\<close> is a correct solution of the bin packing problem.\<close>
	+lemma simple_bp_correct:
	+"VARS P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u
	+ {True}
	+ P\<^sub>1 := {}; P\<^sub>2 := {}; B\<^sub>1 := {}; B\<^sub>2 := {}; V := U;
	+ WHILE V \<inter> S \<noteq> {} INV {inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V} DO
	+ u := (SOME u. u \<in> V); V := V - {u};
	+ IF W(B\<^sub>1) + w(u) \<le> c
	+ THEN B\<^sub>1 := B\<^sub>1 \<union> {u}
	+ ELSE IF W(B\<^sub>2) + w(u) \<le> c
	+ THEN B\<^sub>2 := B\<^sub>2 \<union> {u}
	+ ELSE P\<^sub>2 := P\<^sub>2 \<union> wrap B\<^sub>2; B\<^sub>2 := {u} FI;
	+ P\<^sub>1 := P\<^sub>1 \<union> wrap B\<^sub>1; B\<^sub>1 := {} FI
	+ OD;
	+ P := P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \| v. v \<in> V}
	+ {bp P}"
	+proof (vcg, goal_cases)
	+ case (1 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
	+ show ?case
	+ unfolding bp_def partition_on_def pairwise_def wrap_def inv\<^sub>1_def
	+ using weight by auto
	+next
	+ case (2 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
	+ then have INV: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" ..
	+ from 2 have "V \<noteq> {}" by blast
	+ then have IN: "(SOME u. u \<in> V) \<in> V" by (simp add: some_in_eq)
	+ from inv\<^sub>1_stepA[OF INV IN] inv\<^sub>1_stepB[OF INV IN] inv\<^sub>1_stepC[OF INV IN]
	+ show ?case by blast
	+next
	+ case (3 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
	+ then show ?case unfolding inv\<^sub>1_def by blast
	+qed
	+
	+subsubsection \<open>Lower Bounds for the Bin Packing Problem\<close>
	+
	+lemma bp_bins_finite [simp]:
	+ assumes "bp P"
	+ shows "\<forall>B \<in> P. finite B"
	+ using bpE(3)[OF assms] U_Finite by (meson Sup_upper finite_subset)
	+
	+lemma bp_sol_finite [simp]:
	+ assumes "bp P"
	+ shows "finite P"
	+ using bpE(3)[OF assms] U_Finite by (simp add: finite_UnionD)
	+
	+text \<open>If \<open>P\<close> is a solution of the bin packing problem, then no bin in \<open>P\<close> may contain more than
	+ one large object.\<close>
	+lemma only_one_L_per_bin:
	+ assumes "bp P" "B \<in> P"
	+ shows "\<forall>x \<in> B. \<forall>y \<in> B. x \<noteq> y \<longrightarrow> x \<notin> L \<or> y \<notin> L"
	+proof (rule ccontr, simp)
	+ assume "\<exists>x\<in>B. \<exists>y\<in>B. x \<noteq> y \<and> x \<in> L \<and> y \<in> L"
	+ then obtain x y where *: "x \<in> B" "y \<in> B" "x \<noteq> y" "x \<in> L" "y \<in> L" by blast
	+ then have "c < w x + w y" using L_def S_def by force
	+ have "finite B" using assms by simp
	+ have "y \<in> B - {x}" using *(2,3) by blast
	+ have "W B = W (B - {x}) + w x"
	+ using *(1) \<open>finite B\<close> by (simp add: sum.remove)
	+ also have "... = W (B - {x} - {y}) + w x + w y"
	+ using \<open>y \<in> B - {x}\<close> \<open>finite B\<close> by (simp add: sum.remove)
	+ finally have *: "W B = W (B - {x} - {y}) + w x + w y" .
	+ have "\<forall>u \<in> B. 0 < w u" using bpE(3)[OF assms(1)] assms(2) weight by blast
	+ then have "0 \<le> W (B - {x} - {y})" by (smt DiffD1 sum_nonneg)
	+ with * have "c < W B" using \<open>c < w x + w y\<close> by simp
	+ then show False using bpE(4)[OF assms(1)] assms(2) by fastforce
	+qed
	+
	+text \<open>If \<open>P\<close> is a solution of the bin packing problem, then the amount of large objects
	+ is a lower bound for the amount of bins in P.\<close>
	+lemma L_lower_bound_card:
	+ assumes "bp P"
	+ shows "card L \<le> card P"
	+proof -
	+ have "\<forall>x \<in> L. \<exists>B \<in> P. x \<in> B"
	+ using bpE(3)[OF assms] L_def by blast
	+ then obtain f where f_def: "\<forall>u \<in> L. u \<in> f u \<and> f u \<in> P" by metis
	+ then have "inj_on f L"
	+ unfolding inj_on_def using only_one_L_per_bin[OF assms] by blast
	+ then have card_eq: "card L = card (f ` L)" by (simp add: card_image)
	+ have "f ` L \<subseteq> P" using f_def by blast
	+ moreover have "finite P" using assms by simp
	+ ultimately have "card (f ` L) \<le> card P" by (simp add: card_mono)
	+ then show ?thesis unfolding card_eq .
	+qed
	+
	+text \<open>If \<open>P\<close> is a solution of the bin packing problem, then the amount of bins of a subset of P
	+ in which every bin contains a large object is a lower bound on the amount of large objects.\<close>
	+lemma subset_bp_card:
	+ assumes "bp P" "M \<subseteq> P" "\<forall>B \<in> M. B \<inter> L \<noteq> {}"
	+ shows "card M \<le> card L"
	+proof -
	+ have "\<forall>B \<in> M. \<exists>u \<in> L. u \<in> B" using assms(3) by fast
	+ then have "\<exists>f. \<forall>B \<in> M. f B \<in> L \<and> f B \<in> B" by metis
	+ then obtain f where f_def: "\<forall>B \<in> M. f B \<in> L \<and> f B \<in> B" ..
	+ have "inj_on f M"
	+ proof (rule ccontr)
	+ assume "\<not> inj_on f M"
	+ then have "\<exists>x \<in> M. \<exists>y \<in> M. x \<noteq> y \<and> f x = f y" unfolding inj_on_def by blast
	+ then obtain x y where *: "x \<in> M" "y \<in> M" "x \<noteq> y" "f x = f y" by blast
	+ then have "\<exists>u. u \<in> x \<and> u \<in> y" using f_def by metis
	+ then have "x \<inter> y \<noteq> {}" by blast
	+ moreover have "pairwise disjnt M" using pairwise_subset[OF bpE(1)[OF assms(1)] assms(2)] .
	+ ultimately show False using * unfolding pairwise_def disjnt_def by simp
	+ qed
	+ moreover have "finite L" using L_def U_Finite by blast
	+ moreover have "f ` M \<subseteq> L" using f_def by blast
	+ ultimately show ?thesis using card_inj_on_le by blast
	+qed
	+
	+text \<open>If \<open>P\<close> is a correct solution of the bin packing problem, \<open>inv\<^sub>1\<close> holds for the partial solution,
	+ and every bin in \<open>P\<^sub>1 \<union> wrap B\<^sub>1\<close> contains a large object, then the amount of bins in
	+ \<open>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> V \<inter> L}\<close> is a lower bound for the amount of bins in \<open>P\<close>.\<close>
	+lemma L_bins_lower_bound_card:
	+ assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L \<noteq> {}"
	+ shows "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> V \<inter> L}) \<le> card P"
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(2)]
	+ have "\<forall>B \<in> {{v} \|v. v \<in> V \<inter> L}. B \<inter> L \<noteq> {}" by blast
	+ with assms(3) have
	+ "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> V \<inter> L} \<subseteq> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}"
	+ "\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> V \<inter> L}. B \<inter> L \<noteq> {}" by blast+
	+ from subset_bp_card[OF invrules(1) this] show ?thesis
	+ using L_lower_bound_card[OF assms(1)] by linarith
	+qed
	+
	+text \<open>If \<open>P\<close> is a correct solution of the bin packing problem, then the sum of the weights of the
	+ objects is equal to the sum of the weights of the bins in \<open>P\<close>.\<close>
	+lemma sum_Un_eq_sum_sum:
	+ assumes "bp P"
	+ shows "(\<Sum>u \<in> U. w u) = (\<Sum>B \<in> P. W B)"
	+proof -
	+ have FINITE: "\<forall>B \<in> P. finite B" using assms by simp
	+ have DISJNT: "\<forall>A \<in> P. \<forall>B \<in> P. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
	+ using bpE(1)[OF assms] unfolding pairwise_def disjnt_def .
	+ have "(\<Sum>u \<in> (\<Union>P). w u) = (\<Sum>B \<in> P. W B)"
	+ using sum.Union_disjoint[OF FINITE DISJNT] by auto
	+ then show ?thesis unfolding bpE(3)[OF assms] .
	+qed
	+
	+text \<open>If \<open>P\<close> is a correct solution of the bin packing problem, then the sum of the weights of the items
	+ is a lower bound of amount of bins in \<open>P\<close> multiplied by their maximum capacity.\<close>
	+lemma sum_lower_bound_card:
	+ assumes "bp P"
	+ shows "(\<Sum>u \<in> U. w u) \<le> c * card P"
	+proof -
	+ have *: "\<forall>B \<in> P. 0 < W B \<and> W B \<le> c"
	+ using bpE(2-4)[OF assms] weight by (metis UnionI assms bp_bins_finite sum_pos)
	+ have "(\<Sum>u \<in> U. w u) = (\<Sum>B \<in> P. W B)"
	+ using sum_Un_eq_sum_sum[OF assms] .
	+ also have "... \<le> (\<Sum>B \<in> P. c)" using sum_mono * by fastforce
	+ also have "... = c * card P" by simp
	+ finally show ?thesis .
	+qed
	+
	+lemma bp_NE:
	+ assumes "bp P"
	+ shows "P \<noteq> {}"
	+ using U_NE bpE(3)[OF assms] by blast
	+
	+lemma sum_Un_ge:
	+ fixes f :: "_ \<Rightarrow> real"
	+ assumes "finite M" "finite N" "\<forall>B \<in> M \<union> N. 0 < f B"
	+ shows "sum f M \<le> sum f (M \<union> N)"
	+proof -
	+ have "0 \<le> sum f N - sum f (M \<inter> N)"
	+ using assms by (smt DiffD1 inf.cobounded2 UnCI sum_mono2)
	+ then have "sum f M \<le> sum f M + sum f N - sum f (M \<inter> N)"
	+ by simp
	+ also have "... = sum f (M \<union> N)"
	+ using sum_Un[OF assms(1,2), symmetric] .
	+ finally show ?thesis .
	+qed
	+
	+text \<open>If \<open>bij_exists\<close> holds, one can obtain a function which is bijective between the bins in \<open>P\<close>
	+and the objects in \<open>V\<close> such that an object returned by the function would cause the bin to
	+exceed its capacity.\<close>
	+definition bij_exists :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+ "bij_exists P V = (\<exists>f. bij_betw f P V \<and> (\<forall>B \<in> P. W B + w (f B) > c))"
	+
	+text \<open>If \<open>P\<close> is a functionally correct solution of the bin packing problem, \<open>inv\<^sub>1\<close> holds for the
	+partial solution, and such a bijective function exists between the bins in \<open>P\<^sub>1\<close> and the objects in
	+@{term "P\<^sub>2 \<union> wrap B\<^sub>2"}, the following strict lower bound can be shown:\<close>
	+lemma P\<^sub>1_lower_bound_card:
	+ assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ shows "card P\<^sub>1 + 1 \<le> card P"
	+proof (cases \<open>P\<^sub>1 = {}\<close>)
	+ case True
	+ have "finite P" using assms(1) by simp
	+ then have "1 \<le> card P" using bp_NE[OF assms(1)]
	+ by (metis Nat.add_0_right Suc_diff_1 Suc_le_mono card_gt_0_iff le0 mult_Suc_right nat_mult_1)
	+ then show ?thesis unfolding True by simp
	+next
	+ note invrules = inv\<^sub>1E[OF assms(2)]
	+ case False
	+ obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B \<in> P\<^sub>1. W B + w (f B) > c"
	+ using assms(3) unfolding bij_exists_def by blast
	+ have FINITE: "finite P\<^sub>1" "finite (P\<^sub>2 \<union> wrap B\<^sub>2)" "finite (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)" "finite (wrap B\<^sub>1 \<union> {{v} \|v. v \<in> V})"
	+ using inv\<^sub>1E(1)[OF assms(2)] bp_sol_finite by blast+
	+
	+ have F: "\<forall>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. finite B" using invrules(1) by simp
	+ have D: "\<forall>A \<in> P\<^sub>2 \<union> wrap B\<^sub>2. \<forall>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
	+ using bpE(1)[OF invrules(1)] unfolding pairwise_def disjnt_def by auto
	+ have sum_eq: "W (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) = (\<Sum>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. W B)"
	+ using sum.Union_disjoint[OF F D] by auto
	+
	+ have "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}. 0 < W B"
	+ using bpE(2,3)[OF invrules(1)] weight by (metis (no_types, lifting) UnionI bp_bins_finite invrules(1) sum_pos)
	+ then have "(\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B) \<le> (\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> (wrap B\<^sub>1 \<union> {{v} \|v. v \<in> V}). W B)"
	+ using sum_Un_ge[OF FINITE(3,4), of W] by blast
	+ also have "... = (\<Sum>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}. W B)" by (smt Un_assoc Un_commute)
	+ also have "... = W U" using sum_Un_eq_sum_sum[OF invrules(1), symmetric] .
	+ finally have *: "(\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B) \<le> W U" .
	+
	+ \<comment> \<open>This follows from the fourth and final additional conjunct of \<open>inv\<^sub>1\<close> and is necessary to combine the sums of the bins
	+ of the two partial solutions. This does not inherently follow from the union being a correct solution,
	+ as this need not be the case if \<open>P\<^sub>1\<close> and \<open>P\<^sub>2 \<union> wrap B\<^sub>2\<close> happened to be equal.\<close>
	+ have DISJNT: "P\<^sub>1 \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}" using invrules(5) by blast
	+
	+ \<comment> \<open>This part of the proof is based on the proof on page 72 of the article @{cite BerghammerR03}.\<close>
	+ have "c * card P\<^sub>1 = (\<Sum>B \<in> P\<^sub>1. c)" by simp
	+ also have "... < (\<Sum>B \<in> P\<^sub>1. W B + w (f B))"
	+ using f_def(2) sum_strict_mono[OF FINITE(1) False] by fastforce
	+ also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + (\<Sum>B \<in> P\<^sub>1. w (f B))"
	+ by (simp add: Groups_Big.comm_monoid_add_class.sum.distrib)
	+ also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + W (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" unfolding sum.reindex_bij_betw[OF f_def(1), of w] ..
	+ also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + (\<Sum>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. W B)" unfolding sum_eq ..
	+ also have "... = (\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B)" using sum.union_disjoint[OF FINITE(1,2) DISJNT, of W] by (simp add: Un_assoc)
	+ also have "... \<le> (\<Sum>u \<in> U. w u)" using * .
	+ also have "... \<le> c * card P" using sum_lower_bound_card[OF assms(1)] .
	+ finally show ?thesis by (meson discrete nat_mult_less_cancel_disj of_nat_less_imp_less)
	+qed
	+
	+text \<open>As @{thm wrap_card} holds, it follows that the amount of bins in \<open>P\<^sub>1 \<union> wrap B\<^sub>1\<close>
	+ are a lower bound for the amount of bins in \<open>P\<close>.\<close>
	+lemma P\<^sub>1_B\<^sub>1_lower_bound_card:
	+ assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ shows "card (P\<^sub>1 \<union> wrap B\<^sub>1) \<le> card P"
	+proof -
	+ have "card (P\<^sub>1 \<union> wrap B\<^sub>1) \<le> card P\<^sub>1 + card (wrap B\<^sub>1)"
	+ using card_Un_le by blast
	+ also have "... \<le> card P\<^sub>1 + 1" using wrap_card by simp
	+ also have "... \<le> card P" using P\<^sub>1_lower_bound_card[OF assms] .
	+ finally show ?thesis .
	+qed
	+
	+text \<open>If \<open>inv\<^sub>1\<close> holds, there are at most half as many bins in \<open>P\<^sub>2\<close> as there are objects in \<open>P\<^sub>2\<close>, and we can again
	+ obtain a bijective function between the bins in \<open>P\<^sub>1\<close> and the objects of the second partial solution,
	+ then the amount of bins in the second partial solution are a strict lower bound for half the bins of
	+ the first partial solution.\<close>
	+lemma P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ shows "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> card P\<^sub>1 + 1"
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
	+
	+ have "pairwise disjnt (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using bprules(1) pairwise_subset by blast
	+ moreover have "B\<^sub>2 \<notin> P\<^sub>2" using invrules(4) by simp
	+ ultimately have DISJNT: "\<Union>P\<^sub>2 \<inter> B\<^sub>2 = {}"
	+ by (auto, metis (no_types, hide_lams) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un)
	+
	+ have "finite (\<Union>P\<^sub>2)" using U_Finite bprules(3) by auto
	+ have "finite B\<^sub>2" using bp_bins_finite[OF invrules(1)] wrap_not_empty by blast
	+ have "finite P\<^sub>2" "finite (wrap B\<^sub>2)" using bp_sol_finite[OF invrules(1)] by blast+
	+ have DISJNT2: "P\<^sub>2 \<inter> wrap B\<^sub>2 = {}" unfolding wrap_def using \<open>B\<^sub>2 \<notin> P\<^sub>2\<close> by auto
	+ have "card (wrap B\<^sub>2) \<le> card B\<^sub>2"
	+ proof (cases \<open>B\<^sub>2 = {}\<close>)
	+ case False
	+ then have "1 \<le> card B\<^sub>2" by (simp add: leI \<open>finite B\<^sub>2\<close>)
	+ then show ?thesis using wrap_card[of B\<^sub>2] by linarith
	+ qed simp
	+
	+ \<comment> \<open>This part of the proof is based on the proof on page 73 of the article @{cite BerghammerR03}.\<close>
	+ from assms(2) have "2 * card P\<^sub>2 + 2 * card (wrap B\<^sub>2) \<le> card (\<Union>P\<^sub>2) + card (wrap B\<^sub>2) + 1"
	+ using wrap_card[of B\<^sub>2] by linarith
	+ then have "2 * (card P\<^sub>2 + card (wrap B\<^sub>2)) \<le> card (\<Union>P\<^sub>2) + card B\<^sub>2 + 1"
	+ using \<open>card (wrap B\<^sub>2) \<le> card B\<^sub>2\<close> by simp
	+ then have "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card (\<Union>P\<^sub>2 \<union> B\<^sub>2) + 1"
	+ using card_Un_disjoint[OF \<open>finite (\<Union>P\<^sub>2)\<close> \<open>finite B\<^sub>2\<close> DISJNT]
	+ and card_Un_disjoint[OF \<open>finite P\<^sub>2\<close> \<open>finite (wrap B\<^sub>2)\<close> DISJNT2] by argo
	+ then have "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2)) + 1"
	+ by (cases \<open>B\<^sub>2 = {}\<close>) (auto simp: Un_commute)
	+ then show "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card P\<^sub>1 + 1"
	+ using assms(3) bij_betw_same_card unfolding bij_exists_def by metis
	+qed
	+
	+subsubsection \<open>Proving the Approximation Factor\<close>
	+
	+text \<open>We define \<open>inv\<^sub>2\<close> as it is defined in the article.
	+ These conjuncts allow us to prove the desired approximation factor.\<close>
	+definition inv\<^sub>2 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+ "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<longleftrightarrow> inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<comment> \<open>\<open>inv\<^sub>1\<close> holds for the partial solution\<close>
	+ \<and> (V \<inter> L \<noteq> {} \<longrightarrow> (\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L \<noteq> {})) \<comment> \<open>If there are still large objects left, then every bin of the first partial solution must contain a large object\<close>
	+ \<and> bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2)) \<comment> \<open>There exists a bijective function between the bins of the first partial solution and the objects of the second one\<close>
	+ \<and> (2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)) \<comment> \<open>There are at most twice as many bins in \<open>P\<^sub>2\<close> as there are objects in \<open>P\<^sub>2\<close>\<close>"
	+
	+lemma inv\<^sub>2E:
	+ assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
	+ shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
	+ and "V \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L \<noteq> {}"
	+ and "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ and "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)"
	+ using assms unfolding inv\<^sub>2_def by blast+
	+
	+lemma inv\<^sub>2I:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
	+ and "V \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L \<noteq> {}"
	+ and "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ and "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)"
	+ shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
	+ using assms unfolding inv\<^sub>2_def by blast
	+
	+text \<open>If \<open>P\<close> is a correct solution of the bin packing problem, \<open>inv\<^sub>2\<close> holds for the partial solution,
	+ and there are no more small objects left to be distributed, then the amount of bins of the partial solution
	+ is no larger than \<open>3 / 2\<close> of the amount of bins in \<open>P\<close>. This proof strongly follows the proof in
	+ \<open>Theorem 4.1\<close> of the article @{cite BerghammerR03}.\<close>
	+lemma bin_packing_lower_bound_card:
	+ assumes "V \<inter> S = {}" "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "bp P"
	+ shows "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}) \<le> 3 / 2 * card P"
	+proof (cases \<open>V = {}\<close>)
	+ note invrules = inv\<^sub>2E[OF assms(2)]
	+ case True
	+ then have "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V})
	+ = card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)" by simp
	+ also have "... \<le> card (P\<^sub>1 \<union> wrap B\<^sub>1) + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using card_Un_le[of \<open>P\<^sub>1 \<union> wrap B\<^sub>1\<close>] by (simp add: Un_assoc)
	+ also have "... \<le> card P + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using P\<^sub>1_B\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by simp
	+ also have "... \<le> card P + card P / 2"
	+ using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)]
	+ and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith
	+ finally show ?thesis by linarith
	+next
	+ note invrules = inv\<^sub>2E[OF assms(2)]
	+ case False
	+ have "U = S \<union> L" using S_def L_def by blast
	+ then have *: "V = V \<inter> L"
	+ using bpE(3)[OF inv\<^sub>1E(1)[OF invrules(1)]]
	+ and assms(1) by blast
	+ with False have NE: "V \<inter> L \<noteq> {}" by simp
	+ have "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V})
	+ = card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> V \<inter> L} \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using * by (simp add: Un_commute Un_assoc)
	+ also have "... \<le> card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> V \<inter> L}) + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using card_Un_le[of \<open>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> V \<inter> L}\<close>] by (simp add: Un_assoc)
	+ also have "... \<le> card P + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using L_bins_lower_bound_card[OF assms(3) invrules(1) invrules(2)[OF NE]] by linarith
	+ also have "... \<le> card P + card P / 2"
	+ using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)]
	+ and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith
	+ finally show ?thesis by linarith
	+qed
	+
	+text \<open>We define \<open>inv\<^sub>3\<close> as it is defined in the article.
	+ This final conjunct allows us to prove that the invariant will be maintained by the algorithm.\<close>
	+definition inv\<^sub>3 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+ "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<longleftrightarrow> inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<and> B\<^sub>2 \<subseteq> S"
	+
	+lemma inv\<^sub>3E:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
	+ shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and "B\<^sub>2 \<subseteq> S"
	+ using assms unfolding inv\<^sub>3_def by blast+
	+
	+lemma inv\<^sub>3I:
	+ assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and "B\<^sub>2 \<subseteq> S"
	+ shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
	+ using assms unfolding inv\<^sub>3_def by blast
	+
	+lemma loop_init:
	+ "inv\<^sub>3 {} {} {} {} U"
	+proof -
	+ have *: "inv\<^sub>1 {} {} {} {} U"
	+ unfolding bp_def partition_on_def pairwise_def wrap_def inv\<^sub>1_def
	+ using weight by auto
	+ have "bij_exists {} (\<Union> ({} \<union> wrap {}))"
	+ using bij_betwI' unfolding bij_exists_def by fastforce
	+ from inv\<^sub>2I[OF * _ this] have "inv\<^sub>2 {} {} {} {} U" by auto
	+ from inv\<^sub>3I[OF this] show ?thesis by blast
	+qed
	+
	+text \<open>If \<open>B\<^sub>1\<close> is empty and there are no large objects left, then \<open>inv\<^sub>3\<close> will be maintained
	+ if \<open>B\<^sub>1\<close> is initialized with \<open>u \<in> V \<inter> S\<close>.\<close>
	+lemma loop_stepA:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 = {}" "V \<inter> L = {}" "u \<in> V \<inter> S"
	+ shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
	+ have WEIGHT: "W B\<^sub>1 + w u \<le> c" using S_def assms(2,4) by simp
	+ from assms(4) have "u \<in> V" by blast
	+ from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2) have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by simp
	+ have 2: "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap {u}. B \<inter> L \<noteq> {}" using assms(3) by blast
	+ from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by blast
	+ from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
	+qed
	+
	+text \<open>If \<open>B\<^sub>1\<close> is empty and there are large objects left, then \<open>inv\<^sub>3\<close> will be maintained
	+ if \<open>B\<^sub>1\<close> is initialized with \<open>u \<in> V \<inter> L\<close>.\<close>
	+lemma loop_stepB:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 = {}" "u \<in> V \<inter> L"
	+ shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
	+ have WEIGHT: "W B\<^sub>1 + w u \<le> c" using L_def weight assms(2,3) by simp
	+ from assms(3) have "u \<in> V" by blast
	+ from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2) have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by simp
	+ have "\<forall>B\<in>P\<^sub>1. B \<inter> L \<noteq> {}" using assms(3) invrules(2) by blast
	+ then have 2: "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap {u}. B \<inter> L \<noteq> {}"
	+ using assms(3) by (metis Int_iff UnE empty_iff insertE singletonI wrap_not_empty)
	+ from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by blast
	+ from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
	+qed
	+
	+text \<open>If \<open>B\<^sub>1\<close> is not empty and \<open>u \<in> V \<inter> S\<close> does not exceed its maximum capacity, then \<open>inv\<^sub>3\<close>
	+ will be maintained if \<open>B\<^sub>1\<close> and \<open>{u}\<close> are replaced with \<open>B\<^sub>1 \<union> {u}\<close>.\<close>
	+lemma loop_stepC:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 \<noteq> {}" "u \<in> V \<inter> S" "W B\<^sub>1 + w(u) \<le> c"
	+ shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
	+ from assms(3) have "u \<in> V" by blast
	+ from inv\<^sub>1_stepA[OF invrules(1) this assms(4)] have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (V - {u})" .
	+ have "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L \<noteq> {}" using invrules(2) by blast
	+ then have 2: "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}). B \<inter> L \<noteq> {}"
	+ by (metis Int_commute Un_empty_right Un_insert_right assms(2) disjoint_insert(2) insert_iff wrap_not_empty)
	+ from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (V - {u})" by blast
	+ from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
	+qed
	+
	+text \<open>If \<open>B\<^sub>1\<close> is not empty and \<open>u \<in> V \<inter> S\<close> does exceed its maximum capacity but not the capacity of \<open>B\<^sub>2\<close>,
	+ then \<open>inv\<^sub>3\<close> will be maintained if \<open>B\<^sub>1\<close> is added to \<open>P\<^sub>1\<close> and emptied, and \<open>B\<^sub>2\<close> and \<open>{u}\<close> are replaced with \<open>B\<^sub>2 \<union> {u}\<close>.\<close>
	+lemma loop_stepD:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 \<noteq> {}" "u \<in> V \<inter> S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) \<le> c"
	+ shows "inv\<^sub>3 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
	+ from assms(3) have "u \<in> V" by blast
	+ from inv\<^sub>1_stepB[OF invrules(1) this assms(5)] have 1: "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (V - {u})" .
	+
	+ have 2: "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}. B \<inter> L \<noteq> {}"
	+ using invrules(2) unfolding wrap_empty by blast
	+
	+ from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B\<in>P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast
	+ have "B\<^sub>1 \<notin> P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast
	+ have "u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast
	+ then have "(\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}))) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}}))"
	+ by (metis Sup_empty Un_assoc Union_Un_distrib ccpo_Sup_singleton wrap_empty wrap_not_empty)
	+ also have "... = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" by simp
	+ finally have UN: "(\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}))) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" .
	+ have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp
	+ let ?f = "f (B\<^sub>1 := u)"
	+ have BIJ: "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))"
	+ unfolding wrap_empty \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> UN using f_def(1) \<open>B\<^sub>1 \<notin> P\<^sub>1\<close> \<open>u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))\<close>
	+ by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3)
	+ have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp
	+ then have "(\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))"
	+ unfolding \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> using f_def(2) by simp
	+ with BIJ have "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))
	+ \<and> (\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))" by blast
	+ then have 3: "bij_exists (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))"
	+ unfolding bij_exists_def by blast
	+ from inv\<^sub>2I[OF 1 2 3] have "inv\<^sub>2 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (V - {u})" using invrules(4) by blast
	+
	+ from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] assms(3) by blast
	+qed
	+
	+text \<open>If the maximum capacity of \<open>B\<^sub>2\<close> is exceeded by \<open>u \<in> V \<inter> S\<close>,
	+ then \<open>B\<^sub>2\<close> must contain at least two objects.\<close>
	+lemma B\<^sub>2_at_least_two_objects:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V \<inter> S" "W B\<^sub>2 + w(u) > c"
	+ shows "2 \<le> card B\<^sub>2"
	+proof (rule ccontr, simp add: not_le)
	+ have FINITE: "finite B\<^sub>2" using inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF inv\<^sub>3E(1)[OF assms(1)]]]
	+ by (metis (no_types, lifting) Finite_Set.finite.simps U_Finite Union_Un_distrib bpE(3) ccpo_Sup_singleton finite_Un wrap_not_empty)
	+ assume "card B\<^sub>2 < 2"
	+ then consider (0) "card B\<^sub>2 = 0" \| (1) "card B\<^sub>2 = 1" by linarith
	+ then show False proof cases
	+ case 0 then have "B\<^sub>2 = {}" using FINITE by simp
	+ then show ?thesis using assms(2,3) S_def by simp
	+ next
	+ case 1 then obtain v where "B\<^sub>2 = {v}"
	+ using card_1_singletonE by auto
	+ with inv\<^sub>3E(2)[OF assms(1)] have "2 * w v \<le> c" using S_def by simp
	+ moreover from \<open>B\<^sub>2 = {v}\<close> have "W B\<^sub>2 = w v" by simp
	+ ultimately show ?thesis using assms(2,3) S_def by simp
	+ qed
	+qed
	+
	+text \<open>If \<open>B\<^sub>1\<close> is not empty and \<open>u \<in> V \<inter> S\<close> exceeds the maximum capacity of both \<open>B\<^sub>1\<close> and \<open>B\<^sub>2\<close>,
	+ then \<open>inv\<^sub>3\<close> will be maintained if \<open>B\<^sub>1\<close> and \<open>B\<^sub>2\<close> are added to \<open>P\<^sub>1\<close> and \<open>P\<^sub>2\<close> respectively,
	+ emptied, and \<open>B\<^sub>2\<close> initialized with \<open>u\<close>.\<close>
	+lemma loop_stepE:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 \<noteq> {}" "u \<in> V \<inter> S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) > c"
	+ shows "inv\<^sub>3 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
	+ from assms(3) have "u \<in> V" by blast
	+ from inv\<^sub>1_stepC[OF invrules(1) this] have 1: "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (V - {u})" .
	+
	+ have 2: "(V - {u}) \<inter> L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}. B \<inter> L \<noteq> {}"
	+ using invrules(2) unfolding wrap_empty by blast
	+
	+ from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B\<in>P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast
	+ have "B\<^sub>1 \<notin> P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast
	+ have "u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast
	+ have "(\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u})) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}}))" unfolding wrap_def by simp
	+ also have "... = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" by simp
	+ finally have UN: "(\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u})) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" .
	+ have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp
	+ let ?f = "f (B\<^sub>1 := u)"
	+ have BIJ: "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))"
	+ unfolding wrap_empty \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> UN using f_def(1) \<open>B\<^sub>1 \<notin> P\<^sub>1\<close> \<open>u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))\<close>
	+ by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3)
	+ have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp
	+ then have "(\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))"
	+ unfolding \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> using f_def(2) by simp
	+ with BIJ have "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))
	+ \<and> (\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))" by blast
	+ then have 3: "bij_exists (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))"
	+ unfolding bij_exists_def by blast
	+
	+ have 4: "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> card (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ proof -
	+ note bprules = bpE[OF inv\<^sub>1E(1)[OF invrules(1)]]
	+ have "pairwise disjnt (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using bprules(1) pairwise_subset by blast
	+ moreover have "B\<^sub>2 \<notin> P\<^sub>2" using inv\<^sub>1E(4)[OF invrules(1)] by simp
	+ ultimately have DISJNT: "\<Union>P\<^sub>2 \<inter> B\<^sub>2 = {}"
	+ by (auto, metis (no_types, hide_lams) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un)
	+ have "finite (\<Union>P\<^sub>2)" using U_Finite bprules(3) by auto
	+ have "finite B\<^sub>2" using inv\<^sub>1E(1)[OF invrules(1)] bp_bins_finite wrap_not_empty by blast
	+
	+ have "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> 2 * (card P\<^sub>2 + card (wrap B\<^sub>2))"
	+ using card_Un_le[of P\<^sub>2 \<open>wrap B\<^sub>2\<close>] by simp
	+ also have "... \<le> 2 * card P\<^sub>2 + 2" using wrap_card by auto
	+ also have "... \<le> card (\<Union> P\<^sub>2) + 2" using invrules(4) by simp
	+ also have "... \<le> card (\<Union> P\<^sub>2) + card B\<^sub>2" using B\<^sub>2_at_least_two_objects[OF assms(1,3,5)] by simp
	+ also have "... = card (\<Union> (P\<^sub>2 \<union> {B\<^sub>2}))" using DISJNT card_Un_disjoint[OF \<open>finite (\<Union>P\<^sub>2)\<close> \<open>finite B\<^sub>2\<close>] by (simp add: Un_commute)
	+ also have "... = card (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" by (cases \<open>B\<^sub>2 = {}\<close>) auto
	+ finally show ?thesis .
	+ qed
	+ from inv\<^sub>2I[OF 1 2 3 4] have "inv\<^sub>2 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (V - {u})" .
	+
	+ from inv\<^sub>3I[OF this] show ?thesis using assms(3) by blast
	+qed
	+
	+text \<open>The bin packing algorithm as it is proposed in the article @{cite BerghammerR03}.
	+ \<open>P\<close> will not only be a correct solution of the bin packing problem, but the amount of bins
	+ will be a lower bound for \<open>3 / 2\<close> of the amount of bins of any correct solution \<open>Q\<close>, and thus
	+ guarantee an approximation factor of \<open>3 / 2\<close> for the optimum.\<close>
	+lemma bp_approx:
	+"VARS P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u
	+ {True}
	+ P\<^sub>1 := {}; P\<^sub>2 := {}; B\<^sub>1 := {}; B\<^sub>2 := {}; V := U;
	+ WHILE V \<inter> S \<noteq> {} INV {inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V} DO
	+ IF B\<^sub>1 \<noteq> {}
	+ THEN u := (SOME u. u \<in> V \<inter> S)
	+ ELSE IF V \<inter> L \<noteq> {}
	+ THEN u := (SOME u. u \<in> V \<inter> L)
	+ ELSE u := (SOME u. u \<in> V \<inter> S) FI FI;
	+ V := V - {u};
	+ IF W(B\<^sub>1) + w(u) \<le> c
	+ THEN B\<^sub>1 := B\<^sub>1 \<union> {u}
	+ ELSE IF W(B\<^sub>2) + w(u) \<le> c
	+ THEN B\<^sub>2 := B\<^sub>2 \<union> {u}
	+ ELSE P\<^sub>2 := P\<^sub>2 \<union> wrap B\<^sub>2; B\<^sub>2 := {u} FI;
	+ P\<^sub>1 := P\<^sub>1 \<union> wrap B\<^sub>1; B\<^sub>1 := {} FI
	+ OD;
	+ P := P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \| v. v \<in> V}
	+ {bp P \<and> (\<forall>Q. bp Q \<longrightarrow> card P \<le> 3 / 2 * card Q)}"
	+proof (vcg, goal_cases)
	+case (1 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
	+ then show ?case by (simp add: loop_init)
	+next
	+ case (2 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
	+ then have INV: "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" ..
	+ let ?s = "SOME u. u \<in> V \<inter> S"
	+ let ?l = "SOME u. u \<in> V \<inter> L"
	+ have LIN: "V \<inter> L \<noteq> {} \<Longrightarrow> ?l \<in> V \<inter> L" using some_in_eq by metis
	+ then have LWEIGHT: "V \<inter> L \<noteq> {} \<Longrightarrow> w ?l \<le> c" using L_def weight by blast
	+ from 2 have "V \<inter> S \<noteq> {}" ..
	+ then have IN: "?s \<in> V \<inter> S" using some_in_eq by metis
	+ then have "w ?s \<le> c" using S_def by simp
	+
	+ then show ?case
	+ using LWEIGHT loop_stepA[OF INV _ _ IN] loop_stepB[OF INV _ LIN] loop_stepC[OF INV _ IN]
	+ and loop_stepD[OF INV _ IN] loop_stepE[OF INV _ IN] by (cases \<open>B\<^sub>1 = {}\<close>, cases \<open>V \<inter> L = {}\<close>) auto
	+next
	+ case (3 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u)
	+ then have INV: "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and EMPTY: "V \<inter> S = {}" by blast+
	+ from inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF inv\<^sub>3E(1)[OF INV]]] and bin_packing_lower_bound_card[OF EMPTY inv\<^sub>3E(1)[OF INV]]
	+ show ?case by blast
	+qed
	+
	+end (* BinPacking *)
	+
	+subsection \<open>The Full Linear Time Version of the Proposed Algorithm\<close>
	+
	+text \<open>Finally, we prove the Algorithm proposed on page 78 of the article @{cite BerghammerR03}.
	+ This version generates the S and L sets beforehand and uses them directly to calculate the solution,
	+ thus removing the need for intersection operations, and ensuring linear time if we can
	+ perform \<open>insertion, removal, and selection of an element, the union of two sets,
	+ and the emptiness test in constant time\<close> @{cite BerghammerR03}.\<close>
	+
	+locale BinPacking_Complete =
	+ fixes U :: "'a set" \<comment> \<open>A finite, non-empty set of objects\<close>
	+ and w :: "'a \<Rightarrow> real" \<comment> \<open>A mapping from objects to their respective weights (positive real numbers)\<close>
	+ and c :: nat \<comment> \<open>The maximum capacity of a bin (as a natural number)\<close>
	+ assumes weight: "\<forall>u \<in> U. 0 < w(u) \<and> w(u) \<le> c"
	+ and U_Finite: "finite U"
	+ and U_NE: "U \<noteq> {}"
	+begin
	+
	+text \<open>The correctness proofs will be identical to the ones of the simplified algorithm.\<close>
	+
	+abbreviation W :: "'a set \<Rightarrow> real" where
	+ "W B \<equiv> (\<Sum>u \<in> B. w(u))"
	+
	+definition bp :: "'a set set \<Rightarrow> bool" where
	+ "bp P \<longleftrightarrow> partition_on U P \<and> (\<forall>B \<in> P. W(B) \<le> c)"
	+
	+lemma bpE:
	+ assumes "bp P"
	+ shows "pairwise disjnt P" "{} \<notin> P" "\<Union>P = U" "\<forall>B \<in> P. W(B) \<le> c"
	+ using assms unfolding bp_def partition_on_def by blast+
	+
	+lemma bpI:
	+ assumes "pairwise disjnt P" "{} \<notin> P" "\<Union>P = U" "\<forall>B \<in> P. W(B) \<le> c"
	+ shows "bp P"
	+ using assms unfolding bp_def partition_on_def by blast
	+
	+definition inv\<^sub>1 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+ "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \<longleftrightarrow> bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}) \<comment> \<open>A correct solution to the bin packing problem\<close>
	+ \<and> \<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V \<comment> \<open>The partial solution does not contain objects that have not yet been assigned\<close>
	+ \<and> B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<comment> \<open>\<open>B\<^sub>1\<close> is distinct from all the other bins\<close>
	+ \<and> B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2) \<comment> \<open>\<open>B\<^sub>2\<close> is distinct from all the other bins\<close>
	+ \<and> (P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {} \<comment> \<open>The first and second partial solutions are disjoint from each other.\<close>"
	+
	+lemma inv\<^sub>1E:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
	+ shows "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V})"
	+ and "\<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V"
	+ and "B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ and "B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2)"
	+ and "(P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
	+ using assms unfolding inv\<^sub>1_def by auto
	+
	+lemma inv\<^sub>1I:
	+ assumes "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V})"
	+ and "\<Union>(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - V"
	+ and "B\<^sub>1 \<notin> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ and "B\<^sub>2 \<notin> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2)"
	+ and "(P\<^sub>1 \<union> wrap B\<^sub>1) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
	+ shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V"
	+ using assms unfolding inv\<^sub>1_def by blast
	+
	+lemma wrap_Un [simp]: "wrap (M \<union> {x}) = {M \<union> {x}}" unfolding wrap_def by simp
	+lemma wrap_empty [simp]: "wrap {} = {}" unfolding wrap_def by simp
	+lemma wrap_not_empty [simp]: "M \<noteq> {} \<longleftrightarrow> wrap M = {M}" unfolding wrap_def by simp
	+
	+lemma inv\<^sub>1_stepA:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V" "W(B\<^sub>1) + w(u) \<le> c"
	+ shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
	+
	+ \<comment> \<open>Rule 1: Pairwise Disjoint\<close>
	+ have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. u \<notin> M"
	+ using invrules(2) assms(2) by blast
	+ have "{{v} \|v. v \<in> V} = {{u}} \<union> {{v} \|v. v \<in> V - {u}}"
	+ using assms(2) by blast
	+ then have "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> ({{u}} \<union> {{v} \|v. v \<in> V - {u}}))"
	+ using bprules(1) assms(2) by simp
	+ then have "pairwise disjnt (wrap B\<^sub>1 \<union> {{u}} \<union> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}})" by (simp add: Un_commute)
	+ then have assm: "pairwise disjnt (wrap B\<^sub>1 \<union> {{u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))" by (simp add: Un_assoc)
	+ have "pairwise disjnt ({B\<^sub>1 \<union> {u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))"
	+ proof (cases \<open>B\<^sub>1 = {}\<close>)
	+ case True with assm show ?thesis by simp
	+ next
	+ case False
	+ with assm have assm: "pairwise disjnt ({B\<^sub>1} \<union> {{u}} \<union> (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))" by simp
	+ from NOTIN have "{u} \<notin> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}" by blast
	+ from pairwise_disjnt_Un[OF assm _ this] invrules(2,3) show ?thesis
	+ using False by auto
	+ qed
	+ then have 1: "pairwise disjnt (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}})"
	+ unfolding wrap_Un by simp
	+
	+ \<comment> \<open>Rule 2: No empty sets\<close>
	+ from bprules(2) have 2: "{} \<notin> P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}"
	+ unfolding wrap_def by simp
	+
	+ \<comment> \<open>Rule 3: Union preserved\<close>
	+ from bprules(3) have "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} \|v. v \<in> V - {u}}) = U"
	+ using assms(2) by blast
	+ then have 3: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}) = U"
	+ unfolding wrap_def by force
	+
	+ \<comment> \<open>Rule 4: Weights below capacity\<close>
	+ have "0 < w u" using weight assms(2) bprules(3) by blast
	+ have "finite B\<^sub>1" using bprules(3) U_Finite by (cases \<open>B\<^sub>1 = {}\<close>) auto
	+ then have "W (B\<^sub>1 \<union> {u}) \<le> W B\<^sub>1 + w u" using \<open>0 < w u\<close> by (cases \<open>u \<in> B\<^sub>1\<close>) (auto simp: insert_absorb)
	+ also have "... \<le> c" using assms(3) .
	+ finally have "W (B\<^sub>1 \<union> {u}) \<le> c" .
	+ then have "\<forall>B \<in> wrap (B\<^sub>1 \<union> {u}). W B \<le> c" unfolding wrap_Un by blast
	+ moreover have "\<forall>B\<in>P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. W B \<le> c"
	+ using bprules(4) by blast
	+ ultimately have 4: "\<forall>B\<in>P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. W B \<le> c" by blast
	+ from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}})" .
	+
	+ \<comment> \<open>Auxiliary information is preserved\<close>
	+ have "u \<in> U" using assms(2) bprules(3) by blast
	+ then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
	+ have L: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<union> {u}"
	+ unfolding wrap_def using NOTIN by auto
	+ have 2: "\<Union> (P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2 \<union> wrap B\<^sub>2) = U - (V - {u})"
	+ unfolding L R invrules(2) ..
	+ have 3: "B\<^sub>1 \<union> {u} \<notin> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2"
	+ using NOTIN by auto
	+ have 4: "B\<^sub>2 \<notin> P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}) \<union> P\<^sub>2"
	+ using invrules(4) NOTIN unfolding wrap_def by fastforce
	+ have 5: "(P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u})) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}"
	+ using invrules(5) NOTIN unfolding wrap_Un by auto
	+
	+ from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
	+qed
	+
	+lemma inv\<^sub>1_stepB:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V" "W B\<^sub>2 + w u \<le> c"
	+ shows "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
	+
	+ have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. u \<notin> M"
	+ using invrules(2) assms(2) by blast
	+ have "{{v} \|v. v \<in> V} = {{u}} \<union> {{v} \|v. v \<in> V - {u}}"
	+ using assms(2) by blast
	+ then have "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} \|v. v \<in> V - {u}})"
	+ using bprules(1) assms(2) by simp
	+ then have assm: "pairwise disjnt (wrap B\<^sub>2 \<union> {{u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))"
	+ by (simp add: Un_assoc Un_commute)
	+ have "pairwise disjnt ({B\<^sub>2 \<union> {u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))"
	+ proof (cases \<open>B\<^sub>2 = {}\<close>)
	+ case True with assm show ?thesis by simp
	+ next
	+ case False
	+ with assm have assm: "pairwise disjnt ({B\<^sub>2} \<union> {{u}} \<union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}))" by simp
	+ from NOTIN have "{u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}" by blast
	+ from pairwise_disjnt_Un[OF assm _ this] invrules(2,4) show ?thesis
	+ using False by auto
	+ qed
	+ then have 1: "pairwise disjnt (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} \|v. v \<in> V - {u}})"
	+ unfolding wrap_Un by simp
	+
	+ \<comment> \<open>Rule 2: No empty sets\<close>
	+ from bprules(2) have 2: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} \|v. v \<in> V - {u}}"
	+ unfolding wrap_def by simp
	+
	+ \<comment> \<open>Rule 3: Union preserved\<close>
	+ from bprules(3) have "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} \|v. v \<in> V - {u}}) = U"
	+ using assms(2) by blast
	+ then have 3: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} \|v. v \<in> V - {u}}) = U"
	+ unfolding wrap_def by force
	+
	+ \<comment> \<open>Rule 4: Weights below capacity\<close>
	+ have "0 < w u" using weight assms(2) bprules(3) by blast
	+ have "finite B\<^sub>2" using bprules(3) U_Finite by (cases \<open>B\<^sub>2 = {}\<close>) auto
	+ then have "W (B\<^sub>2 \<union> {u}) \<le> W B\<^sub>2 + w u" using \<open>0 < w u\<close> by (cases \<open>u \<in> B\<^sub>2\<close>) (auto simp: insert_absorb)
	+ also have "... \<le> c" using assms(3) .
	+ finally have "W (B\<^sub>2 \<union> {u}) \<le> c" .
	+ then have "\<forall>B \<in> wrap (B\<^sub>2 \<union> {u}). W B \<le> c" unfolding wrap_Un by blast
	+ moreover have "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. W B \<le> c"
	+ using bprules(4) by blast
	+ ultimately have 4: "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} \|v. v \<in> V - {u}}. W B \<le> c"
	+ by auto
	+ from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}) \<union> {{v} \|v. v \<in> V - {u}})" .
	+
	+ \<comment> \<open>Auxiliary information is preserved\<close>
	+ have "u \<in> U" using assms(2) bprules(3) by blast
	+ then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
	+ have L: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap B\<^sub>2) \<union> {u}"
	+ unfolding wrap_def using NOTIN by auto
	+ have 2: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = U - (V - {u})"
	+ unfolding L R using invrules(2) by simp
	+ have 3: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})"
	+ using bpE(2)[OF 1] by simp
	+ have 4: "B\<^sub>2 \<union> {u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> P\<^sub>2"
	+ using NOTIN by auto
	+ have 5: "(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}) \<inter> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})) = {}"
	+ using invrules(5) NOTIN unfolding wrap_empty wrap_Un by auto
	+
	+ from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
	+qed
	+
	+lemma inv\<^sub>1_stepC:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \<in> V"
	+ shows "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (V - {u})"
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(1)]
	+ \<comment> \<open>Rule 1-4: Correct Bin Packing\<close>
	+ have "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} \|v. v \<in> V - {u}}
	+ = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}} \<union> {{v} \|v. v \<in> V - {u}}"
	+ by (metis (no_types, lifting) Un_assoc Un_empty_right insert_not_empty wrap_empty wrap_not_empty)
	+ also have "... = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}"
	+ using assms(2) by auto
	+ finally have EQ: "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} \|v. v \<in> V - {u}}
	+ = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V}" .
	+ from invrules(1) have 1: "bp (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u} \<union> {{v} \|v. v \<in> V - {u}})"
	+ unfolding EQ .
	+
	+ \<comment> \<open>Auxiliary information is preserved\<close>
	+ have NOTIN: "\<forall>M \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> V - {u}}. u \<notin> M"
	+ using invrules(2) assms(2) by blast
	+ have "u \<in> U" using assms(2) bpE(3)[OF invrules(1)] by blast
	+ then have R: "U - (V - {u}) = U - V \<union> {u}" by blast
	+ have L: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}) = \<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}"
	+ unfolding wrap_def using NOTIN by auto
	+ have 2: "\<Union> (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}) = U - (V - {u})"
	+ unfolding L R using invrules(2) by auto
	+ have 3: "{} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> (P\<^sub>2 \<union> wrap B\<^sub>2) \<union> wrap {u}"
	+ using bpE(2)[OF 1] by simp
	+ have 4: "{u} \<notin> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {} \<union> (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using NOTIN by auto
	+ have 5: "(P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}) \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}) = {}"
	+ using invrules(5) NOTIN unfolding wrap_def by force
	+
	+ from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis .
	+qed
	+
	+text \<open>From this point onward, we will require a different approach for proving lower bounds.
	+ Instead of fixing and assuming the definitions of the \<open>S\<close> and \<open>L\<close> sets, we will introduce
	+ the abbreviations \<open>S\<^sub>U\<close> and \<open>L\<^sub>U\<close> for any occurrences of the original \<open>S\<close> and \<open>L\<close> sets.
	+ The union of \<open>S\<close> and \<open>L\<close> can be interpreted as \<open>V\<close>. As a result, occurrences of \<open>V \<inter> S\<close>
	+ become \<open>(S \<union> L) \<inter> S = S\<close>, and \<open>V \<inter> L\<close> become \<open>(S \<union> L) \<inter> L = L\<close>.
	+ Occurrences of these sets will have to be replaced appropriately.\<close>
	+abbreviation S\<^sub>U where
	+ "S\<^sub>U \<equiv> {u \<in> U. w u \<le> c / 2}"
	+
	+abbreviation L\<^sub>U where
	+ "L\<^sub>U \<equiv> {u \<in> U. c / 2 < w u}"
	+
	+text \<open>As we will remove elements from \<open>S\<close> and \<open>L\<close>, we will only be able to show that they remain
	+ subsets of \<open>S\<^sub>U\<close> and \<open>L\<^sub>U\<close> respectively.\<close>
	+abbreviation SL where
	+ "SL S L \<equiv> S \<subseteq> S\<^sub>U \<and> L \<subseteq> L\<^sub>U"
	+
	+lemma bp_bins_finite [simp]:
	+ assumes "bp P"
	+ shows "\<forall>B \<in> P. finite B"
	+ using bpE(3)[OF assms] U_Finite by (meson Sup_upper finite_subset)
	+
	+lemma bp_sol_finite [simp]:
	+ assumes "bp P"
	+ shows "finite P"
	+ using bpE(3)[OF assms] U_Finite by (simp add: finite_UnionD)
	+
	+lemma only_one_L_per_bin:
	+ assumes "bp P" "B \<in> P"
	+ shows "\<forall>x \<in> B. \<forall>y \<in> B. x \<noteq> y \<longrightarrow> x \<notin> L\<^sub>U \<or> y \<notin> L\<^sub>U"
	+proof (rule ccontr, simp)
	+ assume "\<exists>x\<in>B. \<exists>y\<in>B. x \<noteq> y \<and> y \<in> U \<and> x \<in> U \<and> real c < w x * 2 \<and> real c < w y * 2"
	+ then obtain x y where *: "x \<in> B" "y \<in> B" "x \<noteq> y" "x \<in> L\<^sub>U" "y \<in> L\<^sub>U" by auto
	+ then have "c < w x + w y" by force
	+ have "finite B" using assms by simp
	+ have "y \<in> B - {x}" using *(2,3) by blast
	+ have "W B = W (B - {x}) + w x"
	+ using *(1) \<open>finite B\<close> by (simp add: sum.remove)
	+ also have "... = W (B - {x} - {y}) + w x + w y"
	+ using \<open>y \<in> B - {x}\<close> \<open>finite B\<close> by (simp add: sum.remove)
	+ finally have *: "W B = W (B - {x} - {y}) + w x + w y" .
	+ have "\<forall>u \<in> B. 0 < w u" using bpE(3)[OF assms(1)] assms(2) weight by blast
	+ then have "0 \<le> W (B - {x} - {y})" by (smt DiffD1 sum_nonneg)
	+ with * have "c < W B" using \<open>c < w x + w y\<close> by simp
	+ then show False using bpE(4)[OF assms(1)] assms(2) by fastforce
	+qed
	+
	+lemma L_lower_bound_card:
	+ assumes "bp P"
	+ shows "card L\<^sub>U \<le> card P"
	+proof -
	+ have "\<forall>x \<in> L\<^sub>U. \<exists>B \<in> P. x \<in> B"
	+ using bpE(3)[OF assms] by blast
	+ then obtain f where f_def: "\<forall>u \<in> L\<^sub>U. u \<in> f u \<and> f u \<in> P" by metis
	+ then have "inj_on f L\<^sub>U"
	+ unfolding inj_on_def using only_one_L_per_bin[OF assms] by blast
	+ then have card_eq: "card L\<^sub>U = card (f ` L\<^sub>U)" by (simp add: card_image)
	+ have "f ` L\<^sub>U \<subseteq> P" using f_def by blast
	+ moreover have "finite P" using assms by simp
	+ ultimately have "card (f ` L\<^sub>U) \<le> card P" by (simp add: card_mono)
	+ then show ?thesis unfolding card_eq .
	+qed
	+
	+lemma subset_bp_card:
	+ assumes "bp P" "M \<subseteq> P" "\<forall>B \<in> M. B \<inter> L\<^sub>U \<noteq> {}"
	+ shows "card M \<le> card L\<^sub>U"
	+proof -
	+ have "\<forall>B \<in> M. \<exists>u \<in> L\<^sub>U. u \<in> B" using assms(3) by fast
	+ then have "\<exists>f. \<forall>B \<in> M. f B \<in> L\<^sub>U \<and> f B \<in> B" by metis
	+ then obtain f where f_def: "\<forall>B \<in> M. f B \<in> L\<^sub>U \<and> f B \<in> B" ..
	+ have "inj_on f M"
	+ proof (rule ccontr)
	+ assume "\<not> inj_on f M"
	+ then have "\<exists>x \<in> M. \<exists>y \<in> M. x \<noteq> y \<and> f x = f y" unfolding inj_on_def by blast
	+ then obtain x y where *: "x \<in> M" "y \<in> M" "x \<noteq> y" "f x = f y" by blast
	+ then have "\<exists>u. u \<in> x \<and> u \<in> y" using f_def by metis
	+ then have "x \<inter> y \<noteq> {}" by blast
	+ moreover have "pairwise disjnt M" using pairwise_subset[OF bpE(1)[OF assms(1)] assms(2)] .
	+ ultimately show False using * unfolding pairwise_def disjnt_def by simp
	+ qed
	+ moreover have "finite L\<^sub>U" using U_Finite by auto
	+ moreover have "f ` M \<subseteq> L\<^sub>U" using f_def by blast
	+ ultimately show ?thesis using card_inj_on_le by blast
	+qed
	+
	+lemma L_bins_lower_bound_card:
	+ assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)" "\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L\<^sub>U \<noteq> {}"
	+ and SL_def: "SL S L"
	+ shows "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> L}) \<le> card P"
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(2)]
	+ have "\<forall>B \<in> {{v} \|v. v \<in> L}. B \<inter> L\<^sub>U \<noteq> {}" using SL_def by blast
	+ with assms(3) have
	+ "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> L} \<subseteq> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> S \<union> L}"
	+ "\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> L}. B \<inter> L\<^sub>U \<noteq> {}" by blast+
	+ from subset_bp_card[OF invrules(1) this] show ?thesis
	+ using L_lower_bound_card[OF assms(1)] by linarith
	+qed
	+
	+lemma sum_Un_eq_sum_sum:
	+ assumes "bp P"
	+ shows "(\<Sum>u \<in> U. w u) = (\<Sum>B \<in> P. W B)"
	+proof -
	+ have FINITE: "\<forall>B \<in> P. finite B" using assms by simp
	+ have DISJNT: "\<forall>A \<in> P. \<forall>B \<in> P. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
	+ using bpE(1)[OF assms] unfolding pairwise_def disjnt_def .
	+ have "(\<Sum>u \<in> (\<Union>P). w u) = (\<Sum>B \<in> P. W B)"
	+ using sum.Union_disjoint[OF FINITE DISJNT] by auto
	+ then show ?thesis unfolding bpE(3)[OF assms] .
	+qed
	+
	+lemma sum_lower_bound_card:
	+ assumes "bp P"
	+ shows "(\<Sum>u \<in> U. w u) \<le> c * card P"
	+proof -
	+ have *: "\<forall>B \<in> P. 0 < W B \<and> W B \<le> c"
	+ using bpE(2-4)[OF assms] weight by (metis UnionI assms bp_bins_finite sum_pos)
	+ have "(\<Sum>u \<in> U. w u) = (\<Sum>B \<in> P. W B)"
	+ using sum_Un_eq_sum_sum[OF assms] .
	+ also have "... \<le> (\<Sum>B \<in> P. c)" using sum_mono * by fastforce
	+ also have "... = c * card P" by simp
	+ finally show ?thesis .
	+qed
	+
	+lemma bp_NE:
	+ assumes "bp P"
	+ shows "P \<noteq> {}"
	+ using U_NE bpE(3)[OF assms] by blast
	+
	+lemma sum_Un_ge:
	+ fixes f :: "_ \<Rightarrow> real"
	+ assumes "finite M" "finite N" "\<forall>B \<in> M \<union> N. 0 < f B"
	+ shows "sum f M \<le> sum f (M \<union> N)"
	+proof -
	+ have "0 \<le> sum f N - sum f (M \<inter> N)"
	+ using assms by (smt DiffD1 inf.cobounded2 UnCI sum_mono2)
	+ then have "sum f M \<le> sum f M + sum f N - sum f (M \<inter> N)"
	+ by simp
	+ also have "... = sum f (M \<union> N)"
	+ using sum_Un[OF assms(1,2), symmetric] .
	+ finally show ?thesis .
	+qed
	+
	+definition bij_exists :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+ "bij_exists P V = (\<exists>f. bij_betw f P V \<and> (\<forall>B \<in> P. W B + w (f B) > c))"
	+
	+lemma P\<^sub>1_lower_bound_card:
	+ assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ shows "card P\<^sub>1 + 1 \<le> card P"
	+proof (cases \<open>P\<^sub>1 = {}\<close>)
	+ case True
	+ have "finite P" using assms(1) by simp
	+ then have "1 \<le> card P" using bp_NE[OF assms(1)]
	+ by (metis Nat.add_0_right Suc_diff_1 Suc_le_mono card_gt_0_iff le0 mult_Suc_right nat_mult_1)
	+ then show ?thesis unfolding True by simp
	+next
	+ note invrules = inv\<^sub>1E[OF assms(2)]
	+ case False
	+ obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B \<in> P\<^sub>1. W B + w (f B) > c"
	+ using assms(3) unfolding bij_exists_def by blast
	+ have FINITE: "finite P\<^sub>1" "finite (P\<^sub>2 \<union> wrap B\<^sub>2)" "finite (P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)" "finite (wrap B\<^sub>1 \<union> {{v} \|v. v \<in> S \<union> L})"
	+ using inv\<^sub>1E(1)[OF assms(2)] bp_sol_finite by blast+
	+
	+ have F: "\<forall>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. finite B" using invrules(1) by simp
	+ have D: "\<forall>A \<in> P\<^sub>2 \<union> wrap B\<^sub>2. \<forall>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
	+ using bpE(1)[OF invrules(1)] unfolding pairwise_def disjnt_def by auto
	+ have sum_eq: "W (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) = (\<Sum>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. W B)"
	+ using sum.Union_disjoint[OF F D] by auto
	+
	+ have "\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> S \<union> L}. 0 < W B"
	+ using bpE(2,3)[OF invrules(1)] weight by (metis (no_types, lifting) UnionI bp_bins_finite invrules(1) sum_pos)
	+ then have "(\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B) \<le> (\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> (wrap B\<^sub>1 \<union> {{v} \|v. v \<in> S \<union> L}). W B)"
	+ using sum_Un_ge[OF FINITE(3,4), of W] by blast
	+ also have "... = (\<Sum>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> S \<union> L}. W B)" by (smt Un_assoc Un_commute)
	+ also have "... = W U" using sum_Un_eq_sum_sum[OF invrules(1), symmetric] .
	+ finally have *: "(\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B) \<le> W U" .
	+ have DISJNT: "P\<^sub>1 \<inter> (P\<^sub>2 \<union> wrap B\<^sub>2) = {}" using invrules(5) by blast
	+
	+ \<comment> \<open>This part of the proof is based on the proof on page 72 of the article @{cite BerghammerR03}.\<close>
	+ have "c * card P\<^sub>1 = (\<Sum>B \<in> P\<^sub>1. c)" by simp
	+ also have "... < (\<Sum>B \<in> P\<^sub>1. W B + w (f B))"
	+ using f_def(2) sum_strict_mono[OF FINITE(1) False] by fastforce
	+ also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + (\<Sum>B \<in> P\<^sub>1. w (f B))"
	+ by (simp add: Groups_Big.comm_monoid_add_class.sum.distrib)
	+ also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + W (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" unfolding sum.reindex_bij_betw[OF f_def(1), of w] ..
	+ also have "... = (\<Sum>B \<in> P\<^sub>1. W B) + (\<Sum>B \<in> P\<^sub>2 \<union> wrap B\<^sub>2. W B)" unfolding sum_eq ..
	+ also have "... = (\<Sum>B \<in> P\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2. W B)" using sum.union_disjoint[OF FINITE(1,2) DISJNT, of W] by (simp add: Un_assoc)
	+ also have "... \<le> (\<Sum>u \<in> U. w u)" using * .
	+ also have "... \<le> c * card P" using sum_lower_bound_card[OF assms(1)] .
	+ finally show ?thesis by (meson discrete nat_mult_less_cancel_disj of_nat_less_imp_less)
	+qed
	+
	+lemma P\<^sub>1_B\<^sub>1_lower_bound_card:
	+ assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ shows "card (P\<^sub>1 \<union> wrap B\<^sub>1) \<le> card P"
	+proof -
	+ have "card (P\<^sub>1 \<union> wrap B\<^sub>1) \<le> card P\<^sub>1 + card (wrap B\<^sub>1)"
	+ using card_Un_le by blast
	+ also have "... \<le> card P\<^sub>1 + 1" using wrap_card by simp
	+ also have "... \<le> card P" using P\<^sub>1_lower_bound_card[OF assms] .
	+ finally show ?thesis .
	+qed
	+
	+lemma P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)" "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)" "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ shows "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> card P\<^sub>1 + 1"
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)]
	+
	+ have "pairwise disjnt (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using bprules(1) pairwise_subset by blast
	+ moreover have "B\<^sub>2 \<notin> P\<^sub>2" using invrules(4) by simp
	+ ultimately have DISJNT: "\<Union>P\<^sub>2 \<inter> B\<^sub>2 = {}"
	+ by (auto, metis (no_types, hide_lams) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un)
	+
	+ have "finite (\<Union>P\<^sub>2)" using U_Finite bprules(3) by auto
	+ have "finite B\<^sub>2" using bp_bins_finite[OF invrules(1)] wrap_not_empty by blast
	+ have "finite P\<^sub>2" "finite (wrap B\<^sub>2)" using bp_sol_finite[OF invrules(1)] by blast+
	+ have DISJNT2: "P\<^sub>2 \<inter> wrap B\<^sub>2 = {}" unfolding wrap_def using \<open>B\<^sub>2 \<notin> P\<^sub>2\<close> by auto
	+ have "card (wrap B\<^sub>2) \<le> card B\<^sub>2"
	+ proof (cases \<open>B\<^sub>2 = {}\<close>)
	+ case False
	+ then have "1 \<le> card B\<^sub>2" by (simp add: leI \<open>finite B\<^sub>2\<close>)
	+ then show ?thesis using wrap_card[of B\<^sub>2] by linarith
	+ qed simp
	+
	+ \<comment> \<open>This part of the proof is based on the proof on page 73 of the article @{cite BerghammerR03}.\<close>
	+ from assms(2) have "2 * card P\<^sub>2 + 2 * card (wrap B\<^sub>2) \<le> card (\<Union>P\<^sub>2) + card (wrap B\<^sub>2) + 1"
	+ using wrap_card[of B\<^sub>2] by linarith
	+ then have "2 * (card P\<^sub>2 + card (wrap B\<^sub>2)) \<le> card (\<Union>P\<^sub>2) + card B\<^sub>2 + 1"
	+ using \<open>card (wrap B\<^sub>2) \<le> card B\<^sub>2\<close> by simp
	+ then have "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card (\<Union>P\<^sub>2 \<union> B\<^sub>2) + 1"
	+ using card_Un_disjoint[OF \<open>finite (\<Union>P\<^sub>2)\<close> \<open>finite B\<^sub>2\<close> DISJNT]
	+ and card_Un_disjoint[OF \<open>finite P\<^sub>2\<close> \<open>finite (wrap B\<^sub>2)\<close> DISJNT2] by argo
	+ then have "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2)) + 1"
	+ by (cases \<open>B\<^sub>2 = {}\<close>) (auto simp: Un_commute)
	+ then show "2 * (card (P\<^sub>2 \<union> wrap B\<^sub>2)) \<le> card P\<^sub>1 + 1"
	+ using assms(3) bij_betw_same_card unfolding bij_exists_def by metis
	+qed
	+
	+text \<open>We add \<open>SL S L\<close> to \<open>inv\<^sub>2\<close> to ensure that the \<open>S\<close> and \<open>L\<close> sets only contain objects with correct weights.\<close>
	+definition inv\<^sub>2 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+ "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \<longleftrightarrow> inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L) \<comment> \<open>\<open>inv\<^sub>1\<close> holds for the partial solution\<close>
	+ \<and> (L \<noteq> {} \<longrightarrow> (\<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L\<^sub>U \<noteq> {})) \<comment> \<open>If there are still large objects left, then every bin of the first partial solution must contain a large object\<close>
	+ \<and> bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2)) \<comment> \<open>There exists a bijective function between the bins of the first partial solution and the objects of the second one\<close>
	+ \<and> (2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)) \<comment> \<open>There are at most twice as many bins in \<open>P\<^sub>2\<close> as there are objects in \<open>P\<^sub>2\<close>\<close>
	+ \<and> SL S L \<comment> \<open>\<open>S\<close> and \<open>L\<close> are subsets of \<open>S\<^sub>U\<close> and \<open>L\<^sub>U\<close>\<close>"
	+
	+lemma inv\<^sub>2E:
	+ assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L"
	+ shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)"
	+ and "L \<noteq> {} \<Longrightarrow> \<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L\<^sub>U \<noteq> {}"
	+ and "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ and "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)"
	+ and "SL S L"
	+ using assms unfolding inv\<^sub>2_def by blast+
	+
	+lemma inv\<^sub>2I:
	+ assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \<union> L)"
	+ and "L \<noteq> {} \<Longrightarrow> \<forall>B \<in> P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L\<^sub>U \<noteq> {}"
	+ and "bij_exists P\<^sub>1 (\<Union>(P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ and "2 * card P\<^sub>2 \<le> card (\<Union>P\<^sub>2)"
	+ and "SL S L"
	+ shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L"
	+ using assms unfolding inv\<^sub>2_def by blast
	+
	+lemma bin_packing_lower_bound_card:
	+ assumes "S = {}" "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "bp P"
	+ shows "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> S \<union> L}) \<le> 3 / 2 * card P"
	+proof (cases \<open>L = {}\<close>)
	+ note invrules = inv\<^sub>2E[OF assms(2)]
	+ case True
	+ then have "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> S \<union> L})
	+ = card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2)" using assms(1) by simp
	+ also have "... \<le> card (P\<^sub>1 \<union> wrap B\<^sub>1) + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using card_Un_le[of \<open>P\<^sub>1 \<union> wrap B\<^sub>1\<close>] by (simp add: Un_assoc)
	+ also have "... \<le> card P + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using P\<^sub>1_B\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by simp
	+ also have "... \<le> card P + card P / 2"
	+ using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)]
	+ and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith
	+ finally show ?thesis by linarith
	+next
	+ note invrules = inv\<^sub>2E[OF assms(2)]
	+ case False
	+ have "card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> S \<union> L})
	+ = card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> L} \<union> P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using assms(1) by (simp add: Un_commute Un_assoc)
	+ also have "... \<le> card (P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> L}) + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using card_Un_le[of \<open>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> {{v} \|v. v \<in> L}\<close>] by (simp add: Un_assoc)
	+ also have "... \<le> card P + card (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using L_bins_lower_bound_card[OF assms(3) invrules(1) invrules(2)[OF False] invrules(5)] by linarith
	+ also have "... \<le> card P + card P / 2"
	+ using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)]
	+ and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith
	+ finally show ?thesis by linarith
	+qed
	+
	+definition inv\<^sub>3 :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+ "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \<longleftrightarrow> inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \<and> B\<^sub>2 \<subseteq> S\<^sub>U"
	+
	+lemma inv\<^sub>3E:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L"
	+ shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" and "B\<^sub>2 \<subseteq> S\<^sub>U"
	+ using assms unfolding inv\<^sub>3_def by blast+
	+
	+lemma inv\<^sub>3I:
	+ assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" and "B\<^sub>2 \<subseteq> S\<^sub>U"
	+ shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L"
	+ using assms unfolding inv\<^sub>3_def by blast
	+
	+lemma loop_init:
	+ "inv\<^sub>3 {} {} {} {} S\<^sub>U L\<^sub>U"
	+proof -
	+ have "S\<^sub>U \<union> L\<^sub>U = U" by auto
	+ then have *: "inv\<^sub>1 {} {} {} {} (S\<^sub>U \<union> L\<^sub>U)"
	+ unfolding bp_def partition_on_def pairwise_def wrap_def inv\<^sub>1_def
	+ using weight by auto
	+ have "bij_exists {} (\<Union> ({} \<union> wrap {}))"
	+ using bij_betwI' unfolding bij_exists_def by fastforce
	+ from inv\<^sub>2I[OF * _ this] have "inv\<^sub>2 {} {} {} {} S\<^sub>U L\<^sub>U" by auto
	+ from inv\<^sub>3I[OF this] show ?thesis by blast
	+qed
	+
	+lemma loop_stepA:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 = {}" "L = {}" "u \<in> S"
	+ shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S - {u}) L"
	+proof -
	+ note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
	+ have WEIGHT: "W B\<^sub>1 + w u \<le> c" using invrules(5) assms(2,4) by fastforce
	+ from assms(4) have "u \<in> S \<union> L" by blast
	+ from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2,3) have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S - {u} \<union> L)" by simp
	+ have 2: "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap {u}. B \<inter> L\<^sub>U \<noteq> {}" using assms(3) by blast
	+ from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S - {u}) L" by blast
	+ from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
	+qed
	+
	+lemma loop_stepB:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 = {}" "u \<in> L"
	+ shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 S (L - {u})"
	+proof -
	+ note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
	+ have WEIGHT: "W B\<^sub>1 + w u \<le> c" using weight invrules(5) assms(2,3) by fastforce
	+
	+ \<comment> \<open>This observation follows from the fact that the \<open>S\<close> and \<open>L\<close> sets have to be disjoint from each other,
	+ and allows us to reuse our proofs of the preservation of \<open>inv\<^sub>1\<close> by simply replacing \<open>V\<close> with \<open>S \<union> L\<close>\<close>
	+ have *: "S \<union> L - {u} = S \<union> (L - {u})" using invrules(5) assms(3) by force
	+ from assms(3) have "u \<in> S \<union> L" by blast
	+ from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2) * have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S \<union> (L - {u}))" by simp
	+ have "\<forall>B\<in>P\<^sub>1. B \<inter> L\<^sub>U \<noteq> {}" "{u} \<inter> L\<^sub>U \<noteq> {}" using assms(3) invrules(2,5) by blast+
	+ then have 2: "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap {u}. B \<inter> L\<^sub>U \<noteq> {}"
	+ using assms(3) by (metis (full_types) Un_iff empty_iff insert_iff wrap_not_empty)
	+ from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 S (L - {u})" by blast
	+ from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
	+qed
	+
	+lemma loop_stepC:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 \<noteq> {}" "u \<in> S" "W B\<^sub>1 + w(u) \<le> c"
	+ shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (S - {u}) L"
	+proof -
	+ note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
	+
	+ \<comment> \<open>Same approach, but removing \<open>{u}\<close> from \<open>S\<close> instead of \<open>L\<close>\<close>
	+ have *: "S \<union> L - {u} = (S - {u}) \<union> L" using invrules(5) assms(3) by force
	+ from assms(3) have "u \<in> S \<union> L" by blast
	+ from inv\<^sub>1_stepA[OF invrules(1) this assms(4)] * have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (S - {u} \<union> L)" by simp
	+ have "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. B \<inter> L\<^sub>U \<noteq> {}" using invrules(2) by blast
	+ then have 2: "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap (B\<^sub>1 \<union> {u}). B \<inter> L\<^sub>U \<noteq> {}"
	+ by (smt Int_insert_left Un_empty_right Un_iff Un_insert_right assms(2) insert_not_empty singletonD singletonI wrap_def)
	+ from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \<union> {u}) B\<^sub>2 (S - {u}) L" by blast
	+ from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] .
	+qed
	+
	+lemma loop_stepD:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 \<noteq> {}" "u \<in> S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) \<le> c"
	+ shows "inv\<^sub>3 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (S - {u}) L"
	+proof -
	+ note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
	+ have *: "S \<union> L - {u} = (S - {u}) \<union> L" using invrules(5) assms(3) by force
	+ from assms(3) have "u \<in> S \<union> L" by blast
	+ from inv\<^sub>1_stepB[OF invrules(1) this assms(5)] * have 1: "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (S - {u} \<union> L)" by simp
	+
	+ have 2: "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}. B \<inter> L\<^sub>U \<noteq> {}"
	+ using invrules(2) unfolding wrap_empty by blast
	+
	+ from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B\<in>P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast
	+ have "B\<^sub>1 \<notin> P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast
	+ have "u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast
	+ then have "(\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}))) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}}))"
	+ by (metis Sup_empty Un_assoc Union_Un_distrib ccpo_Sup_singleton wrap_empty wrap_not_empty)
	+ also have "... = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" by simp
	+ finally have UN: "(\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u}))) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" .
	+ have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp
	+ let ?f = "f (B\<^sub>1 := u)"
	+ have BIJ: "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))"
	+ unfolding wrap_empty \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> UN using f_def(1) \<open>B\<^sub>1 \<notin> P\<^sub>1\<close> \<open>u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))\<close>
	+ by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3)
	+ have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp
	+ then have "(\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))"
	+ unfolding \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> using f_def(2) by simp
	+ with BIJ have "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))
	+ \<and> (\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))" by blast
	+ then have 3: "bij_exists (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap (B\<^sub>2 \<union> {u})))"
	+ unfolding bij_exists_def by blast
	+ from inv\<^sub>2I[OF 1 2 3] have "inv\<^sub>2 (P\<^sub>1 \<union> wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \<union> {u}) (S - {u}) L" using invrules(4,5) by blast
	+
	+ from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] assms(3) invrules(5) by blast
	+qed
	+
	+lemma B\<^sub>2_at_least_two_objects:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "u \<in> S" "W B\<^sub>2 + w(u) > c"
	+ shows "2 \<le> card B\<^sub>2"
	+proof (rule ccontr, simp add: not_le)
	+ have FINITE: "finite B\<^sub>2" using inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF inv\<^sub>3E(1)[OF assms(1)]]]
	+ by (metis (no_types, lifting) Finite_Set.finite.simps U_Finite Union_Un_distrib bpE(3) ccpo_Sup_singleton finite_Un wrap_not_empty)
	+ assume "card B\<^sub>2 < 2"
	+ then consider (0) "card B\<^sub>2 = 0" \| (1) "card B\<^sub>2 = 1" by linarith
	+ then show False proof cases
	+ case 0 then have "B\<^sub>2 = {}" using FINITE by simp
	+ then show ?thesis using assms(2,3) inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF assms(1)]] by force
	+ next
	+ case 1 then obtain v where "B\<^sub>2 = {v}"
	+ using card_1_singletonE by auto
	+ with inv\<^sub>3E(2)[OF assms(1)] have "2 * w v \<le> c" using inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF assms(1)]] by simp
	+ moreover from \<open>B\<^sub>2 = {v}\<close> have "W B\<^sub>2 = w v" by simp
	+ ultimately show ?thesis using assms(2,3) inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF assms(1)]] by force
	+ qed
	+qed
	+
	+lemma loop_stepE:
	+ assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 \<noteq> {}" "u \<in> S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) > c"
	+ shows "inv\<^sub>3 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (S - {u}) L"
	+proof -
	+ note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]]
	+ have *: "S \<union> L - {u} = (S - {u}) \<union> L" using invrules(5) assms(3) by force
	+ from assms(3) have "u \<in> S \<union> L" by blast
	+ from inv\<^sub>1_stepC[OF invrules(1) this] * have 1: "inv\<^sub>1 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (S - {u} \<union> L)" by simp
	+
	+ have 2: "L \<noteq> {} \<Longrightarrow> \<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1 \<union> wrap {}. B \<inter> L\<^sub>U \<noteq> {}"
	+ using invrules(2) unfolding wrap_empty by blast
	+
	+ from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" "\<forall>B\<in>P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast
	+ have "B\<^sub>1 \<notin> P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast
	+ have "u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast
	+ have "(\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u})) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{u}}))" unfolding wrap_def by simp
	+ also have "... = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" by simp
	+ finally have UN: "(\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u})) = (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2)) \<union> {u}" .
	+ have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp
	+ let ?f = "f (B\<^sub>1 := u)"
	+ have BIJ: "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))"
	+ unfolding wrap_empty \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> UN using f_def(1) \<open>B\<^sub>1 \<notin> P\<^sub>1\<close> \<open>u \<notin> (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))\<close>
	+ by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3)
	+ have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp
	+ then have "(\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))"
	+ unfolding \<open>wrap B\<^sub>1 = {B\<^sub>1}\<close> using f_def(2) by simp
	+ with BIJ have "bij_betw ?f (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))
	+ \<and> (\<forall>B\<in>P\<^sub>1 \<union> wrap B\<^sub>1. c < W B + w (?f B))" by blast
	+ then have 3: "bij_exists (P\<^sub>1 \<union> wrap B\<^sub>1) (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2 \<union> wrap {u}))"
	+ unfolding bij_exists_def by blast
	+
	+ have 4: "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> card (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))"
	+ proof -
	+ note bprules = bpE[OF inv\<^sub>1E(1)[OF invrules(1)]]
	+ have "pairwise disjnt (P\<^sub>2 \<union> wrap B\<^sub>2)"
	+ using bprules(1) pairwise_subset by blast
	+ moreover have "B\<^sub>2 \<notin> P\<^sub>2" using inv\<^sub>1E(4)[OF invrules(1)] by simp
	+ ultimately have DISJNT: "\<Union>P\<^sub>2 \<inter> B\<^sub>2 = {}"
	+ by (auto, metis (no_types, hide_lams) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un)
	+ have "finite (\<Union>P\<^sub>2)" using U_Finite bprules(3) by auto
	+ have "finite B\<^sub>2" using inv\<^sub>1E(1)[OF invrules(1)] bp_bins_finite wrap_not_empty by blast
	+
	+ have "2 * card (P\<^sub>2 \<union> wrap B\<^sub>2) \<le> 2 * (card P\<^sub>2 + card (wrap B\<^sub>2))"
	+ using card_Un_le[of P\<^sub>2 \<open>wrap B\<^sub>2\<close>] by simp
	+ also have "... \<le> 2 * card P\<^sub>2 + 2" using wrap_card by auto
	+ also have "... \<le> card (\<Union> P\<^sub>2) + 2" using invrules(4) by simp
	+ also have "... \<le> card (\<Union> P\<^sub>2) + card B\<^sub>2" using B\<^sub>2_at_least_two_objects[OF assms(1,3,5)] by simp
	+ also have "... = card (\<Union> (P\<^sub>2 \<union> {B\<^sub>2}))" using DISJNT card_Un_disjoint[OF \<open>finite (\<Union>P\<^sub>2)\<close> \<open>finite B\<^sub>2\<close>] by (simp add: Un_commute)
	+ also have "... = card (\<Union> (P\<^sub>2 \<union> wrap B\<^sub>2))" by (cases \<open>B\<^sub>2 = {}\<close>) auto
	+ finally show ?thesis .
	+ qed
	+ from inv\<^sub>2I[OF 1 2 3 4] have "inv\<^sub>2 (P\<^sub>1 \<union> wrap B\<^sub>1) (P\<^sub>2 \<union> wrap B\<^sub>2) {} {u} (S - {u}) L"
	+ using invrules(5) by blast
	+
	+ from inv\<^sub>3I[OF this] show ?thesis using assms(3) invrules(5) by blast
	+qed
	+
	+text \<open>The bin packing algorithm as it is proposed on page 78 of the article @{cite BerghammerR03}.
	+ \<open>P\<close> will not only be a correct solution of the bin packing problem, but the amount of bins
	+ will be a lower bound for \<open>3 / 2\<close> of the amount of bins of any correct solution \<open>Q\<close>, and thus
	+ guarantee an approximation factor of \<open>3 / 2\<close> for the optimum.\<close>
	+lemma bp_approx:
	+"VARS P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u
	+ {True}
	+ S := {}; L:= {}; V := U;
	+ WHILE V \<noteq> {} INV {V \<subseteq> U \<and> S = {u \<in> U - V. w(u) \<le> c / 2} \<and> L = {u \<in> U - V. c / 2 < w(u)}} DO
	+ u := (SOME u. u \<in> V);
	+ IF w(u) \<le> c / 2
	+ THEN S := S \<union> {u}
	+ ELSE L := L \<union> {u} FI;
	+ V := V - {u}
	+ OD;
	+ P\<^sub>1 := {}; P\<^sub>2 := {}; B\<^sub>1 := {}; B\<^sub>2 := {};
	+ WHILE S \<noteq> {} INV {inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L} DO
	+ IF B\<^sub>1 \<noteq> {}
	+ THEN u := (SOME u. u \<in> S); S := S - {u}
	+ ELSE IF L \<noteq> {}
	+ THEN u := (SOME u. u \<in> L); L := L - {u}
	+ ELSE u := (SOME u. u \<in> S); S := S - {u} FI FI;
	+ IF W(B\<^sub>1) + w(u) \<le> c
	+ THEN B\<^sub>1 := B\<^sub>1 \<union> {u}
	+ ELSE IF W(B\<^sub>2) + w(u) \<le> c
	+ THEN B\<^sub>2 := B\<^sub>2 \<union> {u}
	+ ELSE P\<^sub>2 := P\<^sub>2 \<union> wrap B\<^sub>2; B\<^sub>2 := {u} FI;
	+ P\<^sub>1 := P\<^sub>1 \<union> wrap B\<^sub>1; B\<^sub>1 := {} FI
	+ OD;
	+ P := P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2; V := L;
	+ WHILE V \<noteq> {}
	+ INV {S = {} \<and> inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \<and> V \<subseteq> L \<and> P = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v}\|v. v \<in> L - V}} DO
	+ u := (SOME u. u \<in> V); P := P \<union> {{u}}; V := V - {u}
	+ OD
	+ {bp P \<and> (\<forall>Q. bp Q \<longrightarrow> card P \<le> 3 / 2 * card Q)}"
	+proof (vcg, goal_cases)
	+ case (1 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
	+ then show ?case by blast
	+next
	+ case (2 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
	+ then show ?case by (auto simp: some_in_eq)
	+next
	+ case (3 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
	+ then show ?case using loop_init by force
	+next
	+ case (4 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
	+ then have INV: "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" ..
	+ let ?s = "SOME u. u \<in> S"
	+ let ?l = "SOME u. u \<in> L"
	+ note SL_def = inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF INV]]
	+ have LIN: "L \<noteq> {} \<Longrightarrow> ?l \<in> L" using some_in_eq by metis
	+ then have LWEIGHT: "L \<noteq> {} \<Longrightarrow> w ?l \<le> c" using weight SL_def by blast
	+ from 4 have "S \<noteq> {}" ..
	+ then have IN: "?s \<in> S" using some_in_eq by metis
	+ then have "w ?s \<le> c" using SL_def by auto
	+ then show ?case
	+ using LWEIGHT loop_stepA[OF INV _ _ IN] loop_stepB[OF INV _ LIN] loop_stepC[OF INV _ IN]
	+ and loop_stepD[OF INV _ IN] loop_stepE[OF INV _ IN] by (cases \<open>B\<^sub>1 = {}\<close>, cases \<open>L = {}\<close>) auto
	+next
	+ case (5 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
	+ then show ?case by blast
	+next
	+ case (6 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
	+ then have *: "(SOME u. u \<in> V) \<in> V" "(SOME u. u \<in> V) \<in> L" by (auto simp add: some_in_eq)
	+ then have "P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> L - (V - {SOME u. u \<in> V})}
	+ = P\<^sub>1 \<union> wrap B\<^sub>1 \<union> P\<^sub>2 \<union> wrap B\<^sub>2 \<union> {{v} \|v. v \<in> L - V \<union> {SOME u. u \<in> V}}"
	+ by blast
	+ with 6 * show ?case by blast
	+next
	+ case (7 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u)
	+ then have *: "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L"
	+ using inv\<^sub>3E(1) by blast
	+ from inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF *]] 7
	+ have "bp P" by fastforce
	+ with bin_packing_lower_bound_card[OF _ *] 7
	+ show ?case by fastforce
	+qed
	+
	+end (* BinPacking_Complete *)
	+
	+end (* Theory *)
	\ No newline at end of file
	diff --git a/thys/Approximation_Algorithms/Approx_LB_Hoare.thy b/thys/Approximation_Algorithms/Approx_LB_Hoare.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Approximation_Algorithms/Approx_LB_Hoare.thy
	@@ -0,0 +1,609 @@
	+section \<open>Load Balancing\<close>
	+
	+theory Approx_LB_Hoare
	+ imports Complex_Main "HOL-Hoare.Hoare_Logic"
	+begin
	+
	+text \<open>This is formalization of the load balancing algorithms and proofs
	+in the book by Kleinberg and Tardos \cite{KleinbergT06}.\<close>
	+
	+hide_const (open) sorted
	+
	+(* TODO: mv *)
	+
	+lemma sum_le_card_Max: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> sum f A \<le> card A * Max (f ` A)"
	+proof(induction A rule: finite_ne_induct)
	+ case (singleton x)
	+ then show ?case by simp
	+next
	+ case (insert x F)
	+ then show ?case by (auto simp: max_def order.trans[of "sum f F" "card F * Max (f ` F)"])
	+qed
	+
	+lemma Max_const[simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Max ((\<lambda>_. c) ` A) = c"
	+using Max_in image_is_empty by blast
	+
	+abbreviation Max\<^sub>0 :: "nat set \<Rightarrow> nat" where
	+"Max\<^sub>0 N \<equiv> (if N={} then 0 else Max N)"
	+
	+fun f_Max\<^sub>0 :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
	+ "f_Max\<^sub>0 f 0 = 0"
	+\| "f_Max\<^sub>0 f (Suc x) = max (f (Suc x)) (f_Max\<^sub>0 f x)"
	+
	+lemma f_Max\<^sub>0_equiv: "f_Max\<^sub>0 f n = Max\<^sub>0 (f ` {1..n})"
	+ by (induction n) (auto simp: not_le atLeastAtMostSuc_conv)
	+
	+lemma f_Max\<^sub>0_correct:
	+ "\<forall>x \<in> {1..m}. T x \<le> f_Max\<^sub>0 T m"
	+ "m > 0 \<Longrightarrow> \<exists>x \<in> {1..m}. T x = f_Max\<^sub>0 T m"
	+ apply (induction m)
	+ apply simp_all
	+ apply (metis atLeastAtMost_iff le_Suc_eq max.cobounded1 max.coboundedI2)
	+ subgoal for m by (cases \<open>m = 0\<close>) (auto simp: max_def)
	+ done
	+
	+lemma f_Max\<^sub>0_mono:
	+ "y \<le> T x \<Longrightarrow> f_Max\<^sub>0 (T (x := y)) m \<le> f_Max\<^sub>0 T m"
	+ "T x \<le> y \<Longrightarrow> f_Max\<^sub>0 T m \<le> f_Max\<^sub>0 (T (x := y)) m"
	+ by (induction m) auto
	+
	+lemma f_Max\<^sub>0_out_of_range [simp]:
	+ "x \<notin> {1..k} \<Longrightarrow> f_Max\<^sub>0 (T (x := y)) k = f_Max\<^sub>0 T k"
	+ by (induction k) auto
	+
	+lemma fun_upd_f_Max\<^sub>0:
	+ assumes "x \<in> {1..m}" "T x \<le> y"
	+ shows "f_Max\<^sub>0 (T (x := y)) m = max y (f_Max\<^sub>0 T m)"
	+ using assms by (induction m) auto
	+
	+locale LoadBalancing = (* Load Balancing *)
	+ fixes t :: "nat \<Rightarrow> nat"
	+ and m :: nat
	+ and n :: nat
	+ assumes m_gt_0: "m > 0"
	+begin
	+
	+subsection \<open>Formalization of a Correct Load Balancing\<close>
	+
	+subsubsection \<open>Definition\<close>
	+
	+definition lb :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
	+ "lb T A j = ((\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}) \<comment> \<open>No job is assigned to more than one machine\<close>
	+ \<and> (\<Union>x \<in> {1..m}. A x) = {1..j} \<comment> \<open>Every job is assigned\<close>
	+ \<and> (\<forall>x \<in> {1..m}. (\<Sum>j \<in> A x. t j) = T x) \<comment> \<open>The processing times sum up to the correct load\<close>)"
	+
	+abbreviation makespan :: "(nat \<Rightarrow> nat) \<Rightarrow> nat" where
	+ "makespan T \<equiv> f_Max\<^sub>0 T m"
	+
	+lemma makespan_def': "makespan T = Max (T ` {1..m})"
	+ using m_gt_0 by (simp add: f_Max\<^sub>0_equiv)
	+(*
	+lemma makespan_correct:
	+ "\<forall>x \<in> {1..m}. T x \<le> makespan T m"
	+ "m > 0 \<Longrightarrow> \<exists>x \<in> {1..m}. T x = makespan T m"
	+ apply (induction m)
	+ apply simp_all
	+ apply (metis atLeastAtMost_iff le_Suc_eq max.cobounded1 max.coboundedI2)
	+ subgoal for m by (cases \<open>m = 0\<close>) (auto simp: max_def)
	+ done
	+
	+lemma no_machines_lb_iff_no_jobs: "lb T A j 0 \<longleftrightarrow> j = 0"
	+ unfolding lb_def by auto
	+
	+lemma machines_if_jobs: "\<lbrakk> lb T A j m; j > 0 \<rbrakk> \<Longrightarrow> m > 0"
	+ using no_machines_lb_iff_no_jobs by (cases m) auto
	+*)
	+
	+lemma makespan_correct:
	+ "\<forall>x \<in> {1..m}. T x \<le> makespan T"
	+ "\<exists>x \<in> {1..m}. T x = makespan T"
	+ using f_Max\<^sub>0_correct m_gt_0 by auto
	+
	+lemma lbE:
	+ assumes "lb T A j"
	+ shows "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
	+ "(\<Union>x \<in> {1..m}. A x) = {1..j}"
	+ "\<forall>x \<in> {1..m}. (\<Sum>y \<in> A x. t y) = T x"
	+ using assms unfolding lb_def by blast+
	+
	+lemma lbI:
	+ assumes "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
	+ "(\<Union>x \<in> {1..m}. A x) = {1..j}"
	+ "\<forall>x \<in> {1..m}. (\<Sum>y \<in> A x. t y) = T x"
	+ shows "lb T A j" using assms unfolding lb_def by blast
	+
	+lemma A_lb_finite [simp]:
	+ assumes "lb T A j" "x \<in> {1..m}"
	+ shows "finite (A x)"
	+ by (metis lbE(2) assms finite_UN finite_atLeastAtMost)
	+
	+text \<open>If \<open>A x\<close> is pairwise disjoint for all \<open>x \<in> {1..m}\<close>, then the the sum over the sums of the
	+ individual \<open>A x\<close> is equal to the sum over the union of all \<open>A x\<close>.\<close>
	+lemma sum_sum_eq_sum_Un:
	+ fixes A :: "nat \<Rightarrow> nat set"
	+ assumes "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
	+ and "\<forall>x \<in> {1..m}. finite (A x)"
	+ shows "(\<Sum>x \<in> {1..m}. (\<Sum>y \<in> A x. t y)) = (\<Sum>x \<in> (\<Union>y \<in> {1..m}. A y). t x)"
	+ using assms
	+proof (induction m)
	+ case (Suc m)
	+ have FINITE: "finite (\<Union>x \<in> {1..m}. A x)" "finite (A (Suc m))"
	+ using Suc.prems(2) by auto
	+ have "\<forall>x \<in> {1..m}. A x \<inter> A (Suc m) = {}"
	+ using Suc.prems(1) by simp
	+ then have DISJNT: "(\<Union>x \<in> {1..m}. A x) \<inter> (A (Suc m)) = {}" using Union_disjoint by blast
	+ have "(\<Sum>x \<in> (\<Union>y \<in> {1..m}. A y). t x) + (\<Sum>x \<in> A (Suc m). t x)
	+ = (\<Sum>x \<in> ((\<Union>y \<in> {1..m}. A y) \<union> A (Suc m)). t x)"
	+ using sum.union_disjoint[OF FINITE DISJNT, symmetric] .
	+ also have "... = (\<Sum>x \<in> (\<Union>y \<in> {1..Suc m}. A y). t x)"
	+ by (metis UN_insert image_Suc_lessThan image_insert inf_sup_aci(5) lessThan_Suc)
	+ finally show ?case using Suc by auto
	+qed simp
	+
	+text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines,
	+ then the sum of the loads has to be equal to the sum of the processing times of the jobs\<close>
	+lemma lb_impl_job_sum:
	+ assumes "lb T A j"
	+ shows "(\<Sum>x \<in> {1..m}. T x) = (\<Sum>x \<in> {1..j}. t x)"
	+proof -
	+ note lbrules = lbE[OF assms]
	+ from assms have FINITE: "\<forall>x \<in> {1..m}. finite (A x)" by simp
	+ have "(\<Sum>x \<in> {1..m}. T x) = (\<Sum>x \<in> {1..m}. (\<Sum>y \<in> A x. t y))"
	+ using lbrules(3) by simp
	+ also have "... = (\<Sum>x \<in> {1..j}. t x)"
	+ using sum_sum_eq_sum_Un[OF lbrules(1) FINITE]
	+ unfolding lbrules(2) .
	+ finally show ?thesis .
	+qed
	+
	+subsubsection \<open>Lower Bounds for the Makespan\<close>
	+
	+text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines, then the processing time
	+ of any job \<open>x \<in> {1..j}\<close> is a lower bound for the load of some machine \<open>y \<in> {1..m}\<close>\<close>
	+lemma job_lower_bound_machine:
	+ assumes "lb T A j" "x \<in> {1..j}"
	+ shows "\<exists>y \<in> {1..m}. t x \<le> T y"
	+proof -
	+ note lbrules = lbE[OF assms(1)]
	+ have "\<exists>y \<in> {1..m}. x \<in> A y" using lbrules(2) assms(2) by blast
	+ then obtain y where y_def: "y \<in> {1..m}" "x \<in> A y" ..
	+ moreover have "finite (A y)" using assms(1) y_def(1) by simp
	+ ultimately have "t x \<le> (\<Sum>x \<in> A y. t x)" using lbrules(1) member_le_sum by fast
	+ also have "... = T y" using lbrules(3) y_def(1) by blast
	+ finally show ?thesis using y_def(1) by blast
	+qed
	+
	+text \<open>As the load of any machine is a lower bound for the makespan, the processing time
	+ of any job \<open>x \<in> {1..j}\<close> has to also be a lower bound for the makespan.
	+ Follows from @{thm [source] job_lower_bound_machine} and @{thm [source] makespan_correct}.\<close>
	+lemma job_lower_bound_makespan:
	+ assumes "lb T A j" "x \<in> {1..j}"
	+ shows "t x \<le> makespan T"
	+ by (meson job_lower_bound_machine[OF assms] makespan_correct(1) le_trans)
	+
	+text \<open>The makespan over \<open>j\<close> jobs is a lower bound for the makespan of any correct load balancing for \<open>j\<close> jobs.\<close>
	+lemma max_job_lower_bound_makespan:
	+ assumes "lb T A j"
	+ shows "Max\<^sub>0 (t ` {1..j}) \<le> makespan T"
	+ using job_lower_bound_makespan[OF assms] by fastforce
	+
	+lemma job_dist_lower_bound_makespan:
	+ assumes "lb T A j"
	+ shows "(\<Sum>x \<in> {1..j}. t x) / m \<le> makespan T"
	+proof -
	+ have "(\<Sum>x \<in> {1..j}. t x) \<le> m * makespan T"
	+ using assms lb_impl_job_sum[symmetric]
	+ and sum_le_card_Max[of "{1..m}"] m_gt_0 by (simp add: makespan_def')
	+ then have "real (\<Sum>x \<in> {1..j}. t x) \<le> real m * real (makespan T)"
	+ using of_nat_mono by fastforce
	+ then show ?thesis by (simp add: field_simps m_gt_0)
	+qed
	+
	+subsection \<open>The Greedy Approximation Algorithm\<close>
	+
	+text \<open>This function will perform a linear scan from \<open>k \<in> {1..m}\<close> and return the index of the machine with minimum load assuming \<open>m > 0\<close>\<close>
	+fun min\<^sub>k :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
	+ "min\<^sub>k T 0 = 1"
	+\| "min\<^sub>k T (Suc x) =
	+ (let k = min\<^sub>k T x
	+ in if T (Suc x) < T k then (Suc x) else k)"
	+
	+lemma min_correct:
	+ "\<forall>x \<in> {1..m}. T (min\<^sub>k T m) \<le> T x"
	+ by (induction m) (auto simp: Let_def le_Suc_eq, force)
	+
	+lemma min_in_range:
	+ "k > 0 \<Longrightarrow> (min\<^sub>k T k) \<in> {1..k}"
	+ by (induction k) (auto simp: Let_def, force+)
	+
	+lemma add_job:
	+ assumes "lb T A j" "x \<in> {1..m}"
	+ shows "lb (T (x := T x + t (Suc j))) (A (x := A x \<union> {Suc j})) (Suc j)"
	+ (is \<open>lb ?T ?A _\<close>)
	+proof -
	+ note lbrules = lbE[OF assms(1)]
	+
	+ \<comment> \<open>Rule 1: @{term ?A} pairwise disjoint\<close>
	+ have NOTIN: "\<forall>i \<in> {1..m}. Suc j \<notin> A i" using lbrules(2) assms(2) by force
	+ with lbrules(1) have "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> A i \<inter> (A x \<union> {Suc j}) = {}"
	+ using assms(2) by blast
	+ then have 1: "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> ?A x \<inter> ?A y = {}"
	+ using lbrules(1) by simp
	+
	+ \<comment> \<open>Rule 2: @{term ?A} contains all jobs\<close>
	+ have "(\<Union>y \<in> {1..m}. ?A y) = (\<Union>y \<in> {1..m}. A y) \<union> {Suc j}"
	+ using UNION_fun_upd assms(2) by auto
	+ also have "... = {1..Suc j}" unfolding lbrules(2) by auto
	+ finally have 2: "(\<Union>y \<in> {1..m}. ?A y) = {1..Suc j}" .
	+
	+ \<comment> \<open>Rule 3: @{term ?A} sums to @{term ?T}\<close>
	+ have "(\<Sum>i \<in> ?A x. t i) = (\<Sum>i \<in> A x \<union> {Suc j}. t i)" by simp
	+ moreover have "A x \<inter> {Suc j} = {}" using NOTIN assms(2) by blast
	+ moreover have "finite (A x)" "finite {Suc j}" using assms by simp+
	+ ultimately have "(\<Sum>i \<in> ?A x. t i) = (\<Sum>i \<in> A x. t i) + (\<Sum>i \<in> {Suc j}. t i)"
	+ using sum.union_disjoint by simp
	+ also have "... = T x + t (Suc j)" using lbrules(3) assms(2) by simp
	+ finally have "(\<Sum>i \<in> ?A x. t i) = ?T x" by simp
	+ then have 3: "\<forall>i \<in> {1..m}. (\<Sum>j \<in> ?A i. t j) = ?T i"
	+ using lbrules(3) assms(2) by simp
	+
	+ from lbI[OF 1 2 3] show ?thesis .
	+qed
	+
	+lemma makespan_mono:
	+ "y \<le> T x \<Longrightarrow> makespan (T (x := y)) \<le> makespan T"
	+ "T x \<le> y \<Longrightarrow> makespan T \<le> makespan (T (x := y))"
	+ using f_Max\<^sub>0_mono by auto
	+
	+lemma smaller_optimum:
	+ assumes "lb T A (Suc j)"
	+ shows "\<exists>T' A'. lb T' A' j \<and> makespan T' \<le> makespan T"
	+proof -
	+ note lbrules = lbE[OF assms]
	+ have "\<exists>x \<in> {1..m}. Suc j \<in> A x" using lbrules(2) by auto
	+ then obtain x where x_def: "x \<in> {1..m}" "Suc j \<in> A x" ..
	+ let ?T = "T (x := T x - t (Suc j))"
	+ let ?A = "A (x := A x - {Suc j})"
	+
	+ \<comment> \<open>Rule 1: @{term ?A} pairwise disjoint\<close>
	+ from lbrules(1) have "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> A i \<inter> (A x - {Suc j}) = {}"
	+ using x_def(1) by blast
	+ then have 1: "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> ?A x \<inter> ?A y = {}"
	+ using lbrules(1) by auto
	+
	+ \<comment> \<open>Rule 2: @{term ?A} contains all jobs\<close>
	+ have NOTIN: "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> Suc j \<notin> A i" using lbrules(1) x_def by blast
	+ then have "(\<Union>y \<in> {1..m}. ?A y) = (\<Union>y \<in> {1..m}. A y) - {Suc j}"
	+ using UNION_fun_upd x_def by auto
	+ also have "... = {1..j}" unfolding lbrules(2) by auto
	+ finally have 2: "(\<Union>y \<in> {1..m}. ?A y) = {1..j}" .
	+
	+ \<comment> \<open>Rule 3: @{term ?A} sums to @{term ?T}\<close>
	+ have "(\<Sum>i \<in> A x - {Suc j}. t i) = (\<Sum>i \<in> A x. t i) - t (Suc j)"
	+ by (simp add: sum_diff1_nat x_def(2))
	+ also have "... = T x - t (Suc j)" using lbrules(3) x_def(1) by simp
	+ finally have "(\<Sum>i \<in> ?A x. t i) = ?T x" by simp
	+ then have 3: "\<forall>i \<in> {1..m}. (\<Sum>j \<in> ?A i. t j) = ?T i"
	+ using lbrules(3) x_def(1) by simp
	+
	+ \<comment> \<open>@{term makespan} is not larger\<close>
	+ have "lb ?T ?A j \<and> makespan ?T \<le> makespan T"
	+ using lbI[OF 1 2 3] makespan_mono(1) by force
	+ then show ?thesis by blast
	+qed
	+
	+text \<open>If the processing time \<open>y\<close> does not contribute to the makespan, we can ignore it.\<close>
	+lemma remove_small_job:
	+ assumes "makespan (T (x := T x + y)) \<noteq> T x + y"
	+ shows "makespan (T (x := T x + y)) = makespan T"
	+proof -
	+ let ?T = "T (x := T x + y)"
	+ have NOT_X: "makespan ?T \<noteq> ?T x" using assms(1) by simp
	+ then have "\<exists>i \<in> {1..m}. makespan ?T = ?T i \<and> i \<noteq> x"
	+ using makespan_correct(2) by metis
	+ then obtain i where i_def: "i \<in> {1..m}" "makespan ?T = ?T i" "i \<noteq> x" by blast
	+ then have "?T i = T i" using NOT_X by simp
	+ moreover from this have "makespan T = T i"
	+ by (metis i_def(1,2) antisym_conv le_add1 makespan_mono(2) makespan_correct(1))
	+ ultimately show ?thesis using i_def(2) by simp
	+qed
	+
	+lemma greedy_makespan_no_jobs [simp]:
	+ "makespan (\<lambda>_. 0) = 0"
	+ using m_gt_0 by (simp add: makespan_def')
	+
	+lemma min_avg: "m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..m}. T i)"
	+ (is \<open>_ * ?T \<le> ?S\<close>)
	+proof -
	+ have "(\<Sum>_ \<in> {1..m}. ?T) \<le> ?S"
	+ using sum_mono[of \<open>{1..m}\<close> \<open>\<lambda>_. ?T\<close> T]
	+ and min_correct by blast
	+ then show ?thesis by simp
	+qed
	+
	+definition inv\<^sub>1 :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
	+ "inv\<^sub>1 T A j = (lb T A j \<and> j \<le> n \<and> (\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 2 * makespan T'))"
	+
	+lemma inv\<^sub>1E:
	+ assumes "inv\<^sub>1 T A j"
	+ shows "lb T A j" "j \<le> n"
	+ "lb T' A' j \<Longrightarrow> makespan T \<le> 2 * makespan T'"
	+ using assms unfolding inv\<^sub>1_def by blast+
	+
	+lemma inv\<^sub>1I:
	+ assumes "lb T A j" "j \<le> n" "\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 2 * makespan T'"
	+ shows "inv\<^sub>1 T A j" using assms unfolding inv\<^sub>1_def by blast
	+
	+lemma inv\<^sub>1_step:
	+ assumes "inv\<^sub>1 T A j" "j < n"
	+ shows "inv\<^sub>1 (T ((min\<^sub>k T m) := T (min\<^sub>k T m) + t (Suc j)))
	+ (A ((min\<^sub>k T m) := A (min\<^sub>k T m) \<union> {Suc j})) (Suc j)"
	+ (is \<open>inv\<^sub>1 ?T ?A _\<close>)
	+proof -
	+ note invrules = inv\<^sub>1E[OF assms(1)]
	+ \<comment> \<open>Greedy is correct\<close>
	+ have LB: "lb ?T ?A (Suc j)"
	+ using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast
	+ \<comment> \<open>Greedy maintains approximation factor\<close>
	+ have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 2 * makespan T'"
	+ proof rule+
	+ fix T\<^sub>1 A\<^sub>1 assume "lb T\<^sub>1 A\<^sub>1 (Suc j)"
	+ from smaller_optimum[OF this]
	+ obtain T\<^sub>0 A\<^sub>0 where "lb T\<^sub>0 A\<^sub>0 j" "makespan T\<^sub>0 \<le> makespan T\<^sub>1" by blast
	+ then have IH: "makespan T \<le> 2 * makespan T\<^sub>1"
	+ using invrules(3) by force
	+ show "makespan ?T \<le> 2 * makespan T\<^sub>1"
	+ proof (cases \<open>makespan ?T = T (min\<^sub>k T m) + t (Suc j)\<close>)
	+ case True
	+ have "m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..m}. T i)" by (rule min_avg)
	+ also have "... = (\<Sum>i \<in> {1..j}. t i)" by (rule lb_impl_job_sum[OF invrules(1)])
	+ finally have "real m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i)"
	+ by (auto dest: of_nat_mono)
	+ with m_gt_0 have "T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i) / m"
	+ by (simp add: field_simps)
	+ then have "T (min\<^sub>k T m) \<le> makespan T\<^sub>1"
	+ using job_dist_lower_bound_makespan[OF \<open>lb T\<^sub>0 A\<^sub>0 j\<close>]
	+ and \<open>makespan T\<^sub>0 \<le> makespan T\<^sub>1\<close> by linarith
	+ moreover have "t (Suc j) \<le> makespan T\<^sub>1"
	+ using job_lower_bound_makespan[OF \<open>lb T\<^sub>1 A\<^sub>1 (Suc j)\<close>] by simp
	+ ultimately show ?thesis unfolding True by simp
	+ next
	+ case False show ?thesis using remove_small_job[OF False] IH by simp
	+ qed
	+ qed
	+ from inv\<^sub>1I[OF LB _ MK] show ?thesis using assms(2) by simp
	+qed
	+
	+lemma simple_greedy_approximation:
	+"VARS T A i j
	+{True}
	+T := (\<lambda>_. 0);
	+A := (\<lambda>_. {});
	+j := 0;
	+WHILE j < n INV {inv\<^sub>1 T A j} DO
	+ i := min\<^sub>k T m;
	+ j := (Suc j);
	+ A := A (i := A(i) \<union> {j});
	+ T := T (i := T(i) + t j)
	+OD
	+{lb T A n \<and> (\<forall>T' A'. lb T' A' n \<longrightarrow> makespan T \<le> 2 * makespan T')}"
	+proof (vcg, goal_cases)
	+ case (1 T A i j)
	+ then show ?case by (simp add: lb_def inv\<^sub>1_def)
	+next
	+ case (2 T A i j)
	+ then show ?case using inv\<^sub>1_step by simp
	+next
	+ case (3 T A i j)
	+ then show ?case unfolding inv\<^sub>1_def by force
	+qed
	+
	+definition sorted :: "nat \<Rightarrow> bool" where
	+ "sorted j = (\<forall>x \<in> {1..j}. \<forall>y \<in> {1..x}. t x \<le> t y)"
	+
	+lemma sorted_smaller [simp]: "\<lbrakk> sorted j; j \<ge> j' \<rbrakk> \<Longrightarrow> sorted j'"
	+ unfolding sorted_def by simp
	+
	+lemma j_gt_m_pigeonhole:
	+ assumes "lb T A j" "j > m"
	+ shows "\<exists>x \<in> {1..j}. \<exists>y \<in> {1..j}. \<exists>z \<in> {1..m}. x \<noteq> y \<and> x \<in> A z \<and> y \<in> A z"
	+proof -
	+ have "\<forall>x \<in> {1..j}. \<exists>y \<in> {1..m}. x \<in> A y"
	+ using lbE(2)[OF assms(1)] by blast
	+ then have "\<exists>f. \<forall>x \<in> {1..j}. x \<in> A (f x) \<and> f x \<in> {1..m}" by metis
	+ then obtain f where f_def: "\<forall>x \<in> {1..j}. x \<in> A (f x) \<and> f x \<in> {1..m}" ..
	+ then have "card (f ` {1..j}) \<le> card {1..m}"
	+ by (meson card_mono finite_atLeastAtMost image_subset_iff)
	+ also have "... < card {1..j}" using assms(2) by simp
	+ finally have "card (f ` {1..j}) < card {1..j}" .
	+ then have "\<not> inj_on f {1..j}" using pigeonhole by blast
	+ then have "\<exists>x \<in> {1..j}. \<exists>y \<in> {1..j}. x \<noteq> y \<and> f x = f y"
	+ unfolding inj_on_def by blast
	+ then show ?thesis using f_def by metis
	+qed
	+
	+text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines with \<open>j > m\<close>,
	+ and the jobs are sorted in descending order, then there exists a machine \<open>x \<in> {1..m}\<close>
	+ whose load is at least twice as large as the processing time of job \<open>j\<close>.\<close>
	+lemma sorted_job_lower_bound_machine:
	+ assumes "lb T A j" "j > m" "sorted j"
	+ shows "\<exists>x \<in> {1..m}. 2 * t j \<le> T x"
	+proof -
	+ \<comment> \<open>Step 1: Obtaining the jobs\<close>
	+ note lbrules = lbE[OF assms(1)]
	+ obtain j\<^sub>1 j\<^sub>2 x where *:
	+ "j\<^sub>1 \<in> {1..j}" "j\<^sub>2 \<in> {1..j}" "x \<in> {1..m}" "j\<^sub>1 \<noteq> j\<^sub>2" "j\<^sub>1 \<in> A x" "j\<^sub>2 \<in> A x"
	+ using j_gt_m_pigeonhole[OF assms(1,2)] by blast
	+
	+ \<comment> \<open>Step 2: Jobs contained in sum\<close>
	+ have "finite (A x)" using assms(1) *(3) by simp
	+ then have SUM: "(\<Sum>i \<in> A x. t i) = t j\<^sub>1 + t j\<^sub>2 + (\<Sum>i \<in> A x - {j\<^sub>1} - {j\<^sub>2}. t i)"
	+ using *(4-6) by (simp add: sum.remove)
	+
	+ \<comment> \<open>Step 3: Proof of lower bound\<close>
	+ have "t j \<le> t j\<^sub>1" "t j \<le> t j\<^sub>2"
	+ using assms(3) *(1-2) unfolding sorted_def by auto
	+ then have "2 * t j \<le> t j\<^sub>1 + t j\<^sub>2" by simp
	+ also have "... \<le> (\<Sum>i \<in> A x. t i)" unfolding SUM by simp
	+ finally have "2 * t j \<le> T x" using lbrules(3) *(3) by simp
	+ then show ?thesis using *(3) by blast
	+qed
	+
	+text \<open>Reasoning analogous to @{thm [source] job_lower_bound_makespan}.\<close>
	+lemma sorted_job_lower_bound_makespan:
	+ assumes "lb T A j" "j > m" "sorted j"
	+ shows "2 * t j \<le> makespan T"
	+proof -
	+ obtain x where x_def: "x \<in> {1..m}" "2 * t j \<le> T x"
	+ using sorted_job_lower_bound_machine[OF assms] ..
	+ with makespan_correct(1) have "T x \<le> makespan T" by blast
	+ with x_def(2) show ?thesis by simp
	+qed
	+
	+lemma min_zero:
	+ assumes "x \<in> {1..k}" "T x = 0"
	+ shows "T (min\<^sub>k T k) = 0"
	+ using assms(1)
	+proof (induction k)
	+ case (Suc k)
	+ show ?case proof (cases \<open>x = Suc k\<close>)
	+ case True
	+ then show ?thesis using assms(2) by (simp add: Let_def)
	+ next
	+ case False
	+ with Suc have "T (min\<^sub>k T k) = 0" by simp
	+ then show ?thesis by simp
	+ qed
	+qed simp
	+
	+lemma min_zero_index:
	+ assumes "x \<in> {1..k}" "T x = 0"
	+ shows "min\<^sub>k T k \<le> x"
	+ using assms(1)
	+proof (induction k)
	+ case (Suc k)
	+ show ?case proof (cases \<open>x = Suc k\<close>)
	+ case True
	+ then show ?thesis using min_in_range[of "Suc k"] by simp
	+ next
	+ case False
	+ with Suc.prems have "x \<in> {1..k}" by simp
	+ from min_zero[OF this, of T] assms(2) Suc.IH[OF this]
	+ show ?thesis by simp
	+ qed
	+qed simp
	+
	+definition inv\<^sub>2 :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
	+ "inv\<^sub>2 T A j = (lb T A j \<and> j \<le> n
	+ \<and> (\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 3 / 2 * makespan T')
	+ \<and> (\<forall>x > j. T x = 0)
	+ \<and> (j \<le> m \<longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})))"
	+
	+lemma inv\<^sub>2E:
	+ assumes "inv\<^sub>2 T A j"
	+ shows "lb T A j" "j \<le> n"
	+ "lb T' A' j \<Longrightarrow> makespan T \<le> 3 / 2 * makespan T'"
	+ "\<forall>x > j. T x = 0" "j \<le> m \<Longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})"
	+ using assms unfolding inv\<^sub>2_def by blast+
	+
	+lemma inv\<^sub>2I:
	+ assumes "lb T A j" "j \<le> n"
	+ "\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 3 / 2 * makespan T'"
	+ "\<forall>x > j. T x = 0"
	+ "j \<le> m \<Longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})"
	+ shows "inv\<^sub>2 T A j"
	+ unfolding inv\<^sub>2_def using assms by blast
	+
	+lemma inv\<^sub>2_step:
	+ assumes "sorted n" "inv\<^sub>2 T A j" "j < n"
	+ shows "inv\<^sub>2 (T (min\<^sub>k T m := T(min\<^sub>k T m) + t(Suc j)))
	+ (A (min\<^sub>k T m := A(min\<^sub>k T m) \<union> {Suc j})) (Suc j)"
	+ (is \<open>inv\<^sub>2 ?T ?A _\<close>)
	+proof (cases \<open>Suc j > m\<close>)
	+ case True note invrules = inv\<^sub>2E[OF assms(2)]
	+ \<comment> \<open>Greedy is correct\<close>
	+ have LB: "lb ?T ?A (Suc j)"
	+ using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast
	+ \<comment> \<open>Greedy maintains approximation factor\<close>
	+ have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 3 / 2 * makespan T'"
	+ proof rule+
	+ fix T\<^sub>1 A\<^sub>1 assume "lb T\<^sub>1 A\<^sub>1 (Suc j)"
	+ from smaller_optimum[OF this]
	+ obtain T\<^sub>0 A\<^sub>0 where "lb T\<^sub>0 A\<^sub>0 j" "makespan T\<^sub>0 \<le> makespan T\<^sub>1" by blast
	+ then have IH: "makespan T \<le> 3 / 2 * makespan T\<^sub>1"
	+ using invrules(3) by force
	+ show "makespan ?T \<le> 3 / 2 * makespan T\<^sub>1"
	+ proof (cases \<open>makespan ?T = T (min\<^sub>k T m) + t (Suc j)\<close>)
	+ case True
	+ have "m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..m}. T i)" by (rule min_avg)
	+ also have "... = (\<Sum>i \<in> {1..j}. t i)" by (rule lb_impl_job_sum[OF invrules(1)])
	+ finally have "real m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i)"
	+ by (auto dest: of_nat_mono)
	+ with m_gt_0 have "T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i) / m"
	+ by (simp add: field_simps)
	+ then have "T (min\<^sub>k T m) \<le> makespan T\<^sub>1"
	+ using job_dist_lower_bound_makespan[OF \<open>lb T\<^sub>0 A\<^sub>0 j\<close>]
	+ and \<open>makespan T\<^sub>0 \<le> makespan T\<^sub>1\<close> by linarith
	+ moreover have "2 * t (Suc j) \<le> makespan T\<^sub>1"
	+ using sorted_job_lower_bound_makespan[OF \<open>lb T\<^sub>1 A\<^sub>1 (Suc j)\<close> \<open>Suc j > m\<close>]
	+ and assms(1,3) by simp
	+ ultimately show ?thesis unfolding True by simp
	+ next
	+ case False show ?thesis using remove_small_job[OF False] IH by simp
	+ qed
	+ qed
	+ have "\<forall>x > Suc j. ?T x = 0"
	+ using invrules(4) min_in_range[OF m_gt_0, of T] True by simp
	+ with inv\<^sub>2I[OF LB _ MK] show ?thesis using assms(3) True by simp
	+next
	+ case False
	+ then have IN_RANGE: "Suc j \<in> {1..m}" by simp
	+ note invrules = inv\<^sub>2E[OF assms(2)]
	+ then have "T (Suc j) = 0" by blast
	+
	+ \<comment> \<open>Greedy is correct\<close>
	+ have LB: "lb ?T ?A (Suc j)"
	+ using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast
	+
	+ \<comment> \<open>Greedy is trivially optimal\<close>
	+ from IN_RANGE \<open>T (Suc j) = 0\<close> have "min\<^sub>k T m \<le> Suc j"
	+ using min_zero_index by blast
	+ with invrules(4) have EMPTY: "\<forall>x > Suc j. ?T x = 0" by simp
	+ from IN_RANGE \<open>T (Suc j) = 0\<close> have "T (min\<^sub>k T m) = 0"
	+ using min_zero by blast
	+ with fun_upd_f_Max\<^sub>0[OF min_in_range[OF m_gt_0]] invrules(5) False
	+ have TRIV: "makespan ?T = Max\<^sub>0 (t ` {1..Suc j})" unfolding f_Max\<^sub>0_equiv[symmetric] by simp
	+ have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 3 / 2 * makespan T'"
	+ by (auto simp: TRIV[folded f_Max\<^sub>0_equiv]
	+ dest!: max_job_lower_bound_makespan[folded f_Max\<^sub>0_equiv])
	+
	+ from inv\<^sub>2I[OF LB _ MK EMPTY TRIV] show ?thesis using assms(3) by simp
	+qed
	+
	+lemma sorted_greedy_approximation:
	+"sorted n \<Longrightarrow> VARS T A i j
	+{True}
	+T := (\<lambda>_. 0);
	+A := (\<lambda>_. {});
	+j := 0;
	+WHILE j < n INV {inv\<^sub>2 T A j} DO
	+ i := min\<^sub>k T m;
	+ j := (Suc j);
	+ A := A (i := A(i) \<union> {j});
	+ T := T (i := T(i) + t j)
	+OD
	+{lb T A n \<and> (\<forall>T' A'. lb T' A' n \<longrightarrow> makespan T \<le> 3 / 2 * makespan T')}"
	+proof (vcg, goal_cases)
	+ case (1 T A i j)
	+ then show ?case by (simp add: lb_def inv\<^sub>2_def)
	+next
	+ case (2 T A i j)
	+ then show ?case using inv\<^sub>2_step by simp
	+next
	+ case (3 T A i j)
	+ then show ?case unfolding inv\<^sub>2_def by force
	+qed
	+
	+end (* LoadBalancing *)
	+
	+end (* Theory *)
	\ No newline at end of file
	diff --git a/thys/Approximation_Algorithms/Approx_MIS_Hoare.thy b/thys/Approximation_Algorithms/Approx_MIS_Hoare.thy
	new file mode 100755
	--- /dev/null
	+++ b/thys/Approximation_Algorithms/Approx_MIS_Hoare.thy
	@@ -0,0 +1,561 @@
	+section "Independent Set"
	+
	+theory Approx_MIS_Hoare
	+imports
	+ "HOL-Hoare.Hoare_Logic"
	+ "HOL-Library.Disjoint_Sets"
	+begin
	+
	+
	+text \<open>The algorithm is classical, the proofs are inspired by the ones
	+by Berghammer and M\"uller-Olm \cite{BerghammerM03}.
	+In particular the approximation ratio is improved from \<open>\<Delta>+1\<close> to \<open>\<Delta>\<close>.\<close>
	+
	+
	+subsection "Graph"
	+
	+text \<open>A set set is simply a set of edges, where an edge is a 2-element set.\<close>
	+
	+definition independent_vertices :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+"independent_vertices E S \<longleftrightarrow> S \<subseteq> \<Union>E \<and> (\<forall>v1 v2. v1 \<in> S \<and> v2 \<in> S \<longrightarrow> {v1, v2} \<notin> E)"
	+
	+locale Graph_E =
	+ fixes E :: "'a set set"
	+ assumes finite_E: "finite E"
	+ assumes edges2: "e \<in> E \<Longrightarrow> card e = 2"
	+begin
	+
	+fun vertices :: "'a set set \<Rightarrow> 'a set" where
	+"vertices G = \<Union>G"
	+
	+abbreviation V :: "'a set" where
	+"V \<equiv> vertices E"
	+
	+definition approximation_miv :: "nat \<Rightarrow> 'a set \<Rightarrow> bool" where
	+"approximation_miv n S \<longleftrightarrow> independent_vertices E S \<and> (\<forall>S'. independent_vertices E S' \<longrightarrow> card S' \<le> card S * n)"
	+
	+fun neighbors :: "'a \<Rightarrow> 'a set" where
	+"neighbors v = {u. {u,v} \<in> E}"
	+
	+fun degree_vertex :: "'a \<Rightarrow> nat" where
	+"degree_vertex v = card (neighbors v)"
	+
	+abbreviation \<Delta> :: nat where
	+"\<Delta> \<equiv> Max{degree_vertex u\|u. u \<in> V}"
	+
	+lemma finite_edges: "e \<in> E \<Longrightarrow> finite e"
	+ using card_ge_0_finite and edges2 by force
	+
	+lemma finite_V: "finite V"
	+ using finite_edges and finite_E by auto
	+
	+lemma finite_neighbors: "finite (neighbors u)"
	+ using finite_V and rev_finite_subset [of V "neighbors u"] by auto
	+
	+lemma independent_vertices_finite: "independent_vertices E S \<Longrightarrow> finite S"
	+ by (metis rev_finite_subset independent_vertices_def vertices.simps finite_V)
	+
	+lemma edge_ex_vertices: "e \<in> E \<Longrightarrow> \<exists>u v. u \<noteq> v \<and> e = {u, v}"
	+proof -
	+ assume "e \<in> E"
	+ then have "card e = Suc (Suc 0)" using edges2 by auto
	+ then show "\<exists>u v. u \<noteq> v \<and> e = {u, v}"
	+ by (metis card_eq_SucD insertI1)
	+qed
	+
	+lemma \<Delta>_pos [simp]: "E = {} \<or> 0 < \<Delta>"
	+proof cases
	+ assume "E = {}"
	+ then show "E = {} \<or> 0 < \<Delta>" by auto
	+next
	+ assume 1: "E \<noteq> {}"
	+ then have "V \<noteq> {}" using edges2 by fastforce
	+ moreover have "finite {degree_vertex u \|u. u \<in> V}"
	+ by (metis finite_V finite_imageI Setcompr_eq_image)
	+ ultimately have 2: "\<Delta> \<in> {degree_vertex u \|u. u \<in> V}" using Max_in by auto
	+ have "\<Delta> \<noteq> 0"
	+ proof
	+ assume "\<Delta> = 0"
	+ with 2 obtain u where 3: "u \<in> V" and 4: "degree_vertex u = 0" by auto
	+ from 3 obtain e where 5: "e \<in> E" and "u \<in> e" by auto
	+ moreover with 4 have "\<forall>v. {u, v} \<noteq> e" using finite_neighbors insert_absorb by fastforce
	+ ultimately show False using edge_ex_vertices by auto
	+ qed
	+ then show "E = {} \<or> 0 < \<Delta>" by auto
	+qed
	+
	+lemma \<Delta>_max_degree: "u \<in> V \<Longrightarrow> degree_vertex u \<le> \<Delta>"
	+proof -
	+ assume H: "u \<in> V"
	+ have "finite {degree_vertex u \|u. u \<in> V}"
	+ by (metis finite_V finite_imageI Setcompr_eq_image)
	+ with H show "degree_vertex u \<le> \<Delta>" using Max_ge by auto
	+qed
	+
	+subsection \<open>Wei's algorithm: \<open>(\<Delta>+1)\<close>-approximation\<close>
	+
	+text \<open>The 'functional' part of the invariant, used to prove that the algorithm produces an independent set of vertices.\<close>
	+
	+definition inv_iv :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+"inv_iv S X \<longleftrightarrow> independent_vertices E S
	+ \<and> X \<subseteq> V
	+ \<and> (\<forall>v1 \<in> (V - X). \<forall>v2 \<in> S. {v1, v2} \<notin> E)
	+ \<and> S \<subseteq> X"
	+
	+text \<open>Strenghten the invariant with an approximation ratio \<open>r\<close>:\<close>
	+
	+definition inv_approx :: "'a set \<Rightarrow> 'a set \<Rightarrow> nat \<Rightarrow> bool" where
	+"inv_approx S X r \<longleftrightarrow> inv_iv S X \<and> card X \<le> card S * r"
	+
	+text \<open>Preservation of the functional invariant:\<close>
	+
	+lemma inv_preserv:
	+ fixes S :: "'a set"
	+ and X :: "'a set"
	+ and x :: "'a"
	+ assumes inv: "inv_iv S X"
	+ and x_def: "x \<in> V - X"
	+ shows "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
	+proof -
	+ have inv1: "independent_vertices E S"
	+ and inv2: "X \<subseteq> V"
	+ and inv3: "S \<subseteq> X"
	+ and inv4: "\<forall>v1 v2. v1 \<in> (V - X) \<and> v2 \<in> S \<longrightarrow> {v1, v2} \<notin> E"
	+ using inv unfolding inv_iv_def by auto
	+ have finite_S: "finite S" using inv1 and independent_vertices_finite by auto
	+ have S1: "\<forall>y \<in> S. {x, y} \<notin> E" using inv4 and x_def by blast
	+ have S2: "\<forall>x \<in> S. \<forall>y \<in> S. {x, y} \<notin> E" using inv1 unfolding independent_vertices_def by metis
	+ have S3: "v1 \<in> insert x S \<Longrightarrow> v2 \<in> insert x S \<Longrightarrow> {v1, v2} \<notin> E" for v1 v2
	+ proof -
	+ assume "v1 \<in> insert x S" and "v2 \<in> insert x S"
	+ then consider
	+ (a) "v1 = x" and "v2 = x"
	+ \| (b) "v1 = x" and "v2 \<in> S"
	+ \| (c) "v1 \<in> S" and "v2 = x"
	+ \| (d) "v1 \<in> S" and "v2 \<in> S"
	+ by auto
	+ then show "{v1, v2} \<notin> E"
	+ proof cases
	+ case a then show ?thesis using edges2 by force
	+ next
	+ case b then show ?thesis using S1 by auto
	+ next
	+ case c then show ?thesis using S1 by (metis doubleton_eq_iff)
	+ next
	+ case d then show ?thesis using S2 by auto
	+ qed
	+ qed
	+ (* invariant conjunct 1 *)
	+ have "independent_vertices E (insert x S)"
	+ using S3 and inv1 and x_def unfolding independent_vertices_def by auto
	+ (* invariant conjunct 2 *)
	+ moreover have "X \<union> neighbors x \<union> {x} \<subseteq> V"
	+ proof
	+ fix xa
	+ assume "xa \<in> X \<union> neighbors x \<union> {x}"
	+ then consider (a) "xa \<in> X" \| (b) "xa \<in> neighbors x" \| (c) "xa = x" by auto
	+ then show "xa \<in> V"
	+ proof cases
	+ case a
	+ then show ?thesis using inv2 by blast
	+ next
	+ case b
	+ then show ?thesis by auto
	+ next
	+ case c
	+ then show ?thesis using x_def by blast
	+ qed
	+ qed
	+ (* invariant conjunct 3 *)
	+ moreover have "insert x S \<subseteq> X \<union> neighbors x \<union> {x}" using inv3 by auto
	+ (* invariant conjunct 4 *)
	+ moreover have "v1 \<in> V - (X \<union> neighbors x \<union> {x}) \<Longrightarrow> v2 \<in> insert x S \<Longrightarrow> {v1, v2} \<notin> E" for v1 v2
	+ proof -
	+ assume H: "v1 \<in> V - (X \<union> neighbors x \<union> {x})" and "v2 \<in> insert x S"
	+ then consider (a) "v2 = x" \| (b) "v2 \<in> S" by auto
	+ then show "{v1, v2} \<notin> E"
	+ proof cases
	+ case a
	+ with H have "v1 \<notin> neighbors v2" by blast
	+ then show ?thesis by auto
	+ next
	+ case b
	+ from H have "v1 \<in> V - X" by blast
	+ with b and inv4 show ?thesis by blast
	+ qed
	+ qed
	+ (* conclusion *)
	+ ultimately show "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})" unfolding inv_iv_def by blast
	+qed
	+
	+lemma inv_approx_preserv:
	+ assumes inv: "inv_approx S X (\<Delta> + 1)"
	+ and x_def: "x \<in> V - X"
	+ shows "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (\<Delta> + 1)"
	+proof -
	+ have finite_S: "finite S" using inv and independent_vertices_finite
	+ unfolding inv_approx_def inv_iv_def by auto
	+ have Sx: "x \<notin> S" using inv and x_def unfolding inv_approx_def inv_iv_def by blast
	+ (* main invariant is preserved *)
	+ from inv have "inv_iv S X" unfolding inv_approx_def by auto
	+ with x_def have "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
	+ proof (intro inv_preserv, auto) qed
	+ (* the approximation ratio is preserved (at most \<Delta>+1 vertices are removed in any iteration) *)
	+ moreover have "card (X \<union> neighbors x \<union> {x}) \<le> card (insert x S) * (\<Delta> + 1)"
	+ proof -
	+ have "degree_vertex x \<le> \<Delta>" using \<Delta>_max_degree and x_def by auto
	+ then have "card (neighbors x \<union> {x}) \<le> \<Delta> + 1" using card_Un_le [of "neighbors x" "{x}"] by auto
	+ then have "card (X \<union> neighbors x \<union> {x}) \<le> card X + \<Delta> + 1" using card_Un_le [of X "neighbors x \<union> {x}"] by auto
	+ also have "... \<le> card S * (\<Delta> + 1) + \<Delta> + 1" using inv unfolding inv_approx_def by auto
	+ also have "... = card (insert x S) * (\<Delta> + 1)" using finite_S and Sx by auto
	+ finally show ?thesis .
	+ qed
	+ (* conclusion *)
	+ ultimately show "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (\<Delta> + 1)"
	+ unfolding inv_approx_def by auto
	+qed
	+
	+(* the antecedent combines inv_approx (for an arbitrary ratio r) and the negated post-condition *)
	+lemma inv_approx: "independent_vertices E S \<Longrightarrow> card V \<le> card S * r \<Longrightarrow> approximation_miv r S"
	+proof -
	+ assume 1: "independent_vertices E S" and 2: "card V \<le> card S * r"
	+ have "independent_vertices E S' \<Longrightarrow> card S' \<le> card S * r" for S'
	+ proof -
	+ assume "independent_vertices E S'"
	+ then have "S' \<subseteq> V" unfolding independent_vertices_def by auto
	+ then have "card S' \<le> card V" using finite_V and card_mono by auto
	+ also have "... \<le> card S * r" using 2 by auto
	+ finally show "card S' \<le> card S * r" .
	+ qed
	+ with 1 show "approximation_miv r S" unfolding approximation_miv_def by auto
	+qed
	+
	+theorem wei_approx_\<Delta>_plus_1:
	+"VARS (S :: 'a set) (X :: 'a set) (x :: 'a)
	+ { True }
	+ S := {};
	+ X := {};
	+ WHILE X \<noteq> V
	+ INV { inv_approx S X (\<Delta> + 1) }
	+ DO x := (SOME x. x \<in> V - X);
	+ S := insert x S;
	+ X := X \<union> neighbors x \<union> {x}
	+ OD
	+ { approximation_miv (\<Delta> + 1) S }"
	+proof (vcg, goal_cases)
	+ case (1 S X x) (* invariant initially true *)
	+ then show ?case unfolding inv_approx_def inv_iv_def independent_vertices_def by auto
	+next
	+ case (2 S X x) (* invariant preserved by loop *)
	+ (* definedness of assignment *)
	+ let ?x = "(SOME x. x \<in> V - X)"
	+ have "V - X \<noteq> {}" using 2 unfolding inv_approx_def inv_iv_def by blast
	+ then have "?x \<in> V - X" using some_in_eq by metis
	+ with 2 show ?case using inv_approx_preserv by auto
	+next
	+ case (3 S X x) (* invariant implies post-condition *)
	+ then show ?case using inv_approx unfolding inv_approx_def inv_iv_def by auto
	+qed
	+
	+
	+subsection \<open>Wei's algorithm: \<open>\<Delta>\<close>-approximation\<close>
	+
	+text \<open>The previous approximation uses very little information about the optimal solution (it has at most as many vertices as the set itself). With some extra effort we can improve the ratio to \<open>\<Delta>\<close> instead of \<open>\<Delta>+1\<close>. In order to do that we must show that among the vertices removed in each iteration, at most \<open>\<Delta>\<close> could belong to an optimal solution. This requires carrying around a set \<open>P\<close> (via a ghost variable) which records the vertices deleted in each iteration.\<close>
	+
	+definition inv_partition :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
	+"inv_partition S X P \<longleftrightarrow> inv_iv S X
	+ \<and> \<Union>P = X
	+ \<and> (\<forall>p \<in> P. \<exists>s \<in> V. p = {s} \<union> neighbors s)
	+ \<and> card P = card S
	+ \<and> finite P"
	+
	+lemma inv_partition_preserv:
	+ assumes inv: "inv_partition S X P"
	+ and x_def: "x \<in> V - X"
	+ shows "inv_partition (insert x S) (X \<union> neighbors x \<union> {x}) (insert ({x} \<union> neighbors x) P)"
	+proof -
	+ have finite_S: "finite S" using inv and independent_vertices_finite
	+ unfolding inv_partition_def inv_iv_def by auto
	+ have Sx: "x \<notin> S" using inv and x_def unfolding inv_partition_def inv_iv_def by blast
	+ (* main invariant is preserved *)
	+ from inv have "inv_iv S X" unfolding inv_partition_def by auto
	+ with x_def have "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
	+ proof (intro inv_preserv, auto) qed
	+ (* conjunct 1 *)
	+ moreover have "\<Union>(insert ({x} \<union> neighbors x) P) = X \<union> neighbors x \<union> {x}"
	+ using inv unfolding inv_partition_def by auto
	+ (* conjunct 2 *)
	+ moreover have "(\<forall>p\<in>insert ({x} \<union> neighbors x) P. \<exists>s \<in> V. p = {s} \<union> neighbors s)"
	+ using inv and x_def unfolding inv_partition_def by auto
	+ (* conjunct 3 *)
	+ moreover have "card (insert ({x} \<union> neighbors x) P) = card (insert x S)"
	+ proof -
	+ from x_def and inv have "x \<notin> \<Union>P" unfolding inv_partition_def by auto
	+ then have "{x} \<union> neighbors x \<notin> P" by auto
	+ then have "card (insert ({x} \<union> neighbors x) P) = card P + 1" using inv unfolding inv_partition_def by auto
	+ moreover have "card (insert x S) = card S + 1" using Sx and finite_S by auto
	+ ultimately show ?thesis using inv unfolding inv_partition_def by auto
	+ qed
	+ (* conjunct 4 *)
	+ moreover have "finite (insert ({x} \<union> neighbors x) P)"
	+ using inv unfolding inv_partition_def by auto
	+ (* conclusion *)
	+ ultimately show "inv_partition (insert x S) (X \<union> neighbors x \<union> {x}) (insert ({x} \<union> neighbors x) P)"
	+ unfolding inv_partition_def by auto
	+qed
	+
	+lemma card_Union_le_sum_card:
	+ fixes U :: "'a set set"
	+ assumes "\<forall>u \<in> U. finite u"
	+ shows "card (\<Union>U) \<le> sum card U"
	+proof (cases "finite U")
	+ case False
	+ then show "card (\<Union>U) \<le> sum card U"
	+ using card_eq_0_iff finite_UnionD by auto
	+next
	+ case True
	+ then show "card (\<Union>U) \<le> sum card U"
	+ proof (induct U rule: finite_induct)
	+ case empty
	+ then show ?case by auto
	+ next
	+ case (insert x F)
	+ then have "card(\<Union>(insert x F)) \<le> card(x) + card (\<Union>F)" using card_Un_le by auto
	+ also have "... \<le> card(x) + sum card F" using insert.hyps by auto
	+ also have "... = sum card (insert x F)" using sum.insert_if and insert.hyps by auto
	+ finally show ?case .
	+ qed
	+qed
	+
	+(* this lemma could be more generally about U :: "nat set", but this makes its application more difficult later *)
	+lemma sum_card:
	+ fixes U :: "'a set set"
	+ and n :: nat
	+ assumes "\<forall>S \<in> U. card S \<le> n"
	+ shows "sum card U \<le> card U * n"
	+proof cases
	+ assume "infinite U \<or> U = {}"
	+ then have "sum card U = 0" using sum.infinite by auto
	+ then show "sum card U \<le> card U * n" by auto
	+next
	+ assume "\<not>(infinite U \<or> U = {})"
	+ with assms have "finite U" and "U \<noteq> {}"and "\<forall>S \<in> U. card S \<le> n" by auto
	+ then show "sum card U \<le> card U * n"
	+ proof (induct U rule: finite_ne_induct)
	+ case (singleton x)
	+ then show ?case by auto
	+ next
	+ case (insert x F)
	+ assume "\<forall>S\<in>insert x F. card S \<le> n"
	+ then have 1:"card x \<le> n" and 2:"sum card F \<le> card F * n" using insert.hyps by auto
	+ then have "sum card (insert x F) = card x + sum card F" using sum.insert_if and insert.hyps by auto
	+ also have "... \<le> n + card F * n" using 1 and 2 by auto
	+ also have "... = card (insert x F) * n" using card_insert_if and insert.hyps by auto
	+ finally show ?case .
	+ qed
	+qed
	+
	+(* among the vertices deleted in each iteration, at most \<Delta> can belong to an independent set of
	+ vertices: the chosen vertex or (some of) its neighbors *)
	+lemma x_or_neighbors:
	+ fixes P :: "'a set set"
	+ and S :: "'a set"
	+ assumes inv: "\<forall>p\<in>P. \<exists>s \<in> V. p = {s} \<union> neighbors s"
	+ and ivS: "independent_vertices E S"
	+ shows "\<forall>p \<in> P. card (S \<inter> p) \<le> \<Delta>"
	+proof
	+ fix p
	+ assume "p \<in> P"
	+ then obtain s where 1: "s \<in> V \<and> p = {s} \<union> neighbors s" using inv by blast
	+ then show "card (S \<inter> p) \<le> \<Delta>"
	+ proof cases
	+ assume "s \<in> S"
	+ then have "S \<inter> neighbors s = {}" using ivS unfolding independent_vertices_def by auto
	+ then have "S \<inter> p \<subseteq> {s}" using 1 by auto
	+ then have 2: "card (S \<inter> p) \<le> 1" using subset_singletonD by fastforce
	+ consider (a) "E = {}" \| (b) "0 < \<Delta>" using \<Delta>_pos by auto
	+ then show "card (S \<inter> p) \<le> \<Delta>"
	+ proof cases
	+ case a
	+ then have "S = {}" using ivS unfolding independent_vertices_def by auto
	+ then show ?thesis by auto
	+ next
	+ case b
	+ then show ?thesis using 2 by auto
	+ qed
	+ next
	+ assume "s \<notin> S"
	+ with 1 have "S \<inter> p \<subseteq> neighbors s" by auto
	+ then have "card (S \<inter> p) \<le> degree_vertex s" using card_mono and finite_neighbors by auto
	+ then show "card (S \<inter> p) \<le> \<Delta>" using 1 and \<Delta>_max_degree [of s] by auto
	+ qed
	+qed
	+
	+(* the premise combines the invariant and the negated post-condition *)
	+lemma inv_partition_approx: "inv_partition S V P \<Longrightarrow> approximation_miv \<Delta> S"
	+proof -
	+ assume H1: "inv_partition S V P"
	+ then have "independent_vertices E S" unfolding inv_partition_def inv_iv_def by auto
	+ moreover have "independent_vertices E S' \<Longrightarrow> card S' \<le> card S * \<Delta>" for S'
	+ proof -
	+ let ?I = "{S' \<inter> p \| p. p \<in> P}"
	+ (* split the optimal solution among the sets of P, which cover V so no element is
	+ lost. We obtain a cover of S' and show the required bound on its cardinality *)
	+ assume H2: "independent_vertices E S'"
	+ then have "S' \<subseteq> V" unfolding independent_vertices_def using vertices.simps by blast
	+ with H1 have "S' = S' \<inter> \<Union>P" unfolding inv_partition_def by auto
	+ then have "S' = (\<Union>p \<in> P. S' \<inter> p)" using Int_Union by auto
	+ then have "S' = \<Union>?I" by blast
	+ moreover have "finite S'" using H2 and independent_vertices_finite by auto
	+ then have "p \<in> P \<Longrightarrow> finite (S' \<inter> p)" for p by auto
	+ ultimately have "card S' \<le> sum card ?I" using card_Union_le_sum_card [of ?I] by auto
	+ also have "... \<le> card ?I * \<Delta>"
	+ using x_or_neighbors [of P S']
	+ and sum_card [of ?I \<Delta>]
	+ and H1 and H2 unfolding inv_partition_def by auto
	+ also have "... \<le> card P * \<Delta>"
	+ proof -
	+ have "finite P" using H1 unfolding inv_partition_def by auto
	+ then have "card ?I \<le> card P"
	+ using Setcompr_eq_image [of "\<lambda>p. S' \<inter> p" P]
	+ and card_image_le unfolding inv_partition_def by auto
	+ then show ?thesis by auto
	+ qed
	+ also have "... = card S * \<Delta>" using H1 unfolding inv_partition_def by auto
	+ ultimately show "card S' \<le> card S * \<Delta>" by auto
	+ qed
	+ ultimately show "approximation_miv \<Delta> S" unfolding approximation_miv_def by auto
	+qed
	+
	+theorem wei_approx_\<Delta>:
	+"VARS (S :: 'a set) (X :: 'a set) (x :: 'a)
	+ { True }
	+ S := {};
	+ X := {};
	+ WHILE X \<noteq> V
	+ INV { \<exists>P. inv_partition S X P }
	+ DO x := (SOME x. x \<in> V - X);
	+ S := insert x S;
	+ X := X \<union> neighbors x \<union> {x}
	+ OD
	+ { approximation_miv \<Delta> S }"
	+proof (vcg, goal_cases)
	+ case (1 S X x) (* invariant initially true *)
	+ (* the invariant is initially true with the ghost variable P := {} *)
	+ have "inv_partition {} {} {}" unfolding inv_partition_def inv_iv_def independent_vertices_def by auto
	+ then show ?case by auto
	+next
	+ case (2 S X x) (* invariant preserved by loop *)
	+ (* definedness of assignment *)
	+ let ?x = "(SOME x. x \<in> V - X)"
	+ from 2 obtain P where I: "inv_partition S X P" by auto
	+ then have "V - X \<noteq> {}" using 2 unfolding inv_partition_def by auto
	+ then have "?x \<in> V - X" using some_in_eq by metis
	+ (* show that the invariant is true with the ghost variable P := insert ({?x} \<union> neighbors ?x) P *)
	+ with I have "inv_partition (insert ?x S) (X \<union> neighbors ?x \<union> {?x}) (insert ({?x} \<union> neighbors ?x) P)"
	+ using inv_partition_preserv by blast
	+ then show ?case by auto
	+next
	+ case (3 S X x) (* invariant implies post-condition *)
	+ then show ?case using inv_partition_approx unfolding inv_approx_def by auto
	+qed
	+
	+subsection "Wei's algorithm with dynamically computed approximation ratio"
	+
	+text \<open>In this subsection, we augment the algorithm with a variable used to compute the effective approximation ratio of the solution. In addition, the vertex of smallest degree is picked. With this heuristic, the algorithm achieves an approximation ratio of \<open>(\<Delta>+2)/3\<close>, but this is not proved here.\<close>
	+
	+definition vertex_heuristic :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" where
	+"vertex_heuristic X v = (\<forall>u \<in> V - X. card (neighbors v - X) \<le> card (neighbors u - X))"
	+
	+(* this lemma is needed to show that there exist a vertex to be picked by the heuristic *)
	+lemma ex_min_finite_set:
	+ fixes S :: "'a set"
	+ and f :: "'a \<Rightarrow> nat"
	+ shows "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<exists>x. x \<in> S \<and> (\<forall>y \<in> S. f x \<le> f y)"
	+ (is "?P1 \<Longrightarrow> ?P2 \<Longrightarrow> \<exists>x. ?minf S x")
	+proof (induct S rule: finite_ne_induct)
	+ case (singleton x)
	+ have "?minf {x} x" by auto
	+ then show ?case by auto
	+next
	+ case (insert x F)
	+ from insert(4) obtain y where Py: "?minf F y" by auto
	+ show "\<exists>z. ?minf (insert x F) z"
	+ proof cases
	+ assume "f x < f y"
	+ then have "?minf (insert x F) x" using Py by auto
	+ then show ?case by auto
	+ next
	+ assume "\<not>f x < f y"
	+ then have "?minf (insert x F) y" using Py by auto
	+ then show ?case by auto
	+ qed
	+qed
	+
	+lemma inv_approx_preserv2:
	+ fixes S :: "'a set"
	+ and X :: "'a set"
	+ and s :: nat
	+ and x :: "'a"
	+ assumes inv: "inv_approx S X s"
	+ and x_def: "x \<in> V - X"
	+ shows "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (max (card (neighbors x \<union> {x} - X)) s)"
	+proof -
	+ have finite_S: "finite S" using inv and independent_vertices_finite unfolding inv_approx_def inv_iv_def by auto
	+ have Sx: "x \<notin> S" using inv and x_def unfolding inv_approx_def inv_iv_def by blast
	+ (* main invariant is preserved *)
	+ from inv have "inv_iv S X" unfolding inv_approx_def by auto
	+ with x_def have "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
	+ proof (intro inv_preserv, auto) qed
	+ (* the approximation ratio is preserved *)
	+ moreover have "card (X \<union> neighbors x \<union> {x}) \<le> card (insert x S) * max (card (neighbors x \<union> {x} - X)) s"
	+ proof -
	+ let ?N = "neighbors x \<union> {x} - X"
	+ have "card (X \<union> ?N) \<le> card X + card ?N" using card_Un_le [of X ?N] by auto
	+ also have "... \<le> card S * s + card ?N" using inv unfolding inv_approx_def by auto
	+ also have "... \<le> card S * max (card ?N) s + card ?N" by auto
	+ also have "... \<le> card S * max (card ?N) s + max (card ?N) s" by auto
	+ also have "... = card (insert x S) * max (card ?N) s" using Sx and finite_S by auto
	+ finally show ?thesis by auto
	+ qed
	+ (* conclusion *)
	+ ultimately show "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (max (card (neighbors x \<union> {x} - X)) s)"
	+ unfolding inv_approx_def by auto
	+qed
	+
	+theorem wei_approx_min_degree_heuristic:
	+"VARS (S :: 'a set) (X :: 'a set) (x :: 'a) (r :: nat)
	+ { True }
	+ S := {};
	+ X := {};
	+ r := 0;
	+ WHILE X \<noteq> V
	+ INV { inv_approx S X r }
	+ DO x := (SOME x. x \<in> V - X \<and> vertex_heuristic X x);
	+ S := insert x S;
	+ r := max (card (neighbors x \<union> {x} - X)) r;
	+ X := X \<union> neighbors x \<union> {x}
	+ OD
	+ { approximation_miv r S }"
	+proof (vcg, goal_cases)
	+ case (1 S X x r) (* invariant initially true *)
	+ then show ?case unfolding inv_approx_def inv_iv_def independent_vertices_def by auto
	+next
	+ case (2 S X x r) (* invariant preserved by loop *)
	+ (* definedness of assignment *)
	+ let ?x = "(SOME x. x \<in> V - X \<and> vertex_heuristic X x)"
	+ have "V - X \<noteq> {}" using 2 unfolding inv_approx_def inv_iv_def by blast
	+ moreover have "finite (V - X)" using 2 and finite_V by auto
	+ ultimately have "\<exists>x. x \<in> V - X \<and> vertex_heuristic X x"
	+ using ex_min_finite_set [where ?f = "\<lambda>x. card (neighbors x - X)"]
	+ unfolding vertex_heuristic_def by auto
	+ then have x_def: "?x \<in> V - X \<and> vertex_heuristic X ?x"
	+ using someI_ex [where ?P = "\<lambda>x. x \<in> V - X \<and> vertex_heuristic X x"] by auto
	+ with 2 show ?case using inv_approx_preserv2 by auto
	+next
	+ case (3 S X x r)
	+ then show ?case using inv_approx unfolding inv_approx_def inv_iv_def by auto
	+qed
	+
	+end
	+end
	\ No newline at end of file
	diff --git a/thys/Approximation_Algorithms/Approx_VC_Hoare.thy b/thys/Approximation_Algorithms/Approx_VC_Hoare.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Approximation_Algorithms/Approx_VC_Hoare.thy
	@@ -0,0 +1,202 @@
	+section "Vertex Cover"
	+
	+theory Approx_VC_Hoare
	+imports "HOL-Hoare.Hoare_Logic"
	+begin
	+
	+text \<open>The algorithm is classical, the proof is based on and augments the one
	+by Berghammer and M\"uller-Olm \cite{BerghammerM03}.\<close>
	+
	+subsection "Graph"
	+
	+text \<open>A graph is simply a set of edges, where an edge is a 2-element set.\<close>
	+
	+definition vertex_cover :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
	+"vertex_cover E C = (\<forall>e \<in> E. e \<inter> C \<noteq> {})"
	+
	+abbreviation matching :: "'a set set \<Rightarrow> bool" where
	+"matching M \<equiv> pairwise disjnt M"
	+
	+lemma card_matching_vertex_cover:
	+ "\<lbrakk> finite C; matching M; M \<subseteq> E; vertex_cover E C \<rbrakk> \<Longrightarrow> card M \<le> card C"
	+apply(erule card_le_if_inj_on_rel[where r = "\<lambda>e v. v \<in> e"])
	+ apply (meson disjnt_def disjnt_iff vertex_cover_def subsetCE)
	+by (meson disjnt_iff pairwise_def)
	+
	+
	+subsection "The Approximation Algorithm"
	+
	+text \<open>Formulated using a simple(!) predefined Hoare-logic.
	+This leads to a streamlined proof based on standard invariant reasoning.
	+
	+The nondeterministic selection of an element from a set \<open>F\<close> is simulated by @{term "SOME x. x \<in> F"}.
	+The \<open>SOME\<close> operator is built into HOL: @{term "SOME x. P x"} denotes some \<open>x\<close> that satisfies \<open>P\<close>
	+if such an \<open>x\<close> exists; otherwise it denotes an arbitrary element. Note that there is no
	+actual nondeterminism involved: @{term "SOME x. P x"} is some fixed element
	+but in general we don't know which one. Proofs about \<open>SOME\<close> are notoriously tedious.
	+Typically it involves showing first that @{prop "\<exists>x. P x"}. Then @{thm someI_ex} implies
	+@{prop"P (SOME x. P x)"}. There are a number of (more) useful related theorems:
	+just click on @{thm someI_ex} to be taken there.\<close>
	+
	+text \<open>Convenient notation for choosing an arbitrary element from a set:\<close>
	+abbreviation "some A \<equiv> SOME x. x \<in> A"
	+
	+locale Edges =
	+ fixes E :: "'a set set"
	+ assumes finE: "finite E"
	+ assumes edges2: "e \<in> E \<Longrightarrow> card e = 2"
	+begin
	+
	+text \<open>The invariant:\<close>
	+
	+definition "inv_matching C F M =
	+ (matching M \<and> M \<subseteq> E \<and> card C \<le> 2 * card M \<and> (\<forall>e \<in> M. \<forall>f \<in> F. e \<inter> f = {}))"
	+
	+definition invar :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
	+"invar C F = (F \<subseteq> E \<and> vertex_cover (E-F) C \<and> finite C \<and> (\<exists>M. inv_matching C F M))"
	+
	+text \<open>Preservation of the invariant by the loop body:\<close>
	+
	+lemma invar_step:
	+ assumes "F \<noteq> {}" "invar C F"
	+ shows "invar (C \<union> some F) (F - {e' \<in> F. some F \<inter> e' \<noteq> {}})"
	+proof -
	+ from assms(2) obtain M where "F \<subseteq> E" and vc: "vertex_cover (E-F) C" and fC: "finite C"
	+ and m: "matching M" "M \<subseteq> E" and card: "card C \<le> 2 * card M"
	+ and disj: "\<forall>e \<in> M. \<forall>f \<in> F. e \<inter> f = {}"
	+ by (auto simp: invar_def inv_matching_def)
	+ let ?e = "SOME e. e \<in> F"
	+ have "?e \<in> F" using \<open>F \<noteq> {}\<close> by (simp add: some_in_eq)
	+ hence fe': "finite ?e" using \<open>F \<subseteq> E\<close> edges2 by(intro card_ge_0_finite) auto
	+ have "?e \<notin> M" using edges2 \<open>?e \<in> F\<close> disj \<open>F \<subseteq> E\<close> by fastforce
	+ have card': "card (C \<union> ?e) \<le> 2 * card (insert ?e M)"
	+ using \<open>?e \<in> F\<close> \<open>?e \<notin> M\<close> card_Un_le[of C ?e] \<open>F \<subseteq> E\<close> edges2 card finite_subset[OF m(2) finE]
	+ by fastforce
	+ let ?M = "M \<union> {?e}"
	+ have vc': "vertex_cover (E - (F - {e' \<in> F. ?e \<inter> e' \<noteq> {}})) (C \<union> ?e)"
	+ using vc by(auto simp: vertex_cover_def)
	+ have m': "inv_matching (C \<union> ?e) (F - {e' \<in> F. ?e \<inter> e' \<noteq> {}}) ?M"
	+ using m card' \<open>F \<subseteq> E\<close> \<open>?e \<in> F\<close> disj
	+ by(auto simp: inv_matching_def Int_commute disjnt_def pairwise_insert)
	+ show ?thesis using \<open>F \<subseteq> E\<close> vc' fC fe' m' by(auto simp add: invar_def Let_def)
	+qed
	+
	+
	+lemma approx_vertex_cover:
	+"VARS C F
	+ {True}
	+ C := {};
	+ F := E;
	+ WHILE F \<noteq> {}
	+ INV {invar C F}
	+ DO C := C \<union> some F;
	+ F := F - {e' \<in> F. some F \<inter> e' \<noteq> {}}
	+ OD
	+ {vertex_cover E C \<and> (\<forall>C'. finite C' \<and> vertex_cover E C' \<longrightarrow> card C \<le> 2 * card C')}"
	+proof (vcg, goal_cases)
	+ case (1 C F)
	+ have "inv_matching {} E {}" by (auto simp add: inv_matching_def)
	+ with 1 show ?case by (auto simp add: invar_def vertex_cover_def)
	+next
	+ case (2 C F)
	+ thus ?case using invar_step[of F C] by(auto simp: Let_def)
	+next
	+ case (3 C F)
	+ then obtain M :: "'a set set" where
	+ post: "vertex_cover E C" "matching M" "M \<subseteq> E" "card C \<le> 2 * card M"
	+ by(auto simp: invar_def inv_matching_def)
	+
	+ have opt: "card C \<le> 2 * card C'" if C': "finite C'" "vertex_cover E C'" for C'
	+ proof -
	+ note post(4)
	+ also have "2 * card M \<le> 2 * card C'"
	+ using card_matching_vertex_cover[OF C'(1) post(2,3) C'(2)] by simp
	+ finally show "card C \<le> 2 * card C'" .
	+ qed
	+
	+ show ?case using post(1) opt by auto
	+qed
	+
	+end (* locale Graph *)
	+
	+subsection "Version for Hypergraphs"
	+
	+text \<open>Almost the same. We assume that the degree of every edge is bounded.\<close>
	+
	+locale Bounded_Hypergraph =
	+ fixes E :: "'a set set"
	+ fixes k :: nat
	+ assumes finE: "finite E"
	+ assumes edge_bnd: "e \<in> E \<Longrightarrow> finite e \<and> card e \<le> k"
	+ assumes E1: "{} \<notin> E"
	+begin
	+
	+definition "inv_matching C F M =
	+ (matching M \<and> M \<subseteq> E \<and> card C \<le> k * card M \<and> (\<forall>e \<in> M. \<forall>f \<in> F. e \<inter> f = {}))"
	+
	+definition invar :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
	+"invar C F = (F \<subseteq> E \<and> vertex_cover (E-F) C \<and> finite C \<and> (\<exists>M. inv_matching C F M))"
	+
	+lemma invar_step:
	+ assumes "F \<noteq> {}" "invar C F"
	+ shows "invar (C \<union> some F) (F - {e' \<in> F. some F \<inter> e' \<noteq> {}})"
	+proof -
	+ from assms(2) obtain M where "F \<subseteq> E" and vc: "vertex_cover (E-F) C" and fC: "finite C"
	+ and m: "matching M" "M \<subseteq> E" and card: "card C \<le> k * card M"
	+ and disj: "\<forall>e \<in> M. \<forall>f \<in> F. e \<inter> f = {}"
	+ by (auto simp: invar_def inv_matching_def)
	+ let ?e = "SOME e. e \<in> F"
	+ have "?e \<in> F" using \<open>F \<noteq> {}\<close> by (simp add: some_in_eq)
	+ hence fe': "finite ?e" using \<open>F \<subseteq> E\<close> assms(2) edge_bnd by blast
	+ have "?e \<notin> M" using E1 \<open>?e \<in> F\<close> disj \<open>F \<subseteq> E\<close> by fastforce
	+ have card': "card (C \<union> ?e) \<le> k * card (insert ?e M)"
	+ using \<open>?e \<in> F\<close> \<open>?e \<notin> M\<close> card_Un_le[of C ?e] \<open>F \<subseteq> E\<close> edge_bnd card finite_subset[OF m(2) finE]
	+ by fastforce
	+ let ?M = "M \<union> {?e}"
	+ have vc': "vertex_cover (E - (F - {e' \<in> F. ?e \<inter> e' \<noteq> {}})) (C \<union> ?e)"
	+ using vc by(auto simp: vertex_cover_def)
	+ have m': "inv_matching (C \<union> ?e) (F - {e' \<in> F. ?e \<inter> e' \<noteq> {}}) ?M"
	+ using m card' \<open>F \<subseteq> E\<close> \<open>?e \<in> F\<close> disj
	+ by(auto simp: inv_matching_def Int_commute disjnt_def pairwise_insert)
	+ show ?thesis using \<open>F \<subseteq> E\<close> vc' fC fe' m' by(auto simp add: invar_def Let_def)
	+qed
	+
	+
	+lemma approx_vertex_cover_bnd:
	+"VARS C F
	+ {True}
	+ C := {};
	+ F := E;
	+ WHILE F \<noteq> {}
	+ INV {invar C F}
	+ DO C := C \<union> some F;
	+ F := F - {e' \<in> F. some F \<inter> e' \<noteq> {}}
	+ OD
	+ {vertex_cover E C \<and> (\<forall>C'. finite C' \<and> vertex_cover E C' \<longrightarrow> card C \<le> k * card C')}"
	+proof (vcg, goal_cases)
	+ case (1 C F)
	+ have "inv_matching {} E {}" by (auto simp add: inv_matching_def)
	+ with 1 show ?case by (auto simp add: invar_def vertex_cover_def)
	+next
	+ case (2 C F)
	+ thus ?case using invar_step[of F C] by(auto simp: Let_def)
	+next
	+ case (3 C F)
	+ then obtain M :: "'a set set" where
	+ post: "vertex_cover E C" "matching M" "M \<subseteq> E" "card C \<le> k * card M"
	+ by(auto simp: invar_def inv_matching_def)
	+
	+ have opt: "card C \<le> k * card C'" if C': "finite C'" "vertex_cover E C'" for C'
	+ proof -
	+ note post(4)
	+ also have "k * card M \<le> k * card C'"
	+ using card_matching_vertex_cover[OF C'(1) post(2,3) C'(2)] by simp
	+ finally show "card C \<le> k * card C'" .
	+ qed
	+
	+ show ?case using post(1) opt by auto
	+qed
	+
	+end (* locale Bounded_Hypergraph *)
	+
	+end
	diff --git a/thys/Approximation_Algorithms/ROOT b/thys/Approximation_Algorithms/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Approximation_Algorithms/ROOT
	@@ -0,0 +1,15 @@
	+chapter AFP
	+
	+session Approximation_Algorithms (AFP) = HOL +
	+ options [timeout = 600]
	+ sessions
	+ "HOL-Library"
	+ "HOL-Hoare"
	+ theories
	+ Approx_VC_Hoare
	+ Approx_MIS_Hoare
	+ Approx_LB_Hoare
	+ Approx_BP_Hoare
	+ document_files
	+ "root.bib"
	+ "root.tex"
	diff --git a/thys/Approximation_Algorithms/document/root.bib b/thys/Approximation_Algorithms/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Approximation_Algorithms/document/root.bib
	@@ -0,0 +1,41 @@
	+@string{Springer="Springer"}
	+@string{LNCS="LNCS"}
	+
	+@inproceedings{BerghammerM03,
	+ author = {Rudolf Berghammer and Markus M{\"{u}}ller{-}Olm},
	+ title = {Formal Development and Verification of Approximation Algorithms Using
	+ Auxiliary Variables},
	+ booktitle = {Logic Based Program Synthesis and Transformation, {LOPSTR} 2003},
	+ pages = {59--74},
	+ year = {2003},
	+ crossref = {DBLP:conf/lopstr/2003},
	+ doi = {10.1007/978-3-540-25938-1\_6},
	+}
	+
	+@proceedings{DBLP:conf/lopstr/2003,
	+ editor = {Maurice Bruynooghe},
	+ title = {Logic Based Program Synthesis and Transformation, {LOPSTR} 2003},
	+ series = {LNCS},
	+ volume = {3018},
	+ publisher = {Springer},
	+ year = {2004},
	+}
	+
	+@article{BerghammerR03,
	+ author = {Rudolf Berghammer and Florian Reuter},
	+ title = {A linear approximation algorithm for bin packing with absolute approximation
	+ factor 3/2},
	+ journal = {Sci. Comput. Program.},
	+ volume = {48},
	+ number = {1},
	+ pages = {67--80},
	+ year = {2003},
	+ doi = {10.1016/S0167-6423(03)00011-X},
	+}
	+
	+@book{KleinbergT06,
	+ author = {Jon M. Kleinberg and {\'{E}}va Tardos},
	+ title = {Algorithm Design},
	+ publisher = {Addison-Wesley},
	+ year = {2006},
	+}
	diff --git a/thys/Approximation_Algorithms/document/root.tex b/thys/Approximation_Algorithms/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Approximation_Algorithms/document/root.tex
	@@ -0,0 +1,34 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage{isabelle,isabellesym}
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+
	+\begin{document}
	+
	+\title{Verified Approximation Algorithms}
	+\author{Robin E{\ss}mann, Tobias Nipkow and Simon Robillard}
	+\maketitle
	+
	+\begin{abstract}
	+We present the first formal verifications of approximation algorithms
	+for NP-complete optimization problems:
	+vertex cover, independent set, load balancing, and bin packing.
	+The proofs correct incompletnesses in existing proofs
	+and improve the approximation ratio in one case.
	+\end{abstract}
	+
	+\tableofcontents
	+
	+% include generated text of all theories
	+\input{session}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	diff --git a/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy b/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy
	new file mode 100755
	--- /dev/null
	+++ b/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy
	@@ -0,0 +1,955 @@
	+(*
	+ File: Arith_Prog_Rel_Primes.thy
	+ Author: Jose Manuel Rodriguez Caballero, University of Tartu
	+*)
	+section \<open>Problem ARITHMETIC PROGRESSIONS (Putnam exam problems 2002)\<close>
	+theory Arith_Prog_Rel_Primes
	+ imports
	+ Complex_Main
	+ "HOL-Number_Theory.Number_Theory"
	+begin
	+
	+text \<open>
	+ Statement of the problem (from ~\cite{putnam}): For which integers $n>1$ does the set of positive
	+ integers less than and relatively prime to $n$ constitute an arithmetic progression?
	+
	+ The solution of the above problem is theorem @{text arith_prog_rel_primes_solution}.
	+
	+ First, we will require some auxiliary material before we get started with the actual
	+ solution.
	+\<close>
	+
	+subsection \<open>Auxiliary results\<close>
	+
	+lemma even_and_odd_parts:
	+ fixes n::nat
	+ assumes \<open>n \<noteq> 0\<close>
	+ shows \<open>\<exists> k q::nat. n = (2::nat)^k*q \<and> odd q\<close>
	+proof-
	+ have \<open>prime (2::nat)\<close>
	+ by simp
	+ thus ?thesis
	+ using prime_power_canonical[where p = "2" and m = "n"]
	+ assms semiring_normalization_rules(7) by auto
	+qed
	+
	+lemma only_one_odd_div_power2:
	+ fixes n::nat
	+ assumes \<open>n \<noteq> 0\<close> and \<open>\<And> x. x dvd n \<Longrightarrow> odd x \<Longrightarrow> x = 1\<close>
	+ shows \<open>\<exists> k. n = (2::nat)^k\<close>
	+ by (metis even_and_odd_parts assms(1) assms(2) dvd_triv_left semiring_normalization_rules(11)
	+ semiring_normalization_rules(7))
	+
	+lemma coprime_power2:
	+ fixes n::nat
	+ assumes \<open>n \<noteq> 0\<close> and \<open>\<And> x. x < n \<Longrightarrow> (coprime x n \<longleftrightarrow> odd x)\<close>
	+ shows \<open>\<exists> k. n = (2::nat)^k\<close>
	+proof-
	+ have \<open>x dvd n \<Longrightarrow> odd x \<Longrightarrow> x = 1\<close>
	+ for x
	+ by (metis neq0_conv One_nat_def Suc_1 Suc_lessI assms(1) assms(2) coprime_left_2_iff_odd
	+ dvd_refl linorder_neqE_nat nat_dvd_1_iff_1 nat_dvd_not_less not_coprimeI)
	+ thus ?thesis
	+ using assms(1) only_one_odd_div_power2
	+ by auto
	+qed
	+
	+subsection \<open>Main result\<close>
	+
	+text \<open>
	+ The solution to the problem ARITHMETIC PROGRESSIONS (Putnam exam problems 2002)
	+\<close>
	+
	+theorem arith_prog_rel_primes_solution:
	+ fixes n :: nat
	+ assumes \<open>n > 1\<close>
	+ shows \<open>(prime n \<or> (\<exists> k. n = 2^k) \<or> n = 6) \<longleftrightarrow>
	+(\<exists> a b m. m \<noteq> 0 \<and> {x \| x. x < n \<and> coprime x n} = {a+j*b\| j::nat. j < m})\<close>
	+proof-
	+ have \<open> (prime n \<or> (\<exists> k. n = 2^k) \<or> n = 6) \<longleftrightarrow>
	+ (\<exists> b m. m \<noteq> 0 \<and> {x \| x :: nat. x < n \<and> coprime x n} = {1+j*b\| j::nat. j < m})\<close>
	+ proof
	+ show "\<exists>b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}"
	+ if "prime n \<or> (\<exists>k. n = 2 ^ k) \<or> n = 6"
	+ proof-
	+ have "\<exists>b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}"
	+ if "prime n"
	+ proof-
	+ have \<open>\<exists>m. m \<noteq> 0 \<and> {x \| x :: nat. x < n \<and> coprime x n} = {1+j\| j::nat. j < m}\<close>
	+ proof-
	+ have \<open>{x \| x :: nat. x < n \<and> coprime x n} = {x \| x :: nat. x \<noteq> 0 \<and> x < n}\<close>
	+ proof
	+ show "{x \|x. x < n \<and> coprime x n} \<subseteq> {x \|x. x \<noteq> 0 \<and> x < n}"
	+ by (smt Collect_mono not_le ord_0_nat ord_eq_0 order_refl prime_gt_1_nat that zero_neq_one)
	+ show "{x \|x. x \<noteq> 0 \<and> x < n} \<subseteq> {x \|x. x < n \<and> coprime x n}"
	+ using coprime_commute prime_nat_iff'' that
	+ by fastforce
	+ qed
	+ obtain m where \<open>m+1 = n\<close>
	+ using \<open>1 < n\<close> less_imp_add_positive linordered_field_class.sign_simps(2) by blast
	+ have \<open>{1+j\| j::nat. j < (m::nat)} = {x \| x :: nat. x \<noteq> 0 \<and> x < m+1}\<close>
	+ by (metis Suc_eq_plus1 \<open>m + 1 = n\<close> gr0_implies_Suc le_simps(3) less_nat_zero_code linorder_not_less nat.simps(3) nat_neq_iff plus_1_eq_Suc )
	+ hence \<open>{x \| x :: nat. x < n \<and> coprime x n} = {1+j\| j::nat. j < (m::nat)}\<close>
	+ using \<open>{x \| x :: nat. x < n \<and> coprime x n} = {x \| x :: nat. x \<noteq> 0 \<and> x < n}\<close> \<open>m+1 = n\<close>
	+ by auto
	+ from \<open>n > 1\<close> have \<open>m \<noteq> 0\<close>
	+ using \<open>m + 1 = n\<close> by linarith
	+ have \<open>{x \| x :: nat. x < n \<and> coprime x n} = {1+j\| j::nat. j < m}\<close>
	+ using Suc_eq_plus1 \<open>1 < n\<close> \<open>{x \|x. x < n \<and> coprime x n} = {1 + j \|j. j < m}\<close>
	+ by auto
	+ hence \<open>(\<exists> m. m \<noteq> 0 \<and> {x \| x :: nat. x < n \<and> coprime x n} = {1+j\| j::nat. j < m})\<close>
	+ using \<open>m \<noteq> 0\<close>
	+ by blast
	+ thus ?thesis by blast
	+ qed
	+ hence \<open>\<exists>m. m \<noteq> 0 \<and> {x \| x :: nat. x < n \<and> coprime x n} = {1+j*1\| j::nat. j < m}\<close>
	+ by auto
	+ thus ?thesis
	+ by blast
	+ qed
	+ moreover have "\<exists>b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}"
	+ if "\<exists>k. n = 2 ^ k"
	+ proof-
	+ obtain k where \<open>n = 2 ^ k\<close>
	+ using \<open>\<exists>k. n = 2 ^ k\<close> by auto
	+ have \<open>k \<noteq> 0\<close>
	+ by (metis \<open>1 < n\<close> \<open>n = 2 ^ k\<close> nat_less_le power.simps(1))
	+ obtain t where \<open>Suc t = k\<close>
	+ by (metis \<open>k \<noteq> 0\<close> fib.cases)
	+ have \<open>n = 2^(Suc t)\<close>
	+ by (simp add: \<open>Suc t = k\<close> \<open>n = 2 ^ k\<close>)
	+ have \<open>{x \| x :: nat. x < n \<and> coprime x n} = {1+j*2\| j::nat. j < 2^t}\<close>
	+ proof
	+ show "{x \|x. x < n \<and> coprime x n} \<subseteq> {1 + j * 2 \|j. j < 2^t}"
	+ proof
	+ fix x
	+ assume \<open>x \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ hence \<open>x < n\<close>
	+ by blast
	+ have \<open>coprime x n\<close>
	+ using \<open>x \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ by blast
	+ hence \<open>coprime x (2^(Suc k))\<close>
	+ by (simp add: \<open>k \<noteq> 0\<close> \<open>n = 2 ^ k\<close>)
	+ have \<open>odd x\<close>
	+ using \<open>coprime x n\<close> \<open>k \<noteq> 0\<close> \<open>n = 2 ^ k\<close>
	+ by auto
	+ then obtain j where \<open>x = 1+j*2\<close>
	+ by (metis add.commute add.left_commute left_add_twice mult_2_right oddE)
	+ have \<open>x < 2^k\<close>
	+ using \<open>n = 2 ^ k\<close> \<open>x < n\<close> \<open>x = 1+j*2\<close>
	+ by linarith
	+ hence \<open>1+j*2 < 2^k\<close>
	+ using \<open>x = 1+j*2\<close>
	+ by blast
	+ hence \<open>j < 2^t\<close>
	+ using \<open>Suc t = k\<close> by auto
	+ thus \<open>x \<in> {1 + j * 2 \|j. j < 2^t}\<close>
	+ using \<open>x = 1+j*2\<close>
	+ by blast
	+ qed
	+ show "{1 + j * 2 \|j. j < 2 ^ t} \<subseteq> {x \|x. x < n \<and> coprime x n}"
	+ proof
	+ fix x::nat
	+ assume \<open>x \<in> {1 + j * 2 \|j. j < 2 ^ t}\<close>
	+ then obtain j where \<open>x = 1 + j * 2\<close> and \<open>j < 2 ^ t\<close>
	+ by blast
	+ have \<open>x < 2*(2^t)\<close>
	+ using \<open>x = 1 + j * 2\<close> \<open>j < 2 ^ t\<close>
	+ by linarith
	+ hence \<open>x < n\<close>
	+ by (simp add: \<open>n = 2 ^ Suc t\<close>)
	+ moreover have \<open>coprime x n\<close>
	+ by (metis (no_types) \<open>\<And>thesis. (\<And>j. \<lbrakk>x = 1 + j * 2; j < 2 ^ t\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> \<open>n = 2 ^ k\<close> coprime_Suc_left_nat coprime_mult_right_iff coprime_power_right_iff plus_1_eq_Suc)
	+ ultimately show \<open>x \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ by blast
	+ qed
	+ qed
	+ have \<open>(2::nat)^(t::nat) \<noteq> 0\<close>
	+ by simp
	+ obtain m where \<open>m = (2::nat)^t\<close> by blast
	+ have \<open>m \<noteq> 0\<close>
	+ using \<open>m = 2 ^ t\<close>
	+ by auto
	+ have \<open>{x \| x :: nat. x < n \<and> coprime x n} = {1+j*2\| j::nat. j < m}\<close>
	+ using \<open>m = 2 ^ t\<close> \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * 2 \|j. j < 2 ^ t}\<close>
	+ by auto
	+ from \<open>m \<noteq> 0\<close> \<open>{x \| x :: nat. x < n \<and> coprime x n} = {1+j*2\| j::nat. j < m}\<close>
	+ show ?thesis by blast
	+ qed
	+ moreover have "\<exists>b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}"
	+ if "n = 6"
	+ proof-
	+ have \<open>{x \| x. x < 6 \<and> coprime x 6} = {1+j*4\| j::nat. j < 2}\<close>
	+ proof-
	+ have \<open>{x \| x::nat. x < 6 \<and> coprime x 6} = {1, 5}\<close>
	+ proof
	+ show "{u. \<exists>x. u = (x::nat) \<and> x < 6 \<and> coprime x 6} \<subseteq> {1, 5}"
	+ proof
	+ fix u::nat
	+ assume \<open>u \<in> {u. \<exists>x. u = x \<and> x < 6 \<and> coprime x 6}\<close>
	+ hence \<open>coprime u 6\<close>
	+ by blast
	+ have \<open>u < 6\<close>
	+ using \<open>u \<in> {u. \<exists>x. u = x \<and> x < 6 \<and> coprime x 6}\<close>
	+ by blast
	+ moreover have \<open>u \<noteq> 0\<close>
	+ using \<open>coprime u 6\<close> ord_eq_0
	+ by fastforce
	+ moreover have \<open>u \<noteq> 2\<close>
	+ using \<open>coprime u 6\<close>
	+ by auto
	+ moreover have \<open>u \<noteq> 3\<close>
	+ proof-
	+ have \<open>gcd (3::nat) 6 = 3\<close>
	+ by auto
	+ thus ?thesis
	+ by (metis (no_types) \<open>coprime u 6\<close> \<open>gcd 3 6 = 3\<close> coprime_iff_gcd_eq_1
	+ numeral_eq_one_iff semiring_norm(86))
	+ qed
	+ moreover have \<open>u \<noteq> 4\<close>
	+ proof-
	+ have \<open>gcd (4::nat) 6 = 2\<close>
	+ by (metis (no_types, lifting) add_numeral_left gcd_add1 gcd_add2 gcd_nat.idem
	+ numeral_Bit0 numeral_One one_plus_numeral semiring_norm(4) semiring_norm(5))
	+ thus ?thesis
	+ using \<open>coprime u 6\<close> coprime_iff_gcd_eq_1
	+ by auto
	+ qed
	+ ultimately have \<open>u = 1 \<or> u = 5\<close>
	+ by auto
	+ thus \<open>u \<in> {1, 5}\<close>
	+ by blast
	+ qed
	+ show "{1::nat, 5} \<subseteq> {x \|x. x < 6 \<and> coprime x 6}"
	+ proof-
	+ have \<open>(1::nat) \<in> {x \|x. x < 6 \<and> coprime x 6}\<close>
	+ by simp
	+ moreover have \<open>(5::nat) \<in> {x \|x. x < 6 \<and> coprime x 6}\<close>
	+ by (metis Suc_numeral coprime_Suc_right_nat less_add_one mem_Collect_eq
	+ numeral_plus_one semiring_norm(5) semiring_norm(8))
	+ ultimately show ?thesis
	+ by blast
	+ qed
	+ qed
	+ moreover have \<open>{1+j*4\| j::nat. j < 2} = {1, 5}\<close>
	+ by auto
	+ ultimately show ?thesis by auto
	+ qed
	+ moreover have \<open>(2::nat) \<noteq> 0\<close>
	+ by simp
	+ ultimately have \<open>\<exists> m. m \<noteq> 0 \<and> {x \| x :: nat. x < 6 \<and> coprime x 6} = {1+j*4\| j::nat. j < m}\<close>
	+ by blast
	+ thus ?thesis
	+ using that
	+ by auto
	+ qed
	+ ultimately show ?thesis
	+ using that
	+ by blast
	+ qed
	+ show "prime n \<or> (\<exists>k. n = 2 ^ k) \<or> n = 6"
	+ if "\<exists>b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}"
	+ proof-
	+ obtain b m where \<open>m \<noteq> 0\<close> and \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ using \<open>\<exists>b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by auto
	+ show ?thesis
	+ proof(cases \<open>n = 2\<close>)
	+ case True
	+ thus ?thesis
	+ by auto
	+ next
	+ case False
	+ have \<open>b \<le> 4\<close>
	+ proof(cases \<open>odd b\<close>)
	+ case True
	+ show ?thesis
	+ proof(rule classical)
	+ assume \<open>\<not>(b \<le> 4)\<close>
	+ hence \<open>b > 4\<close>
	+ using le_less_linear
	+ by blast
	+ obtain m where \<open>m \<noteq> 0\<close>
	+ and \<open>{x \| x :: nat. x < n \<and> coprime x n} = {1+j*b\| j::nat. j < m}\<close>
	+ using \<open>m \<noteq> 0\<close> \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ have \<open>b \<noteq> 0\<close>
	+ using \<open>4 < b\<close>
	+ by linarith
	+ have \<open>n = 2 + (m-1)*b\<close>
	+ proof-
	+ have \<open>n-1 \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>1 < n\<close> coprime_diff_one_left_nat
	+ by auto
	+ have \<open>n-1 \<in> {1+j*b\| j::nat. j < m}\<close>
	+ using \<open>n - 1 \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ then obtain i::nat where \<open>n-1 = 1+i*b\<close> and \<open>i < m\<close>
	+ by blast
	+ have \<open>i \<le> m-1\<close>
	+ using \<open>i < m\<close>
	+ by linarith
	+ have \<open>1 + (m-1)b \<in> {1+jb\| j::nat. j < m}\<close>
	+ using \<open>m \<noteq> 0\<close>
	+ by auto
	+ hence \<open>1 + (m-1)*b \<in> {x \| x::nat. x < n \<and> coprime x n}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ hence \<open>1 + (m-1)*b < n\<close>
	+ by blast
	+ hence \<open>1 + (m-1)*b \<le> n-1\<close>
	+ by linarith
	+ hence \<open>1 + (m-1)b \<le> 1+ib\<close>
	+ using \<open>n - 1 = 1 + i * b\<close>
	+ by linarith
	+ hence \<open>(m-1)b \<le> ib\<close>
	+ by linarith
	+ hence \<open>m-1 \<le> i\<close>
	+ using \<open>b \<noteq> 0\<close>
	+ by auto
	+ hence \<open>m-1 = i\<close>
	+ using \<open>i \<le> m - 1\<close> le_antisym
	+ by blast
	+ thus ?thesis
	+ using \<open>m \<noteq> 0\<close> \<open>n - 1 = 1 + i * b\<close>
	+ by auto
	+ qed
	+ have \<open>m \<ge> 2\<close>
	+ using \<open>n = 2 + (m - 1)*b\<close> \<open>n \<noteq> 2\<close>
	+ by auto
	+ hence \<open>1+b \<in> {1+j*b\| j. j < m}\<close>
	+ by fastforce
	+ hence \<open>1+b \<in> {x \| x::nat. x < n \<and> coprime x n}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ hence \<open>coprime (1+b) n\<close>
	+ by blast
	+ have \<open>(2::nat) dvd (1+b)\<close>
	+ using \<open>odd b\<close>
	+ by simp
	+ hence \<open>coprime (2::nat) n\<close>
	+ using \<open>coprime (1 + b) n\<close> coprime_common_divisor coprime_left_2_iff_odd odd_one
	+ by blast
	+ have \<open>(2::nat) < n\<close>
	+ using \<open>1 < n\<close> \<open>n \<noteq> 2\<close>
	+ by linarith
	+ have \<open>2 \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>2 < n\<close> \<open>coprime 2 n\<close>
	+ by blast
	+ hence \<open>2 \<in> {1+j*b\| j::nat. j < m}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ then obtain j::nat where \<open>2 = 1+j*b\<close>
	+ by blast
	+ have \<open>1 = j*b\<close>
	+ using \<open>2 = 1+j*b\<close>
	+ by linarith
	+ thus ?thesis
	+ by simp
	+ qed
	+ next
	+ case False
	+ hence \<open>even b\<close>
	+ by simp
	+ show ?thesis
	+ proof(rule classical)
	+ assume \<open>\<not>(b \<le> 4)\<close>
	+ hence \<open>b > 4\<close>
	+ using le_less_linear
	+ by blast
	+ obtain m where \<open> m \<noteq> 0\<close>
	+ and \<open>{x \| x::nat. x < n \<and> coprime x n} = {1+j*b\| j::nat. j < m}\<close>
	+ using \<open>m \<noteq> 0\<close> \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ have \<open>b \<noteq> 0\<close>
	+ using \<open>4 < b\<close>
	+ by linarith
	+ have \<open>n = 2 + (m-1)*b\<close>
	+ proof-
	+ have \<open>n-1 \<in> {x \| x::nat. x < n \<and> coprime x n}\<close>
	+ using \<open>1 < n\<close> coprime_diff_one_left_nat
	+ by auto
	+ have \<open>n-1 \<in> {1+j*b\| j::nat. j < m}\<close>
	+ using \<open>n - 1 \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ then obtain i::nat where \<open>n-1 = 1+i*b\<close> and \<open>i < m\<close>
	+ by blast
	+ have \<open>i \<le> m-1\<close>
	+ using \<open>i < m\<close>
	+ by linarith
	+ have \<open>1 + (m-1)b \<in> {1+jb\| j::nat. j < m}\<close>
	+ using \<open>m \<noteq> 0\<close>
	+ by auto
	+ hence \<open>1 + (m-1)*b \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ hence \<open>1 + (m-1)*b < n\<close>
	+ by blast
	+ hence \<open>1 + (m-1)*b \<le> n-1\<close>
	+ by linarith
	+ hence \<open>1 + (m-1)b \<le> 1+ib\<close>
	+ using \<open>n - 1 = 1 + i * b\<close>
	+ by linarith
	+ hence \<open>(m-1)b \<le> ib\<close>
	+ by linarith
	+ hence \<open>m-1 \<le> i\<close>
	+ using \<open>b \<noteq> 0\<close>
	+ by auto
	+ hence \<open>m-1 = i\<close>
	+ using \<open>i \<le> m - 1\<close> le_antisym
	+ by blast
	+ thus ?thesis
	+ using \<open>m \<noteq> 0\<close> \<open>n - 1 = 1 + i * b\<close>
	+ by auto
	+ qed
	+ obtain k :: nat where \<open>b = 2*k\<close>
	+ using \<open>even b\<close>
	+ by blast
	+ have \<open>n = 2(1 + (m-1)k)\<close>
	+ using \<open>n = 2 + (m-1)b\<close> \<open>b = 2k\<close>
	+ by simp
	+ show ?thesis
	+ proof (cases \<open>odd m\<close>)
	+ case True
	+ hence \<open>odd m\<close> by blast
	+ then obtain t::nat where \<open>m-1 = 2*t\<close>
	+ by (metis odd_two_times_div_two_nat)
	+ have \<open>n = 2(1 + bt)\<close>
	+ using \<open>m - 1 = 2 * t\<close> \<open>n = 2 + (m - 1) * b\<close>
	+ by auto
	+ have \<open>t < m\<close>
	+ using \<open>m - 1 = 2 * t\<close> \<open>m \<noteq> 0\<close>
	+ by linarith
	+ have \<open>1 + bt \<in> {1+jb\| j::nat. j < m}\<close>
	+ using \<open>t < m\<close>
	+ by auto
	+ hence \<open>1 + b*t \<in> {x \| x::nat. x < n \<and> coprime x n}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ hence \<open>coprime (1 + b*t) n\<close>
	+ by auto
	+ thus ?thesis
	+ by (metis (no_types, lifting) \<open>b = 2 * k\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close> \<open>n = 2 * (1 + b * t)\<close> \<open>n = 2 + (m - 1) * b\<close> \<open>n \<noteq> 2\<close> add_cancel_right_right coprime_mult_right_iff coprime_self mult_cancel_left mult_is_0 nat_dvd_1_iff_1)
	+ next
	+ case False
	+ thus ?thesis
	+ proof(cases \<open>odd k\<close>)
	+ case True
	+ hence \<open>odd k\<close>
	+ by blast
	+ have \<open>even (1 + (m - 1) * k)\<close>
	+ by (simp add: False True \<open>m \<noteq> 0\<close>)
	+ have \<open>coprime (2 + (m - 1) * k) (1 + (m - 1) * k)\<close>
	+ by simp
	+ have \<open>coprime (2 + (m - 1) * k) n\<close>
	+ using \<open>coprime (2 + (m - 1) * k) (1 + (m - 1) * k)\<close> \<open>even (1 + (m - 1) * k)\<close>
	+ \<open>n = 2 * (1 + (m - 1) * k)\<close> coprime_common_divisor coprime_mult_right_iff
	+ coprime_right_2_iff_odd odd_one
	+ by blast
	+ have \<open>2 + (m - 1) * k < n\<close>
	+ by (metis (no_types, lifting) \<open>even (1 + (m - 1) * k)\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close>
	+ add_gr_0 add_mono_thms_linordered_semiring(1) dvd_add_left_iff dvd_add_triv_left_iff dvd_imp_le le_add2 le_neq_implies_less less_numeral_extra(1) mult_2 odd_one)
	+ have \<open>2 + (m - 1) * k \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>2 + (m - 1) * k < n\<close> \<open>coprime (2 + (m - 1) * k) n\<close>
	+ by blast
	+ hence \<open>2 + (m - 1) * k \<in> {1 + j * b \|j. j < m}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ then obtain j::nat where \<open>2 + (m - 1) * k = 1 + j * b\<close> and \<open>j < m\<close>
	+ by blast
	+ have \<open>1 + (m - 1) * k = j * b\<close>
	+ using \<open>2 + (m - 1) * k = 1 + j * b\<close>
	+ by simp
	+ hence \<open>1 + (m - 1) * k = j * (2*k)\<close>
	+ using \<open>b = 2 * k\<close> by blast
	+ thus ?thesis
	+ by (metis \<open>b = 2 * k\<close> \<open>even b\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close> \<open>n = 2 + (m - 1) * b\<close> dvd_add_times_triv_right_iff dvd_antisym dvd_imp_le dvd_triv_right even_numeral mult_2 zero_less_numeral)
	+ next
	+ case False
	+ hence \<open>even k\<close> by auto
	+ have \<open>odd (1 + (m - 1) * k)\<close>
	+ by (simp add: \<open>even k\<close> )
	+ hence \<open>coprime (3 + (m - 1) * k) (1 + (m - 1) * k)\<close>
	+ by (smt add_numeral_left coprime_common_divisor coprime_right_2_iff_odd dvd_add_left_iff not_coprimeE numeral_Bit1 numeral_One numeral_plus_one one_add_one)
	+ hence \<open>coprime (3 + (m - 1) * k) n\<close>
	+ by (metis \<open>even k\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close> coprime_mult_right_iff coprime_right_2_iff_odd even_add even_mult_iff odd_numeral)
	+ have \<open>3 + (m - 1) * k < n\<close>
	+ by (smt Groups.add_ac(2) \<open>even k\<close> \<open>n = 2 * (1 + (m - 1) * k)\<close> \<open>n = 2 + (m - 1) * b\<close> \<open>n \<noteq> 2\<close> add_Suc_right add_cancel_right_right add_mono_thms_linordered_semiring(1) dvd_imp_le even_add even_mult_iff le_add2 le_neq_implies_less left_add_twice mult_2 neq0_conv numeral_Bit1 numeral_One odd_numeral one_add_one plus_1_eq_Suc)
	+ have \<open>3 + (m - 1) * k \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ using \<open>3 + (m - 1) * k < n\<close> \<open>coprime (3 + (m - 1) * k) n\<close>
	+ by blast
	+ hence \<open>3 + (m - 1) * k \<in> {1 + j * b \|j. j < m}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ then obtain j::nat where \<open>3 + (m - 1) * k = 1 + j * b\<close>
	+ by blast
	+ have \<open>2 + (m - 1) * k = j * b\<close>
	+ using \<open>3 + (m - 1) * k = 1 + j * b\<close>
	+ by simp
	+ hence \<open>2 + (m - 1) * k = j * 2*k\<close>
	+ by (simp add: \<open>b = 2 * k\<close>)
	+ thus ?thesis
	+ by (metis \<open>4 < b\<close> \<open>b = 2 * k\<close> \<open>even k\<close> dvd_add_times_triv_right_iff dvd_antisym
	+ dvd_triv_right mult_2 nat_neq_iff numeral_Bit0)
	+ qed
	+ qed
	+ qed
	+ qed
	+ moreover have \<open>b \<noteq> 3\<close>
	+ proof (rule classical)
	+ assume \<open>\<not> (b \<noteq> 3)\<close>
	+ hence \<open>b = 3\<close>
	+ by blast
	+ obtain m where \<open>m \<noteq> 0\<close> and
	+ \<open>{x \| x::nat. x < n \<and> coprime x n} = {1+j*b\| j::nat. j < m}\<close>
	+ using \<open>m \<noteq> 0\<close> \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ have \<open>b \<noteq> 0\<close>
	+ by (simp add: \<open>b = 3\<close>)
	+ have \<open>n = 2 + (m-1)*b\<close>
	+ proof-
	+ have \<open>n-1 \<in> {x \| x::nat. x < n \<and> coprime x n}\<close>
	+ using \<open>1 < n\<close> coprime_diff_one_left_nat
	+ by auto
	+ have \<open>n-1 \<in> {1+j*b\| j::nat. j < m}\<close>
	+ using \<open>n - 1 \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ then obtain i::nat where \<open>n-1 = 1+i*b\<close> and \<open>i < m\<close>
	+ by blast
	+ have \<open>i \<le> m-1\<close>
	+ using \<open>i < m\<close>
	+ by linarith
	+ have \<open>1 + (m-1)b \<in> {1+jb\| j::nat. j < m}\<close>
	+ using \<open>m \<noteq> 0\<close>
	+ by auto
	+ hence \<open>1 + (m-1)*b \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ hence \<open>1 + (m-1)*b < n\<close>
	+ by blast
	+ hence \<open>1 + (m-1)*b \<le> n-1\<close>
	+ by linarith
	+ hence \<open>1 + (m-1)b \<le> 1+ib\<close>
	+ using \<open>n - 1 = 1 + i * b\<close>
	+ by linarith
	+ hence \<open>(m-1)b \<le> ib\<close>
	+ by linarith
	+ hence \<open>m-1 \<le> i\<close>
	+ using \<open>b \<noteq> 0\<close>
	+ by auto
	+ hence \<open>m-1 = i\<close>
	+ using \<open>i \<le> m - 1\<close> le_antisym
	+ by blast
	+ thus ?thesis
	+ using \<open>m \<noteq> 0\<close> \<open>n - 1 = 1 + i * b\<close>
	+ by auto
	+ qed
	+ have \<open>n > 2\<close>
	+ using \<open>1 < n\<close> \<open>n \<noteq> 2\<close>
	+ by linarith
	+ hence \<open> m \<ge> 2 \<close> using \<open>n = 2 + (m-1)*b\<close> \<open>b = 3\<close>
	+ by simp
	+ have \<open>4 \<in> {1+j*(b::nat)\| j::nat. j < m}\<close>
	+ using \<open>2 \<le> m\<close> \<open>b = 3\<close>
	+ by force
	+ hence \<open>(4::nat) \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by auto
	+ hence \<open>coprime (4::nat) n\<close>
	+ by blast
	+ have \<open>(2::nat) dvd 4\<close>
	+ by auto
	+ hence \<open>coprime (2::nat) n\<close>
	+ using \<open>coprime (4::nat) n\<close> coprime_divisors dvd_refl
	+ by blast
	+ have \<open>4 < n\<close>
	+ using \<open>4 \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ by blast
	+ have \<open>2 < (4::nat)\<close>
	+ by auto
	+ have \<open>2 < n\<close>
	+ by (simp add: \<open>2 < n\<close>)
	+ hence \<open>2 \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>coprime (2::nat) n\<close>
	+ by blast
	+ hence \<open>2 \<in> {1+j*(b::nat)\| j::nat. j < m}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ then obtain j::nat where \<open>2 = 1+j*3\<close>
	+ using \<open>b = 3\<close>
	+ by blast
	+ from \<open>2 = 1+j*3\<close>
	+ have \<open>1 = j*3\<close>
	+ by auto
	+ hence \<open>3 dvd 1\<close>
	+ by auto
	+ thus ?thesis
	+ using nat_dvd_1_iff_1 numeral_eq_one_iff
	+ by blast
	+ qed
	+ ultimately have \<open>b = 0 \<or> b = 1 \<or> b = 2 \<or> b = 4\<close>
	+ by auto
	+ moreover have \<open>b = 0 \<Longrightarrow> \<exists>k. n = 2^k\<close>
	+ proof-
	+ assume \<open>b = 0\<close>
	+ have \<open>{1 + j * b \|j. j < m} = {1}\<close>
	+ using \<open>b = 0\<close> \<open>m \<noteq> 0\<close>
	+ by auto
	+ hence \<open>{x \|x. x < n \<and> coprime x n} = {1}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ hence \<open>n = 2\<close>
	+ proof-
	+ have \<open>n-1 \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>1 < n\<close> coprime_diff_one_left_nat
	+ by auto
	+ have \<open>n-1 \<in> {1}\<close>
	+ using \<open>n - 1 \<in> {x \|x. x < n \<and> coprime x n}\<close> \<open>{x \|x. x < n \<and> coprime x n} = {1}\<close>
	+ by blast
	+ hence \<open>n-1 = 1\<close>
	+ by blast
	+ hence \<open>n = 2\<close>
	+ by simp
	+ thus ?thesis
	+ by blast
	+ qed
	+ hence \<open>n = 2^1\<close>
	+ by auto
	+ thus ?thesis
	+ by blast
	+ qed
	+ moreover have \<open>b = 1 \<Longrightarrow> prime n\<close>
	+ proof-
	+ assume \<open>b = 1\<close>
	+ have \<open>x < n \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> coprime x n\<close>
	+ for x
	+ proof-
	+ assume \<open>x < n\<close> and \<open>x \<noteq> 0\<close>
	+ have \<open>{1+j\| j::nat. j < m} = {x \| x::nat. x < m+1 \<and> x \<noteq> 0}\<close>
	+ by (metis (full_types) Suc_eq_plus1 add_mono1 less_Suc_eq_0_disj nat.simps(3) plus_1_eq_Suc )
	+ hence \<open>{x \| x :: nat. x < n \<and> coprime x n} = {x \| x :: nat. x < m+1 \<and> x \<noteq> 0}\<close>
	+ using \<open>b = 1\<close> \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by auto
	+ have \<open>coprime (n-1) n\<close>
	+ using \<open>1 < n\<close> coprime_diff_one_left_nat
	+ by auto
	+ have \<open>n-1 < n\<close>
	+ using \<open>1 < n\<close>
	+ by auto
	+ have \<open>n-1 \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ using \<open>coprime (n - 1) n\<close> \<open>n - 1 < n\<close>
	+ by blast
	+ have \<open>n-1 \<le> m\<close>
	+ by (metis (no_types, lifting) CollectD Suc_eq_plus1 Suc_less_eq2 \<open>n - 1 \<in> {x \|x. x < n \<and> coprime x n}\<close> \<open>{x \|x. x < n \<and> coprime x n} = {x \|x. x < m + 1 \<and> x \<noteq> 0}\<close> leD le_less_linear not_less_eq_eq )
	+ have \<open>m \<in> {x \| x :: nat. x < m+1 \<and> x \<noteq> 0}\<close>
	+ using \<open>m \<noteq> 0\<close>
	+ by auto
	+ have \<open>m \<in> {x \|x. x < n \<and> coprime x n} \<close>
	+ using \<open>m \<in> {x \|x. x < m + 1 \<and> x \<noteq> 0}\<close>
	+ \<open>{x \|x. x < n \<and> coprime x n} = {x \|x. x < m + 1 \<and> x \<noteq> 0}\<close>
	+ by blast
	+ have \<open>m < n\<close>
	+ using \<open>m \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ by blast
	+ have \<open>m+1 = n\<close>
	+ using \<open>m < n\<close> \<open>n - 1 \<le> m\<close>
	+ by linarith
	+ have \<open>x \<in> {x \| x :: nat. x < m+1 \<and> x \<noteq> 0}\<close>
	+ using \<open>m + 1 = n\<close> \<open>x < n\<close> \<open>x \<noteq> 0\<close>
	+ by blast
	+ hence \<open>x \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {x \|x. x < m + 1 \<and> x \<noteq> 0}\<close>
	+ by blast
	+ thus ?thesis
	+ by blast
	+ qed
	+ thus ?thesis
	+ using assms coprime_commute nat_neq_iff prime_nat_iff'' by auto
	+ qed
	+ moreover have \<open>b = 2 \<Longrightarrow> \<exists> k. n = 2^k\<close>
	+ proof-
	+ assume \<open>b = 2\<close>
	+ have \<open>{x \| x :: nat. x < n \<and> coprime x n} = {1+j*2\| j::nat. j < m}\<close>
	+ using \<open>b = 2\<close> \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by auto
	+ have \<open>x < n \<Longrightarrow> coprime x n \<longleftrightarrow> odd x\<close>
	+ for x::nat
	+ proof-
	+ assume \<open>x < n\<close>
	+ have \<open>coprime x n \<Longrightarrow> odd x\<close>
	+ proof-
	+ assume \<open>coprime x n\<close>
	+ have \<open>x \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ by (simp add: \<open>coprime x n\<close> \<open>x < n\<close>)
	+ hence \<open>x \<in> {1+j*2\| j::nat. j < m}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * 2 \|j. j < m}\<close>
	+ by blast
	+ then obtain j where \<open>x = 1+j*2\<close>
	+ by blast
	+ thus ?thesis
	+ by simp
	+ qed
	+ moreover have \<open>odd x \<Longrightarrow> coprime x n\<close>
	+ proof-
	+ assume \<open>odd x\<close>
	+ obtain j::nat where \<open>x = 1+j*2\<close>
	+ by (metis \<open>odd x\<close> add.commute mult_2_right odd_two_times_div_two_succ one_add_one semiring_normalization_rules(16))
	+ have \<open>j < (n-1)/2\<close>
	+ using \<open>x < n\<close> \<open>x = 1 + j * 2\<close>
	+ by linarith
	+ have \<open>n = 2*m\<close>
	+ proof-
	+ have \<open>(2::nat) \<noteq> 0\<close>
	+ by auto
	+ have \<open>n = 2+(m-1)*2\<close>
	+ proof-
	+ have \<open>n-1 \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>1 < n\<close> coprime_diff_one_left_nat
	+ by auto
	+ have \<open>n-1 \<in> {1+j*b\| j::nat. j < m}\<close>
	+ using \<open>n - 1 \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ then obtain i::nat where \<open>n-1 = 1+i*b\<close> and \<open>i < m\<close>
	+ by blast
	+ have \<open>i \<le> m-1\<close>
	+ using \<open>i < m\<close>
	+ by linarith
	+ have \<open>1 + (m-1)b \<in> {1+jb\| j::nat. j < m}\<close>
	+ using \<open>m \<noteq> 0\<close> by auto
	+ hence \<open>1 + (m-1)*b \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ hence \<open>1 + (m-1)*b < n\<close>
	+ by blast
	+ hence \<open>1 + (m-1)*b \<le> n-1\<close>
	+ by linarith
	+ hence \<open>1 + (m-1)b \<le> 1+ib\<close>
	+ using \<open>n - 1 = 1 + i * b\<close>
	+ by linarith
	+ hence \<open>(m-1)b \<le> ib\<close>
	+ by linarith
	+ hence \<open>m-1 \<le> i\<close>
	+ proof-
	+ have \<open>b \<noteq> 0\<close>
	+ using \<open>b = 2\<close>
	+ by simp
	+ thus ?thesis
	+ using \<open>(m - 1) * b \<le> i * b\<close> mult_le_cancel2
	+ by blast
	+ qed
	+ hence \<open>m-1 = i\<close>
	+ using \<open>i \<le> m - 1\<close> le_antisym
	+ by blast
	+ thus ?thesis
	+ using \<open>m \<noteq> 0\<close> \<open>n - 1 = 1 + i * b\<close>
	+ by (simp add: \<open>b = 2\<close>)
	+ qed
	+ thus ?thesis
	+ by (simp add: \<open>m \<noteq> 0\<close> \<open>n = 2 + (m - 1) * 2\<close> mult.commute mult_eq_if)
	+ qed
	+ hence \<open>j < m\<close>
	+ using \<open>x < n\<close> \<open>x = 1 + j * 2\<close>
	+ by linarith
	+ hence \<open>x \<in> {1+j*2\| j::nat. j < m}\<close>
	+ using \<open>x = 1 + j * 2\<close>
	+ by blast
	+ hence \<open>x \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * 2 \|j. j < m}\<close>
	+ by blast
	+ thus ?thesis
	+ by blast
	+ qed
	+ ultimately show ?thesis
	+ by blast
	+ qed
	+ thus ?thesis
	+ using coprime_power2 assms
	+ by auto
	+ qed
	+ moreover have \<open>b = 4 \<Longrightarrow> n = 6\<close>
	+ proof-
	+ assume \<open>b = 4\<close>
	+ have \<open>n = 2 \<or> n = 6\<close>
	+ proof(rule classical)
	+ assume \<open>\<not> (n = 2 \<or> n = 6)\<close>
	+ have \<open>(4::nat) \<noteq> 0\<close>
	+ by auto
	+ have \<open>n = 2+(m-1)*4\<close>
	+ proof-
	+ have \<open>n-1 \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>1 < n\<close> coprime_diff_one_left_nat
	+ by auto
	+ have \<open>n-1 \<in> {1+j*b\| j::nat. j < m}\<close>
	+ using \<open>n - 1 \<in> {x \|x. x < n \<and> coprime x n}\<close>
	+ \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ then obtain i::nat where \<open>n-1 = 1+i*b\<close> and \<open>i < m\<close>
	+ by blast
	+ have \<open>i \<le> m-1\<close>
	+ using \<open>i < m\<close>
	+ by linarith
	+ have \<open>1 + (m-1)b \<in> {1+jb\| j::nat. j < m}\<close>
	+ using \<open>m \<noteq> 0\<close>
	+ by auto
	+ hence \<open>1 + (m-1)*b \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ hence \<open>1 + (m-1)*b < n\<close>
	+ by blast
	+ hence \<open>1 + (m-1)*b \<le> n-1\<close>
	+ by linarith
	+ hence \<open>1 + (m-1)b \<le> 1+ib\<close>
	+ using \<open>n - 1 = 1 + i * b\<close>
	+ by linarith
	+ hence \<open>(m-1)b \<le> ib\<close>
	+ by linarith
	+ hence \<open>m-1 \<le> i\<close>
	+ proof-
	+ have \<open>b \<noteq> 0\<close>
	+ using \<open>b = 4\<close> by auto
	+ thus ?thesis
	+ using \<open>(m - 1) * b \<le> i * b\<close> mult_le_cancel2
	+ by blast
	+ qed
	+ hence \<open>m-1 = i\<close>
	+ using \<open>i \<le> m - 1\<close> le_antisym
	+ by blast
	+ thus ?thesis
	+ using \<open>m \<noteq> 0\<close> \<open>n - 1 = 1 + i * b\<close>
	+ by (simp add: \<open>b = 4\<close>)
	+ qed
	+ hence \<open>n = 4*m - 2\<close>
	+ by (simp add: \<open>m \<noteq> 0\<close> mult.commute mult_eq_if)
	+ have \<open>m \<ge> 3\<close>
	+ using \<open>\<not> (n = 2 \<or> n = 6)\<close> \<open>n = 2 + (m - 1) * 4\<close>
	+ by auto
	+ hence \<open> {1+j4\| j::nat. j < 3} \<subseteq> {1+j4\| j::nat. j < m}\<close>
	+ by force
	+ hence \<open>9 \<in> {1+j*4\| j::nat. j < 3}\<close>
	+ by force
	+ hence \<open>9 \<in> {1+j*4\| j::nat. j < m}\<close>
	+ using \<open> {1+j4\| j::nat. j < 3} \<subseteq> {1+j4\| j::nat. j < m}\<close>
	+ by blast
	+ hence \<open>9 \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>b = 4\<close> \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by auto
	+ hence \<open>coprime (9::nat) n\<close>
	+ by blast
	+ have \<open>(3::nat) dvd 9\<close>
	+ by auto
	+ have \<open>coprime (3::nat) n\<close> using \<open>coprime (9::nat) n\<close> \<open>(3::nat) dvd 9\<close>
	+ by (metis coprime_commute coprime_mult_right_iff dvd_def)
	+ have \<open>(3::nat) < n\<close>
	+ by (metis One_nat_def Suc_lessI \<open>1 < n\<close> \<open>\<not> (n = 2 \<or> n = 6)\<close> \<open>coprime 3 n\<close>
	+ coprime_self numeral_2_eq_2 numeral_3_eq_3 less_numeral_extra(1) nat_dvd_not_less)
	+ have \<open>3 \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>3 < n\<close> \<open>coprime 3 n\<close>
	+ by blast
	+ hence \<open>(3::nat) \<in> {1+j*4\| j::nat. j < m}\<close>
	+ using \<open>b = 4\<close> \<open>{x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}\<close>
	+ by blast
	+ then obtain j::nat where \<open>(3::nat) = 1 + j*4\<close>
	+ by blast
	+ have \<open>2 = j*4\<close>
	+ using numeral_3_eq_3 \<open>(3::nat) = 1 + j*4\<close>
	+ by linarith
	+ hence \<open>1 = j*2\<close>
	+ by linarith
	+ hence \<open>even 1\<close>
	+ by simp
	+ thus ?thesis
	+ using odd_one
	+ by blast
	+ qed
	+ thus ?thesis
	+ by (simp add: False)
	+ qed
	+ ultimately show ?thesis
	+ by blast
	+ qed
	+ qed
	+ qed
	+ moreover have \<open>(\<exists> b m. m \<noteq> 0 \<and> {x \| x :: nat. x < n \<and> coprime x n} = {1+j*b\| j::nat. j < m})
	+ \<longleftrightarrow> (\<exists> a b m. m \<noteq> 0 \<and> {x \| x :: nat. x < n \<and> coprime x n} = {a+j*b\| j::nat. j < m})\<close>
	+ proof
	+ show "\<exists>a b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {a + j * b \|j. j < m}"
	+ if "\<exists>b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}"
	+ using that
	+ by blast
	+ show "\<exists>b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {1 + j * b \|j. j < m}"
	+ if "\<exists>a b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {a + j * b \|j. j < m}"
	+ proof-
	+ obtain a b m::nat where \<open>m \<noteq> 0\<close>
	+ and \<open>{x \| x :: nat. x < n \<and> coprime x n} = {a+j*b\| j::nat. j < m}\<close>
	+ using \<open>\<exists>a b m. m \<noteq> 0 \<and> {x \|x. x < n \<and> coprime x n} = {a + j * b \|j. j < m}\<close>
	+ by auto
	+ have \<open>a = 1\<close>
	+ proof-
	+ have \<open>{x \| x :: nat. x < n \<and> coprime x n} = {(a::nat)+j*(b::nat)\| j::nat. j < m} \<Longrightarrow> a = 1\<close>
	+ proof-
	+ have \<open>Min {x \| x :: nat. x < n \<and> coprime x n} = Min {a+j*b\| j::nat. j < m}\<close>
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {a + j * b \|j. j < m}\<close>
	+ by auto
	+ have \<open>Min {x \| x :: nat. x < n \<and> coprime x n} = 1\<close>
	+ proof-
	+ have \<open>finite {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ by auto
	+ have \<open>{x \| x :: nat. x < n \<and> coprime x n} \<noteq> {}\<close>
	+ using \<open>1 < n\<close> by auto
	+ have \<open>1 \<in> {x \| x :: nat. x < n \<and> coprime x n}\<close>
	+ using \<open>1 < n\<close>
	+ by auto
	+ have \<open>\<forall> x. coprime x n \<longrightarrow> x \<ge> 1\<close>
	+ using \<open>1 < n\<close> le_less_linear
	+ by fastforce
	+ hence \<open>\<forall> x. x < n \<and> coprime x n \<longrightarrow> x \<ge> 1\<close>
	+ by blast
	+ hence \<open>\<forall> x \<in> {x \| x :: nat. x < n \<and> coprime x n}. x \<ge> 1\<close>
	+ by blast
	+ hence \<open>Min {x \| x :: nat. x < n \<and> coprime x n} \<ge> 1\<close>
	+ using \<open>finite {x \| x :: nat. x < n \<and> coprime x n}\<close> \<open>{x \|x. x < n \<and> coprime x n} \<noteq> {}\<close>
	+ by auto
	+ thus ?thesis
	+ using Min_le \<open>1 \<in> {x \|x. x < n \<and> coprime x n}\<close> \<open>finite {x \|x. x < n \<and> coprime x n}\<close>
	+ antisym by blast
	+ qed
	+ have \<open>Min {a+j*b\| j::nat. j < m} = a\<close>
	+ proof -
	+ have f1: "\<exists>n. a = a + n * b \<and> n < m"
	+ using \<open>m \<noteq> 0\<close>
	+ by auto
	+ have f2: "\<exists>n. 1 = a + n * b \<and> n < m"
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {a + j * b \|j. j < m}\<close> assms coprime_1_left
	+ by blast
	+ have f3: "\<exists>na. a = na \<and> na < n \<and> coprime na n"
	+ using f1 \<open>{x \|x. x < n \<and> coprime x n} = {a + j * b \|j. j < m}\<close> by blast
	+ have "n \<noteq> 1"
	+ by (metis (lifting) assms less_irrefl_nat)
	+ then have "\<not> coprime 0 n"
	+ by simp
	+ then show ?thesis
	+ using f3 f2 by (metis \<open>Min {x \|x. x < n \<and> coprime x n} = 1\<close> \<open>{x \|x. x < n \<and> coprime x n} = {a + j * b \|j. j < m}\<close> less_one linorder_neqE_nat not_add_less1)
	+ qed
	+ hence \<open>Min {a+j*b\| j::nat. j < m} = a\<close> by blast
	+ thus ?thesis
	+ using \<open>Min {x \| x :: nat. x < n \<and> coprime x n} = 1\<close> \<open>Min {x \| x :: nat. x < n \<and> coprime x n} = Min {a+j*b\| j::nat. j < m}\<close>
	+ by linarith
	+ qed
	+ thus ?thesis
	+ using \<open>{x \|x. x < n \<and> coprime x n} = {a + j * b \|j. j < m}\<close>
	+ by blast
	+ qed
	+ thus ?thesis using \<open>m \<noteq> 0\<close> \<open>{x \| x. x < n \<and> coprime x n} = {a+j*b\| j::nat. j < m}\<close>
	+ by auto
	+ qed
	+ qed
	+ ultimately show ?thesis
	+ by simp
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Arith_Prog_Rel_Primes/ROOT b/thys/Arith_Prog_Rel_Primes/ROOT
	new file mode 100755
	--- /dev/null
	+++ b/thys/Arith_Prog_Rel_Primes/ROOT
	@@ -0,0 +1,10 @@
	+chapter AFP
	+
	+
	+session Arith_Prog_Rel_Primes (AFP) = "HOL-Number_Theory" +
	+ options [timeout = 300]
	+ theories
	+ Arith_Prog_Rel_Primes
	+ document_files
	+ "root.tex"
	+ "root.bib"
	diff --git a/thys/Arith_Prog_Rel_Primes/document/root.bib b/thys/Arith_Prog_Rel_Primes/document/root.bib
	new file mode 100755
	--- /dev/null
	+++ b/thys/Arith_Prog_Rel_Primes/document/root.bib
	@@ -0,0 +1,5 @@
	+
	+@misc{putnam,
	+ title="Problem {``ARITHMETIC PROGRESSIONS"}, from {P}utnam exam problems 2002, https://www.ocf.berkeley.edu/~wwu/riddles/putnam.shtml"
	+}
	+
	diff --git a/thys/Arith_Prog_Rel_Primes/document/root.tex b/thys/Arith_Prog_Rel_Primes/document/root.tex
	new file mode 100755
	--- /dev/null
	+++ b/thys/Arith_Prog_Rel_Primes/document/root.tex
	@@ -0,0 +1,31 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage{isabelle,isabellesym}
	+
	+
	+%this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+\begin{document}
	+
	+\title{Arithmetic progressions and relative primes}
	+\author{Jos\'e Manuel Rodr\'iguez Caballero}
	+\maketitle
	+
	+\begin{abstract}
	+This article provides a formalization of the solution obtained by the author of the Problem ``ARITHMETIC PROGRESSIONS" from the
	+Putnam exam problems \cite{putnam} of $2002$. The statement of the problem is as follows: For which integers $n>1$ does the set of positive integers less than and relatively prime to $n$ constitute an arithmetic progression?
	+\end{abstract}
	+
	+\tableofcontents
	+
	+\input{session}
	+
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	diff --git a/thys/Bicategory/Bicategory.thy b/thys/Bicategory/Bicategory.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/Bicategory.thy
	@@ -0,0 +1,2498 @@
	+(* Title: Bicategory
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+theory Bicategory
	+imports Prebicategory Category3.Subcategory Category3.DiscreteCategory
	+ MonoidalCategory.MonoidalCategory
	+begin
	+
	+ section "Bicategories"
	+
	+ text \<open>
	+ A \emph{bicategory} is a (vertical) category that has been equipped with
	+ a horizontal composition, an associativity natural isomorphism,
	+ and for each object a ``unit isomorphism'', such that horizontal
	+ composition on the left by target and on the right by source are
	+ fully faithful endofunctors of the vertical category, and such that
	+ the usual pentagon coherence condition holds for the associativity.
	+ \<close>
	+
	+ locale bicategory =
	+ horizontal_composition V H src trg +
	+ VxVxV: product_category V VxV.comp +
	+ VVV: subcategory VxVxV.comp \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close> +
	+ HoHV: "functor" VVV.comp V HoHV +
	+ HoVH: "functor" VVV.comp V HoVH +
	+ \<alpha>: natural_isomorphism VVV.comp V HoHV HoVH
	+ \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> +
	+ L: fully_faithful_functor V V L +
	+ R: fully_faithful_functor V V R
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a" +
	+ assumes unit_in_vhom: "obj a \<Longrightarrow> \<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ and iso_unit: "obj a \<Longrightarrow> iso \<i>[a]"
	+ and pentagon: "\<lbrakk> ide f; ide g; ide h; ide k; src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
	+ (f \<star> \<a> g h k) \<cdot> \<a> f (g \<star> h) k \<cdot> (\<a> f g h \<star> k) = \<a> f g (h \<star> k) \<cdot> \<a> (f \<star> g) h k"
	+ begin
	+ (*
	+ * TODO: the mapping \<i> is not currently assumed to be extensional.
	+ * It might be best in the long run if it were.
	+ *)
	+
	+ definition \<alpha>
	+ where "\<alpha> \<mu>\<nu>\<tau> \<equiv> \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))"
	+
	+ lemma assoc_in_hom':
	+ assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
	+ shows "in_hhom \<a>[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
	+ and "\<guillemotleft>\<a>[\<mu>, \<nu>, \<tau>] : (dom \<mu> \<star> dom \<nu>) \<star> dom \<tau> \<Rightarrow> cod \<mu> \<star> cod \<nu> \<star> cod \<tau>\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<a>[\<mu>, \<nu>, \<tau>] : (dom \<mu> \<star> dom \<nu>) \<star> dom \<tau> \<Rightarrow> cod \<mu> \<star> cod \<nu> \<star> cod \<tau>\<guillemotright>"
	+ proof -
	+ have 1: "VVV.in_hom (\<mu>, \<nu>, \<tau>) (dom \<mu>, dom \<nu>, dom \<tau>) (cod \<mu>, cod \<nu>, cod \<tau>)"
	+ using assms VVV.in_hom_char VVV.arr_char VV.arr_char by auto
	+ have "\<guillemotleft>\<a>[\<mu>, \<nu>, \<tau>] : HoHV (dom \<mu>, dom \<nu>, dom \<tau>) \<Rightarrow> HoVH (cod \<mu>, cod \<nu>, cod \<tau>)\<guillemotright>"
	+ using 1 \<alpha>.preserves_hom by auto
	+ moreover have "HoHV (dom \<mu>, dom \<nu>, dom \<tau>) = (dom \<mu> \<star> dom \<nu>) \<star> dom \<tau>"
	+ using 1 HoHV_def by (simp add: VVV.in_hom_char)
	+ moreover have "HoVH (cod \<mu>, cod \<nu>, cod \<tau>) = cod \<mu> \<star> cod \<nu> \<star> cod \<tau>"
	+ using 1 HoVH_def by (simp add: VVV.in_hom_char)
	+ ultimately show ?thesis by simp
	+ qed
	+ thus "in_hhom \<a>[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
	+ using assms src_cod trg_cod vconn_implies_hpar(1) vconn_implies_hpar(2) by auto
	+ qed
	+
	+ lemma assoc_is_natural_1:
	+ assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
	+ shows "\<a>[\<mu>, \<nu>, \<tau>] = (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]"
	+ using assms \<alpha>.is_natural_1 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char VVV.dom_char
	+ HoVH_def src_dom trg_dom
	+ by simp
	+
	+ lemma assoc_is_natural_2:
	+ assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
	+ shows "\<a>[\<mu>, \<nu>, \<tau>] = \<a>[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> ((\<mu> \<star> \<nu>) \<star> \<tau>)"
	+ using assms \<alpha>.is_natural_2 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char VVV.cod_char
	+ HoHV_def src_dom trg_dom
	+ by simp
	+
	+ lemma assoc_naturality:
	+ assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
	+ shows "\<a>[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> ((\<mu> \<star> \<nu>) \<star> \<tau>) = (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]"
	+ using assms \<alpha>.naturality VVV.arr_char VV.arr_char HoVH_def HoHV_def
	+ VVV.dom_char VVV.cod_char
	+ by auto
	+
	+ lemma assoc_in_hom [intro]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "in_hhom \<a>[f, g, h] (src h) (trg f)"
	+ and "\<guillemotleft>\<a>[f, g, h] : (dom f \<star> dom g) \<star> dom h \<Rightarrow> cod f \<star> cod g \<star> cod h\<guillemotright>"
	+ using assms assoc_in_hom' apply auto[1]
	+ using assms assoc_in_hom' ideD(1) by metis
	+
	+ lemma assoc_simps [simp]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "arr \<a>[f, g, h]"
	+ and "src \<a>[f, g, h] = src h" and "trg \<a>[f, g, h] = trg f"
	+ and "dom \<a>[f, g, h] = (dom f \<star> dom g) \<star> dom h"
	+ and "cod \<a>[f, g, h] = cod f \<star> cod g \<star> cod h"
	+ using assms assoc_in_hom apply auto
	+ using assoc_in_hom(1) by auto
	+
	+ lemma iso_assoc [intro, simp]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "iso \<a>[f, g, h]"
	+ using assms \<alpha>.components_are_iso [of "(f, g, h)"] VVV.ide_char VVV.arr_char VV.arr_char
	+ by simp
	+
	+ end
	+
	+ subsection "Categories Induce Bicategories"
	+
	+ text \<open>
	+ In this section we show that a category becomes a bicategory if we take the vertical
	+ composition to be discrete, we take the composition of the category as the
	+ horizontal composition, and we take the vertical domain and codomain as \<open>src\<close> and \<open>trg\<close>.
	+ \<close>
	+
	+ (*
	+ * It is helpful to make a few local definitions here, but I don't want them to
	+ * clutter the category locale. Using a context and private definitions does not
	+ * work as expected. So we have to define a new locale just for the present purpose.
	+ *)
	+ locale category_as_bicategory = category
	+ begin
	+
	+ interpretation V: discrete_category \<open>Collect arr\<close> null
	+ using not_arr_null by (unfold_locales, blast)
	+
	+ abbreviation V
	+ where "V \<equiv> V.comp"
	+
	+ interpretation src: "functor" V V dom
	+ using V.null_char
	+ by (unfold_locales, simp add: has_domain_iff_arr dom_def, auto)
	+ interpretation trg: "functor" V V cod
	+ using V.null_char
	+ by (unfold_locales, simp add: has_codomain_iff_arr cod_def, auto)
	+
	+ interpretation H: horizontal_homs V dom cod
	+ by (unfold_locales, auto)
	+
	+ interpretation VxV: product_category V V ..
	+ interpretation VV: subcategory VxV.comp
	+ \<open>\<lambda>\<mu>\<nu>. V.arr (fst \<mu>\<nu>) \<and> V.arr (snd \<mu>\<nu>) \<and> dom (fst \<mu>\<nu>) = cod (snd \<mu>\<nu>)\<close>
	+ using H.subcategory_VV by auto
	+ interpretation VxVxV: product_category V VxV.comp ..
	+ interpretation VVV: subcategory VxVxV.comp \<open>\<lambda>\<tau>\<mu>\<nu>. V.arr (fst \<tau>\<mu>\<nu>) \<and>
	+ VV.arr (snd \<tau>\<mu>\<nu>) \<and> dom (fst \<tau>\<mu>\<nu>) = cod (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using H.subcategory_VVV by auto
	+
	+ interpretation H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<cdot> snd \<mu>\<nu>\<close>
	+ apply (unfold_locales)
	+ using VV.arr_char V.null_char ext
	+ apply force
	+ using VV.arr_char V.null_char VV.dom_char VV.cod_char
	+ apply auto[3]
	+ proof -
	+ show "\<And>g f. VV.seq g f \<Longrightarrow>
	+ fst (VV.comp g f) \<cdot> snd (VV.comp g f) = V (fst g \<cdot> snd g) (fst f \<cdot> snd f)"
	+ proof -
	+ have 0: "\<And>f. VV.arr f \<Longrightarrow> V.arr (fst f \<cdot> snd f)"
	+ using VV.arr_char by auto
	+ have 1: "\<And>f g. V.seq g f \<Longrightarrow> V.ide f \<and> g = f"
	+ using V.arr_char V.dom_char V.cod_char V.not_arr_null by force
	+ have 2: "\<And>f g. VxV.seq g f \<Longrightarrow> VxV.ide f \<and> g = f"
	+ using 1 VxV.seq_char by (metis VxV.dom_eqI VxV.ide_Ide)
	+ fix f g
	+ assume fg: "VV.seq g f"
	+ have 3: "VV.ide f \<and> f = g"
	+ using fg 2 VV.seq_char VV.ide_char by blast
	+ show "fst (VV.comp g f) \<cdot> snd (VV.comp g f) = V (fst g \<cdot> snd g) (fst f \<cdot> snd f)"
	+ using fg 0 1 3 VV.comp_char VV.arr_char VV.ide_char V.arr_char V.comp_char
	+ VV.comp_arr_ide
	+ by (metis (no_types, lifting))
	+ qed
	+ qed
	+
	+ interpretation H: horizontal_composition V C dom cod
	+ by (unfold_locales, auto)
	+
	+ interpretation H.HoHV: "functor" VVV.comp V H.HoHV
	+ using H.functor_HoHV by blast
	+ interpretation H.HoVH: "functor" VVV.comp V H.HoVH
	+ using H.functor_HoVH by blast
	+
	+ abbreviation \<a>
	+ where "\<a> f g h \<equiv> f \<cdot> g \<cdot> h"
	+
	+ interpretation \<alpha>: natural_isomorphism VVV.comp V H.HoHV H.HoVH
	+ \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close>
	+ apply unfold_locales
	+ using V.null_char ext
	+ apply fastforce
	+ using H.HoHV_def H.HoVH_def VVV.arr_char VV.arr_char VVV.dom_char VV.dom_char
	+ VVV.cod_char VV.cod_char VVV.ide_char comp_assoc
	+ by auto
	+
	+ interpretation endofunctor V H.L
	+ using H.endofunctor_L by auto
	+ interpretation endofunctor V H.R
	+ using H.endofunctor_R by auto
	+
	+ interpretation fully_faithful_functor V V H.R
	+ using comp_arr_dom by (unfold_locales, auto)
	+ interpretation fully_faithful_functor V V H.L
	+ using comp_cod_arr by (unfold_locales, auto)
	+
	+ abbreviation \<i>
	+ where "\<i> \<equiv> \<lambda>x. x"
	+
	+ proposition induces_bicategory:
	+ shows "bicategory V C \<a> \<i> dom cod"
	+ apply (unfold_locales, auto simp add: comp_assoc)
	+ using comp_arr_dom by fastforce
	+
	+ end
	+
	+ subsection "Monoidal Categories induce Bicategories"
	+
	+ text \<open>
	+ In this section we show that our definition of bicategory directly generalizes our
	+ definition of monoidal category:
	+ a monoidal category becomes a bicategory when equipped with the constant-\<open>\<I>\<close> functors
	+ as src and trg and \<open>\<iota>\<close> as the unit isomorphism from \<open>\<I> \<otimes> \<I>\<close> to \<open>\<I>\<close>.
	+ There is a slight mismatch because the bicategory locale assumes that the associator
	+ is given in curried form, whereas for monoidal categories it is given in tupled form.
	+ Ultimately, the monoidal category locale should be revised to also use curried form,
	+ which ends up being more convenient in most situations.
	+ \<close>
	+
	+ context monoidal_category
	+ begin
	+
	+ interpretation I: constant_functor C C \<I>
	+ using \<iota>_in_hom by unfold_locales auto
	+ interpretation HH: horizontal_homs C I.map I.map
	+ by unfold_locales auto
	+ interpretation CC': subcategory CC.comp \<open>\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and>
	+ I.map (fst \<mu>\<nu>) = I.map (snd \<mu>\<nu>)\<close>
	+ using HH.subcategory_VV by auto
	+ interpretation CCC': subcategory CCC.comp \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> CC'.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ I.map (fst \<tau>\<mu>\<nu>) = I.map (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using HH.subcategory_VVV by simp
	+
	+ lemma CC'_eq_CC:
	+ shows "CC.comp = CC'.comp"
	+ proof -
	+ have "\<And>g f. CC.comp g f = CC'.comp g f"
	+ proof -
	+ fix f g
	+ show "CC.comp g f = CC'.comp g f"
	+ proof -
	+ have "CC.seq g f \<Longrightarrow> CC.comp g f = CC'.comp g f"
	+ using CC'.comp_char CC'.arr_char CC.seq_char
	+ by (elim CC.seqE seqE, simp)
	+ moreover have "\<not> CC.seq g f \<Longrightarrow> CC.comp g f = CC'.comp g f"
	+ using CC'.seq_char CC'.ext CC'.null_char CC.ext
	+ by (metis (no_types, lifting))
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ thus ?thesis by blast
	+ qed
	+
	+ lemma CCC'_eq_CCC:
	+ shows "CCC.comp = CCC'.comp"
	+ proof -
	+ have "\<And>g f. CCC.comp g f = CCC'.comp g f"
	+ proof -
	+ fix f g
	+ show "CCC.comp g f = CCC'.comp g f"
	+ proof -
	+ have "CCC.seq g f \<Longrightarrow> CCC.comp g f = CCC'.comp g f"
	+ using CCC'.comp_char CCC'.arr_char CCC.seq_char CC'.arr_char
	+ by (elim CCC.seqE CC.seqE seqE, simp)
	+ moreover have "\<not> CCC.seq g f \<Longrightarrow> CCC.comp g f = CCC'.comp g f"
	+ using CCC'.seq_char CCC'.ext CCC'.null_char CCC.ext
	+ by (metis (no_types, lifting))
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ thus ?thesis by blast
	+ qed
	+
	+ interpretation H: "functor" CC'.comp C \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<otimes> snd \<mu>\<nu>\<close>
	+ using CC'_eq_CC T.functor_axioms by simp
	+ interpretation H: horizontal_composition C tensor I.map I.map
	+ by (unfold_locales, simp_all)
	+
	+ lemma HoHV_eq_ToTC:
	+ shows "H.HoHV = T.ToTC"
	+ using H.HoHV_def T.ToTC_def CCC'_eq_CCC by presburger
	+
	+ interpretation HoHV: "functor" CCC'.comp C H.HoHV
	+ using T.functor_ToTC HoHV_eq_ToTC CCC'_eq_CCC by argo
	+
	+ lemma HoVH_eq_ToCT:
	+ shows "H.HoVH = T.ToCT"
	+ using H.HoVH_def T.ToCT_def CCC'_eq_CCC by presburger
	+
	+ interpretation HoVH: "functor" CCC'.comp C H.HoVH
	+ using T.functor_ToCT HoVH_eq_ToCT CCC'_eq_CCC by argo
	+
	+ interpretation \<alpha>: natural_isomorphism CCC'.comp C H.HoHV H.HoVH \<alpha>
	+ using \<alpha>.natural_isomorphism_axioms CCC'_eq_CCC HoHV_eq_ToTC HoVH_eq_ToCT
	+ by simp
	+
	+ lemma R'_eq_R:
	+ shows "H.R = R"
	+ using H.is_extensional CC'_eq_CC CC.arr_char by force
	+
	+ lemma L'_eq_L:
	+ shows "H.L = L"
	+ using H.is_extensional CC'_eq_CC CC.arr_char by force
	+
	+ interpretation R': fully_faithful_functor C C H.R
	+ using R'_eq_R R.fully_faithful_functor_axioms unity_def by auto
	+ interpretation L': fully_faithful_functor C C H.L
	+ using L'_eq_L L.fully_faithful_functor_axioms unity_def by auto
	+
	+ lemma obj_char:
	+ shows "HH.obj a \<longleftrightarrow> a = \<I>"
	+ using HH.obj_def \<iota>_in_hom by fastforce
	+
	+ proposition induces_bicategory:
	+ shows "bicategory C tensor (\<lambda>\<mu> \<nu> \<tau>. \<alpha> (\<mu>, \<nu>, \<tau>)) (\<lambda>_. \<iota>) I.map I.map"
	+ using obj_char \<iota>_in_hom \<iota>_is_iso pentagon \<alpha>.is_extensional \<alpha>.is_natural_1 \<alpha>.is_natural_2
	+ by (unfold_locales, simp_all)
	+
	+ end
	+
	+ subsection "Prebicategories Extend to Bicategories"
	+
	+ text \<open>
	+ In this section, we show that a prebicategory with homs and units extends to a bicategory.
	+ The main work is to show that the endofunctors \<open>L\<close> and \<open>R\<close> are fully faithful.
	+ We take the left and right unitor isomorphisms, which were obtained via local
	+ constructions in the left and right hom-subcategories defined by a specified
	+ weak unit, and show that in the presence of the chosen sources and targets they
	+ are the components of a global natural isomorphisms \<open>\<ll>\<close> and \<open>\<rr>\<close> from the endofunctors
	+ \<open>L\<close> and \<open>R\<close> to the identity functor. A consequence is that functors \<open>L\<close> and \<open>R\<close> are
	+ endo-equivalences, hence fully faithful.
	+ \<close>
	+
	+ context prebicategory_with_homs
	+ begin
	+
	+ text \<open>
	+ Once it is equipped with a particular choice of source and target for each arrow,
	+ a prebicategory determines a horizontal composition.
	+ \<close>
	+
	+ lemma induces_horizontal_composition:
	+ shows "horizontal_composition V H src trg"
	+ proof -
	+ interpret VxV: product_category V V ..
	+ interpret VV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and>
	+ src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)\<close>
	+ using subcategory_VV by argo
	+ interpret VxVxV: product_category V VxV.comp ..
	+ interpret VVV: subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using subcategory_VVV by blast
	+ interpret H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
	+ proof -
	+ have "VV.comp = VoV.comp"
	+ using composable_char\<^sub>P\<^sub>B\<^sub>H by meson
	+ thus "functor VV.comp V (\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>)"
	+ using functor_axioms by argo
	+ qed
	+ show "horizontal_composition V H src trg"
	+ using src_hcomp trg_hcomp composable_char\<^sub>P\<^sub>B\<^sub>H not_arr_null
	+ by (unfold_locales; metis)
	+ qed
	+
	+ end
	+
	+ sublocale prebicategory_with_homs \<subseteq> horizontal_composition V H src trg
	+ using induces_horizontal_composition by auto
	+
	+ locale prebicategory_with_homs_and_units =
	+ prebicategory_with_units +
	+ prebicategory_with_homs
	+ begin
	+
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+
	+ text \<open>
	+ The next definitions extend the left and right unitors that were defined locally with
	+ respect to a particular weak unit, to globally defined versions using the chosen
	+ source and target for each arrow.
	+ \<close>
	+
	+ definition lunit ("\<l>[_]")
	+ where "lunit f \<equiv> left_hom_with_unit.lunit V H \<a> \<i>[trg f] (trg f) f"
	+
	+ definition runit ("\<r>[_]")
	+ where "runit f \<equiv> right_hom_with_unit.runit V H \<a> \<i>[src f] (src f) f"
	+
	+ lemma lunit_in_hom:
	+ assumes "ide f"
	+ shows "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
	+ proof -
	+ interpret Left: subcategory V \<open>left (trg f)\<close>
	+ using assms left_hom_is_subcategory by simp
	+ interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[trg f]\<close> \<open>trg f\<close>
	+ using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
	+ have 0: "Left.ide f"
	+ using assms Left.ide_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
	+ show 1: "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
	+ unfolding lunit_def
	+ using assms 0 Left.lunit_char(1) Left.hom_char H\<^sub>L_def by auto
	+ show "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
	+ using 1 src_cod trg_cod src_in_sources trg_in_targets
	+ by (metis arrI vconn_implies_hpar)
	+ qed
	+
	+ lemma runit_in_hom:
	+ assumes "ide f"
	+ shows "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
	+ proof -
	+ interpret Right: subcategory V \<open>right (src f)\<close>
	+ using assms right_hom_is_subcategory weak_unit_self_composable by force
	+ interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[src f]\<close> \<open>src f\<close>
	+ using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
	+ have 0: "Right.ide f"
	+ using assms Right.ide_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
	+ show 1: "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
	+ unfolding runit_def
	+ using assms 0 Right.runit_char(1) Right.hom_char H\<^sub>R_def by auto
	+ show "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
	+ using 1 src_cod trg_cod src_in_sources trg_in_targets
	+ by (metis arrI vconn_implies_hpar)
	+ qed
	+
	+ text \<open>
	+ The characterization of the locally defined unitors yields a corresponding characterization
	+ of the globally defined versions, by plugging in the chosen source or target for each
	+ arrow for the unspecified weak unit in the the local versions.
	+ \<close>
	+
	+ lemma lunit_char:
	+ assumes "ide f"
	+ shows "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
	+ and "trg f \<star> \<l>[f] = (\<i>[trg f] \<star> f) \<cdot> inv \<a>[trg f, trg f, f]"
	+ and "\<exists>!\<mu>. \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright> \<and> trg f \<star> \<mu> = (\<i>[trg f] \<star> f) \<cdot> inv \<a>[trg f, trg f, f]"
	+ proof -
	+ let ?a = "src f" and ?b = "trg f"
	+ interpret Left: subcategory V \<open>left ?b\<close>
	+ using assms left_hom_is_subcategory weak_unit_self_composable by force
	+ interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[?b]\<close> ?b
	+ using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
	+ have 0: "Left.ide f"
	+ using assms Left.ide_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
	+ show "\<guillemotleft>\<l>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
	+ using assms lunit_in_hom by simp
	+ show A: "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
	+ using assms lunit_in_hom by simp
	+ show B: "?b \<star> \<l>[f] = (\<i>[?b] \<star> f) \<cdot> inv \<a>[?b, ?b, f]"
	+ unfolding lunit_def using 0 Left.lunit_char(2) H\<^sub>L_def
	+ by (metis Left.comp_simp Left.characteristic_iso(1-2) Left.seqI')
	+ show "\<exists>!\<mu>. \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright> \<and> trg f \<star> \<mu> = (\<i>[?b] \<star> f) \<cdot> inv \<a>[?b, ?b, f]"
	+ proof -
	+ have 1: "hom (trg f \<star> f) f = Left.hom (Left.L f) f"
	+ proof
	+ have 1: "Left.L f = ?b \<star> f"
	+ using 0 H\<^sub>L_def by simp
	+ show "Left.hom (Left.L f) f \<subseteq> hom (?b \<star> f) f"
	+ using assms Left.hom_char [of "?b \<star> f" f] H\<^sub>L_def by simp
	+ show "hom (?b \<star> f) f \<subseteq> Left.hom (Left.L f) f"
	+ using assms 1 ide_in_hom composable_char\<^sub>P\<^sub>B\<^sub>H hom_connected left_def
	+ Left.hom_char
	+ by auto
	+ qed
	+ let ?P = "\<lambda>\<mu>. Left.in_hom \<mu> (Left.L f) f"
	+ let ?P' = "\<lambda>\<mu>. \<guillemotleft>\<mu> : ?b \<star> f \<Rightarrow> f\<guillemotright>"
	+ let ?Q = "\<lambda>\<mu>. Left.L \<mu> = (\<i>[?b] \<star> f) \<cdot> (inv \<a>[?b, ?b, f])"
	+ let ?R = "\<lambda>\<mu>. ?b \<star> \<mu> = (\<i>[?b] \<star> f) \<cdot> (inv \<a>[?b, ?b, f])"
	+ have 2: "?P = ?P'"
	+ using 0 1 H\<^sub>L_def Left.hom_char by blast
	+ moreover have "\<forall>\<mu>. ?P \<mu> \<longrightarrow> (?Q \<mu> \<longleftrightarrow> ?R \<mu>)"
	+ using 2 Left.lunit_eqI H\<^sub>L_def by presburger
	+ moreover have "(\<exists>!\<mu>. ?P \<mu> \<and> ?Q \<mu>)"
	+ using 0 2 A B Left.lunit_char(3) Left.ide_char Left.arr_char
	+ by (metis (no_types, lifting) Left.lunit_char(2) calculation(2) lunit_def)
	+ ultimately show ?thesis by metis
	+ qed
	+ qed
	+
	+ lemma runit_char:
	+ assumes "ide f"
	+ shows "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>" and "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
	+ and "\<r>[f] \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
	+ and "\<exists>!\<mu>. \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright> \<and> \<mu> \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
	+ proof -
	+ let ?a = "src f" and ?b = "trg f"
	+ interpret Right: subcategory V \<open>right ?a\<close>
	+ using assms right_hom_is_subcategory weak_unit_self_composable by force
	+ interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[?a]\<close> ?a
	+ using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
	+ have 0: "Right.ide f"
	+ using assms Right.ide_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
	+ show "\<guillemotleft>\<r>[f] : src f \<rightarrow>\<^sub>W\<^sub>C trg f\<guillemotright>"
	+ using assms runit_in_hom by simp
	+ show A: "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
	+ using assms runit_in_hom by simp
	+ show B: "\<r>[f] \<star> ?a = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
	+ unfolding runit_def using 0 Right.runit_char(2) H\<^sub>R_def
	+ using Right.comp_simp Right.characteristic_iso(4) Right.iso_is_arr by auto
	+ show "\<exists>!\<mu>. \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright> \<and> \<mu> \<star> ?a = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
	+ proof -
	+ have 1: "hom (f \<star> ?a) f = Right.hom (Right.R f) f"
	+ proof
	+ have 1: "Right.R f = f \<star> ?a"
	+ using 0 H\<^sub>R_def by simp
	+ show "Right.hom (Right.R f) f \<subseteq> hom (f \<star> ?a) f"
	+ using assms Right.hom_char [of "f \<star> ?a" f] H\<^sub>R_def by simp
	+ show "hom (f \<star> ?a) f \<subseteq> Right.hom (Right.R f) f"
	+ using assms 1 ide_in_hom composable_char\<^sub>P\<^sub>B\<^sub>H hom_connected right_def
	+ Right.hom_char
	+ by auto
	+ qed
	+ let ?P = "\<lambda>\<mu>. Right.in_hom \<mu> (Right.R f) f"
	+ let ?P' = "\<lambda>\<mu>. \<guillemotleft>\<mu> : f \<star> ?a \<Rightarrow> f\<guillemotright>"
	+ let ?Q = "\<lambda>\<mu>. Right.R \<mu> = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
	+ let ?R = "\<lambda>\<mu>. \<mu> \<star> ?a = (f \<star> \<i>[?a]) \<cdot> \<a>[f, ?a, ?a]"
	+ have 2: "?P = ?P'"
	+ using 0 1 H\<^sub>R_def Right.hom_char by blast
	+ moreover have "\<forall>\<mu>. ?P \<mu> \<longrightarrow> (?Q \<mu> \<longleftrightarrow> ?R \<mu>)"
	+ using 2 Right.runit_eqI H\<^sub>R_def by presburger
	+ moreover have "(\<exists>!\<mu>. ?P \<mu> \<and> ?Q \<mu>)"
	+ using 0 2 A B Right.runit_char(3) Right.ide_char Right.arr_char
	+ by (metis (no_types, lifting) Right.runit_char(2) calculation(2) runit_def)
	+ ultimately show ?thesis by metis
	+ qed
	+ qed
	+
	+ lemma lunit_eqI:
	+ assumes "ide f" and "\<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright>"
	+ and "trg f \<star> \<mu> = (\<i>[trg f] \<star> f) \<cdot> (inv \<a>[trg f, trg f, f])"
	+ shows "\<mu> = \<l>[f]"
	+ using assms lunit_char(2-4) by blast
	+
	+ lemma runit_eqI:
	+ assumes "ide f" and "\<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright>"
	+ and "\<mu> \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
	+ shows "\<mu> = \<r>[f]"
	+ using assms runit_char(2-4) by blast
	+
	+ lemma iso_lunit:
	+ assumes "ide f"
	+ shows "iso \<l>[f]"
	+ proof -
	+ let ?b = "trg f"
	+ interpret Left: subcategory V \<open>left ?b\<close>
	+ using assms left_hom_is_subcategory weak_unit_self_composable by force
	+ interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[?b]\<close> ?b
	+ using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
	+ show ?thesis
	+ proof -
	+ have 0: "Left.ide f"
	+ using assms Left.ide_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
	+ thus ?thesis
	+ unfolding lunit_def using Left.iso_lunit Left.iso_char by blast
	+ qed
	+ qed
	+
	+ lemma iso_runit:
	+ assumes "ide f"
	+ shows "iso \<r>[f]"
	+ proof -
	+ let ?a = "src f"
	+ interpret Right: subcategory V \<open>right ?a\<close>
	+ using assms right_hom_is_subcategory weak_unit_self_composable by force
	+ interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[?a]\<close> ?a
	+ using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
	+ show ?thesis
	+ proof -
	+ have 0: "Right.ide f"
	+ using assms Right.ide_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
	+ thus ?thesis
	+ unfolding runit_def using Right.iso_runit Right.iso_char by blast
	+ qed
	+ qed
	+
	+ lemma lunit_naturality:
	+ assumes "arr \<mu>"
	+ shows "\<mu> \<cdot> \<l>[dom \<mu>] = \<l>[cod \<mu>] \<cdot> (trg \<mu> \<star> \<mu>)"
	+ proof -
	+ let ?a = "src \<mu>" and ?b = "trg \<mu>"
	+ interpret Left: subcategory V \<open>left ?b\<close>
	+ using assms obj_trg left_hom_is_subcategory weak_unit_self_composable by force
	+ interpret Left: left_hom_with_unit V H \<a> \<open>\<i>[?b]\<close> ?b
	+ using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
	+ interpret Left.L: endofunctor \<open>Left ?b\<close> Left.L
	+ using assms endofunctor_H\<^sub>L [of ?b] weak_unit_self_composable obj_trg obj_is_weak_unit
	+ by blast
	+ have 1: "Left.in_hom \<mu> (dom \<mu>) (cod \<mu>)"
	+ using assms Left.hom_char Left.arr_char left_def composable_char\<^sub>P\<^sub>B\<^sub>H obj_trg by auto
	+ have 2: "Left.in_hom \<l>[Left.dom \<mu>] (?b \<star> dom \<mu>) (dom \<mu>)"
	+ unfolding lunit_def
	+ using assms 1 Left.in_hom_char trg_dom Left.lunit_char(1) H\<^sub>L_def
	+ Left.arr_char Left.dom_char Left.ide_dom
	+ by force
	+ have 3: "Left.in_hom \<l>[Left.cod \<mu>] (?b \<star> cod \<mu>) (cod \<mu>)"
	+ unfolding lunit_def
	+ using assms 1 Left.in_hom_char trg_cod Left.lunit_char(1) H\<^sub>L_def
	+ Left.cod_char Left.ide_cod
	+ by force
	+ have 4: "Left.in_hom (Left.L \<mu>) (?b \<star> dom \<mu>) (?b \<star> cod \<mu>)"
	+ using 1 Left.L.preserves_hom [of \<mu> "dom \<mu>" "cod \<mu>"] H\<^sub>L_def by auto
	+ show ?thesis
	+ proof -
	+ have "\<mu> \<cdot> \<l>[dom \<mu>] = Left.comp \<mu> \<l>[Left.dom \<mu>]"
	+ using 1 2 Left.comp_simp by fastforce
	+ also have "... = Left.comp \<mu> (Left.lunit (Left.dom \<mu>))"
	+ using assms 1 lunit_def by auto
	+ also have "... = Left.comp (Left.lunit (Left.cod \<mu>)) (Left.L \<mu>)"
	+ using 1 Left.lunit_naturality by auto
	+ also have "... = Left.comp (lunit (Left.cod \<mu>)) (Left.L \<mu>)"
	+ using assms 1 lunit_def by auto
	+ also have "... = \<l>[cod \<mu>] \<cdot> Left.L \<mu>"
	+ using 1 3 4 Left.comp_char Left.cod_char Left.in_hom_char by auto
	+ also have "... = \<l>[cod \<mu>] \<cdot> (trg \<mu> \<star> \<mu>)"
	+ using 1 by (simp add: H\<^sub>L_def)
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma runit_naturality:
	+ assumes "arr \<mu>"
	+ shows "\<mu> \<cdot> \<r>[dom \<mu>] = \<r>[cod \<mu>] \<cdot> (\<mu> \<star> src \<mu>)"
	+ proof -
	+ let ?a = "src \<mu>" and ?b = "trg \<mu>"
	+ interpret Right: subcategory V \<open>right ?a\<close>
	+ using assms right_hom_is_subcategory weak_unit_self_composable by force
	+ interpret Right: right_hom_with_unit V H \<a> \<open>\<i>[?a]\<close> ?a
	+ using assms obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by (unfold_locales, auto)
	+ interpret Right.R: endofunctor \<open>Right ?a\<close> Right.R
	+ using assms endofunctor_H\<^sub>R [of ?a] weak_unit_self_composable obj_src obj_is_weak_unit
	+ by blast
	+ have 1: "Right.in_hom \<mu> (dom \<mu>) (cod \<mu>)"
	+ using assms Right.hom_char Right.arr_char right_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
	+ have 2: "Right.in_hom \<r>[Right.dom \<mu>] (dom \<mu> \<star> ?a) (dom \<mu>)"
	+ unfolding runit_def
	+ using 1 Right.in_hom_char trg_dom Right.runit_char(1) [of "Right.dom \<mu>"] H\<^sub>R_def
	+ Right.arr_char Right.dom_char Right.ide_dom assms
	+ by force
	+ have 3: "\<r>[Right.cod \<mu>] \<in> Right.hom (cod \<mu> \<star> ?a) (cod \<mu>)"
	+ unfolding runit_def
	+ using 1 Right.in_hom_char trg_cod Right.runit_char(1) [of "Right.cod \<mu>"] H\<^sub>R_def
	+ Right.cod_char Right.ide_cod assms
	+ by force
	+ have 4: "Right.R \<mu> \<in> Right.hom (dom \<mu> \<star> ?a) (cod \<mu> \<star> ?a)"
	+ using 1 Right.R.preserves_hom [of \<mu> "dom \<mu>" "cod \<mu>"] H\<^sub>R_def by auto
	+ show ?thesis
	+ proof -
	+ have "\<mu> \<cdot> \<r>[dom \<mu>] = Right.comp \<mu> \<r>[Right.dom \<mu>]"
	+ by (metis 1 2 Right.comp_char Right.in_homE Right.seqI' Right.seq_char)
	+ also have "... = Right.comp \<mu> (Right.runit (Right.dom \<mu>))"
	+ using assms 1 src_dom trg_dom Right.hom_char runit_def by auto
	+ also have "... = Right.comp (Right.runit (Right.cod \<mu>)) (Right.R \<mu>)"
	+ using 1 Right.runit_naturality by auto
	+ also have "... = Right.comp (runit (Right.cod \<mu>)) (Right.R \<mu>)"
	+ using assms 1 runit_def by auto
	+ also have "... = \<r>[cod \<mu>] \<cdot> Right.R \<mu>"
	+ using 1 3 4 Right.comp_char Right.cod_char Right.in_hom_char by auto
	+ also have "... = \<r>[cod \<mu>] \<cdot> (\<mu> \<star> ?a)"
	+ using 1 by (simp add: H\<^sub>R_def)
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ interpretation L: endofunctor V L
	+ using endofunctor_L by auto
	+ interpretation \<ll>: transformation_by_components V V L map lunit
	+ using lunit_in_hom lunit_naturality by unfold_locales auto
	+ interpretation \<ll>: natural_isomorphism V V L map \<ll>.map
	+ using iso_lunit by unfold_locales auto
	+
	+ lemma natural_isomorphism_\<ll>:
	+ shows "natural_isomorphism V V L map \<ll>.map"
	+ ..
	+
	+ interpretation L: equivalence_functor V V L
	+ using L.isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
	+
	+ lemma equivalence_functor_L:
	+ shows "equivalence_functor V V L"
	+ ..
	+
	+ lemma lunit_commutes_with_L:
	+ assumes "ide f"
	+ shows "\<l>[L f] = L \<l>[f]"
	+ proof -
	+ have "seq \<l>[f] (L \<l>[f])"
	+ using assms lunit_char(2) L.preserves_hom by fastforce
	+ moreover have "seq \<l>[f] \<l>[L f]"
	+ using assms lunit_char(2) lunit_char(2) [of "L f"] L.preserves_ide by auto
	+ ultimately show ?thesis
	+ using assms lunit_char(2) [of f] lunit_naturality [of "\<l>[f]"] iso_lunit
	+ iso_is_section section_is_mono monoE [of "\<l>[f]" "L \<l>[f]" "\<l>[L f]"]
	+ by auto
	+ qed
	+
	+ interpretation R: endofunctor V R
	+ using endofunctor_R by auto
	+ interpretation \<rr>: transformation_by_components V V R map runit
	+ using runit_in_hom runit_naturality by unfold_locales auto
	+ interpretation \<rr>: natural_isomorphism V V R map \<rr>.map
	+ using iso_runit by unfold_locales auto
	+
	+ lemma natural_isomorphism_\<rr>:
	+ shows "natural_isomorphism V V R map \<rr>.map"
	+ ..
	+
	+ interpretation R: equivalence_functor V V R
	+ using R.isomorphic_to_identity_is_equivalence \<rr>.natural_isomorphism_axioms by simp
	+
	+ lemma equivalence_functor_R:
	+ shows "equivalence_functor V V R"
	+ ..
	+
	+ lemma runit_commutes_with_R:
	+ assumes "ide f"
	+ shows "\<r>[R f] = R \<r>[f]"
	+ proof -
	+ have "seq \<r>[f] (R \<r>[f])"
	+ using assms runit_char(2) R.preserves_hom by fastforce
	+ moreover have "seq \<r>[f] \<r>[R f]"
	+ using assms runit_char(2) runit_char(2) [of "R f"] R.preserves_ide by auto
	+ ultimately show ?thesis
	+ using assms runit_char(2) [of f] runit_naturality [of "\<r>[f]"] iso_runit
	+ iso_is_section section_is_mono monoE [of "\<r>[f]" "R \<r>[f]" "\<r>[R f]"]
	+ by auto
	+ qed
	+
	+ interpretation VxVxV: product_category V VxV.comp ..
	+ interpretation VVV: subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using subcategory_VVV by blast
	+ interpretation HoHV: "functor" VVV.comp V HoHV
	+ using functor_HoHV by blast
	+ interpretation HoVH: "functor" VVV.comp V HoVH
	+ using functor_HoVH by blast
	+
	+ definition \<alpha>
	+ where "\<alpha> \<mu> \<nu> \<tau> \<equiv> if VVV.arr (\<mu>, \<nu>, \<tau>) then
	+ (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]
	+ else null"
	+
	+ lemma \<alpha>_ide_simp [simp]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "\<alpha> f g h = \<a>[f, g, h]"
	+ proof -
	+ have "\<alpha> f g h = (f \<star> g \<star> h) \<cdot> \<a>[dom f, dom g, dom h]"
	+ using assms \<alpha>_def VVV.arr_char [of "(f, g, h)"] by auto
	+ also have "... = (f \<star> g \<star> h) \<cdot> \<a>[f, g, h]"
	+ using assms by simp
	+ also have "... = \<a>[f, g, h]"
	+ using assms \<alpha>_def assoc_in_hom\<^sub>A\<^sub>W\<^sub>C hcomp_in_hom\<^sub>P\<^sub>B\<^sub>H VVV.arr_char VoV.arr_char
	+ comp_cod_arr composable_char\<^sub>P\<^sub>B\<^sub>H
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+
	+ (* TODO: Figure out how this got reinstated. *)
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+
	+ lemma natural_isomorphism_\<alpha>:
	+ shows "natural_isomorphism VVV.comp V HoHV HoVH
	+ (\<lambda>\<mu>\<nu>\<tau>. \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)))"
	+ proof -
	+ interpret \<alpha>: transformation_by_components VVV.comp V HoHV HoVH
	+ \<open>\<lambda>f. \<a>[fst f, fst (snd f), snd (snd f)]\<close>
	+ proof
	+ show 1: "\<And>x. VVV.ide x \<Longrightarrow> \<guillemotleft>\<a>[fst x, fst (snd x), snd (snd x)] : HoHV x \<Rightarrow> HoVH x\<guillemotright>"
	+ proof -
	+ fix x
	+ assume x: "VVV.ide x"
	+ show "\<guillemotleft>\<a>[fst x, fst (snd x), snd (snd x)] : HoHV x \<Rightarrow> HoVH x\<guillemotright>"
	+ proof -
	+ have "ide (fst x) \<and> ide (fst (snd x)) \<and> ide (snd (snd x)) \<and>
	+ fst x \<star> fst (snd x) \<noteq> null \<and> fst (snd x) \<star> snd (snd x) \<noteq> null"
	+ using x VVV.ide_char VVV.arr_char VV.arr_char composable_char\<^sub>P\<^sub>B\<^sub>H by simp
	+ hence "\<a>[fst x, fst (snd x), snd (snd x)]
	+ \<in> hom ((fst x \<star> fst (snd x)) \<star> snd (snd x))
	+ (fst x \<star> fst (snd x) \<star> snd (snd x))"
	+ using x assoc_in_hom\<^sub>A\<^sub>W\<^sub>C by simp
	+ thus ?thesis
	+ unfolding HoHV_def HoVH_def
	+ using x VVV.ideD(1) by simp
	+ qed
	+ qed
	+ show "\<And>f. VVV.arr f \<Longrightarrow>
	+ \<a>[fst (VVV.cod f), fst (snd (VVV.cod f)), snd (snd (VVV.cod f))] \<cdot> HoHV f =
	+ HoVH f \<cdot> \<a>[fst (VVV.dom f), fst (snd (VVV.dom f)), snd (snd (VVV.dom f))]"
	+ unfolding HoHV_def HoVH_def
	+ using assoc_naturality\<^sub>A\<^sub>W\<^sub>C VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char
	+ composable_char\<^sub>P\<^sub>B\<^sub>H
	+ by simp
	+ qed
	+ interpret \<alpha>: natural_isomorphism VVV.comp V HoHV HoVH \<alpha>.map
	+ proof
	+ fix f
	+ assume f: "VVV.ide f"
	+ show "iso (\<alpha>.map f)"
	+ proof -
	+ have "fst f \<star> fst (snd f) \<noteq> null \<and> fst (snd f) \<star> snd (snd f) \<noteq> null"
	+ using f VVV.ideD(1) VVV.arr_char [of f] VV.arr_char composable_char\<^sub>P\<^sub>B\<^sub>H by auto
	+ thus ?thesis
	+ using f \<alpha>.map_simp_ide iso_assoc\<^sub>A\<^sub>W\<^sub>C VVV.ide_char VVV.arr_char by simp
	+ qed
	+ qed
	+ have "(\<lambda>\<mu>\<nu>\<tau>. \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))) = \<alpha>.map"
	+ proof
	+ fix \<mu>\<nu>\<tau>
	+ have "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) = \<alpha>.map \<mu>\<nu>\<tau>"
	+ using \<alpha>_def \<alpha>.map_def by simp
	+ moreover have "VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow>
	+ \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) = \<alpha>.map \<mu>\<nu>\<tau>"
	+ proof -
	+ assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
	+ have "\<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) =
	+ (fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>) \<star> snd (snd \<mu>\<nu>\<tau>)) \<cdot>
	+ \<a>[dom (fst \<mu>\<nu>\<tau>), dom (fst (snd \<mu>\<nu>\<tau>)), dom (snd (snd \<mu>\<nu>\<tau>))]"
	+ using \<mu>\<nu>\<tau> \<alpha>_def by simp
	+ also have "... = \<a>[cod (fst \<mu>\<nu>\<tau>), cod (fst (snd \<mu>\<nu>\<tau>)), cod (snd (snd \<mu>\<nu>\<tau>))] \<cdot>
	+ ((fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>)) \<star> snd (snd \<mu>\<nu>\<tau>))"
	+ using \<mu>\<nu>\<tau> HoHV_def HoVH_def VVV.arr_char VV.arr_char assoc_naturality\<^sub>A\<^sub>W\<^sub>C
	+ composable_char\<^sub>P\<^sub>B\<^sub>H
	+ by simp
	+ also have "... =
	+ \<a>[fst (VVV.cod \<mu>\<nu>\<tau>), fst (snd (VVV.cod \<mu>\<nu>\<tau>)), snd (snd (VVV.cod \<mu>\<nu>\<tau>))] \<cdot>
	+ ((fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>)) \<star> snd (snd \<mu>\<nu>\<tau>))"
	+ using \<mu>\<nu>\<tau> VVV.arr_char VVV.cod_char VV.arr_char by simp
	+ also have "... = \<alpha>.map \<mu>\<nu>\<tau>"
	+ using \<mu>\<nu>\<tau> \<alpha>.map_def HoHV_def composable_char\<^sub>P\<^sub>B\<^sub>H by auto
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show "\<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>)) = \<alpha>.map \<mu>\<nu>\<tau>" by blast
	+ qed
	+ thus ?thesis using \<alpha>.natural_isomorphism_axioms by simp
	+ qed
	+
	+ proposition induces_bicategory:
	+ shows "bicategory V H \<alpha> \<i> src trg"
	+ proof -
	+ interpret VxVxV: product_category V VxV.comp ..
	+ interpret VoVoV: subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using subcategory_VVV by blast
	+ interpret HoHV: "functor" VVV.comp V HoHV
	+ using functor_HoHV by blast
	+ interpret HoVH: "functor" VVV.comp V HoVH
	+ using functor_HoVH by blast
	+ interpret \<alpha>: natural_isomorphism VVV.comp V HoHV HoVH
	+ \<open>\<lambda>\<mu>\<nu>\<tau>. \<alpha> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close>
	+ using natural_isomorphism_\<alpha> by blast
	+ interpret L: equivalence_functor V V L
	+ using equivalence_functor_L by blast
	+ interpret R: equivalence_functor V V R
	+ using equivalence_functor_R by blast
	+ show "bicategory V H \<alpha> \<i> src trg"
	+ proof
	+ show "\<And>a. obj a \<Longrightarrow> \<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ using obj_is_weak_unit unit_in_vhom\<^sub>P\<^sub>B\<^sub>U by blast
	+ show "\<And>a. obj a \<Longrightarrow> iso \<i>[a]"
	+ using obj_is_weak_unit iso_unit\<^sub>P\<^sub>B\<^sub>U by blast
	+ show "\<And>f g h k. \<lbrakk> ide f; ide g; ide h; ide k;
	+ src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
	+ (f \<star> \<alpha> g h k) \<cdot> \<alpha> f (g \<star> h) k \<cdot> (\<alpha> f g h \<star> k) =
	+ \<alpha> f g (h \<star> k) \<cdot> \<alpha> (f \<star> g) h k"
	+ proof -
	+ fix f g h k
	+ assume f: "ide f" and g: "ide g" and h: "ide h" and k: "ide k"
	+ and fg: "src f = trg g" and gh: "src g = trg h" and hk: "src h = trg k"
	+ have "sources f \<inter> targets g \<noteq> {}"
	+ using f g fg src_in_sources [of f] trg_in_targets ideD(1) by auto
	+ moreover have "sources g \<inter> targets h \<noteq> {}"
	+ using g h gh src_in_sources [of g] trg_in_targets ideD(1) by auto
	+ moreover have "sources h \<inter> targets k \<noteq> {}"
	+ using h k hk src_in_sources [of h] trg_in_targets ideD(1) by auto
	+ moreover have "\<alpha> f g h = \<a>[f, g, h] \<and> \<alpha> g h k = \<a>[g, h, k]"
	+ using f g h k fg gh hk \<alpha>_ide_simp by simp
	+ moreover have "\<alpha> f (g \<star> h) k = \<a>[f, g \<star> h, k] \<and> \<alpha> f g (h \<star> k) = \<a>[f, g, h \<star> k] \<and>
	+ \<alpha> (f \<star> g) h k = \<a>[f \<star> g, h, k]"
	+ using f g h k fg gh hk \<alpha>_ide_simp preserves_ide hcomp_in_hom\<^sub>P\<^sub>B\<^sub>H(1) by simp
	+ ultimately show "(f \<star> \<alpha> g h k) \<cdot> \<alpha> f (g \<star> h) k \<cdot> (\<alpha> f g h \<star> k) =
	+ \<alpha> f g (h \<star> k) \<cdot> \<alpha> (f \<star> g) h k"
	+ using f g h k fg gh hk pentagon\<^sub>A\<^sub>W\<^sub>C [of f g h k] \<alpha>_ide_simp by presburger
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ The following is the main result of this development:
	+ Every prebicategory extends to a bicategory, by making an arbitrary choice of
	+ representatives of each isomorphism class of weak units and using that to
	+ define the source and target mappings, and then choosing an arbitrary isomorphism
	+ in \<open>hom (a \<star> a) a\<close> for each weak unit \<open>a\<close>.
	+ \<close>
	+
	+ context prebicategory
	+ begin
	+
	+ interpretation prebicategory_with_homs V H \<a> some_src some_trg
	+ using extends_to_prebicategory_with_homs by auto
	+
	+ interpretation prebicategory_with_units V H \<a> some_unit
	+ using extends_to_prebicategory_with_units by auto
	+
	+ interpretation prebicategory_with_homs_and_units V H \<a> some_unit some_src some_trg ..
	+
	+ theorem extends_to_bicategory:
	+ shows "bicategory V H \<alpha> some_unit some_src some_trg"
	+ using induces_bicategory by simp
	+
	+ end
	+
	+ section "Bicategories as Prebicategories"
	+
	+ subsection "Bicategories are Prebicategories"
	+
	+ text \<open>
	+ In this section we show that a bicategory determines a prebicategory with homs,
	+ whose weak units are exactly those arrows that are isomorphic to their chosen source,
	+ or equivalently, to their chosen target.
	+ Moreover, the notion of horizontal composability, which in a bicategory is determined
	+ by the coincidence of chosen sources and targets, agrees with the version defined
	+ for the induced weak composition in terms of nonempty intersections of source and
	+ target sets, which is not dependent on any arbitrary choices.
	+ \<close>
	+
	+ context bicategory
	+ begin
	+
	+ (* TODO: Why does this get re-introduced? *)
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+
	+ interpretation \<alpha>': inverse_transformation VVV.comp V HoHV HoVH
	+ \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> ..
	+
	+ abbreviation \<alpha>'
	+ where "\<alpha>' \<equiv> \<alpha>'.map"
	+
	+ definition \<a>' ("\<a>\<^sup>-\<^sup>1[_, _, _]")
	+ where "\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] \<equiv> \<alpha>'.map (\<mu>, \<nu>, \<tau>)"
	+
	+ lemma assoc'_in_hom':
	+ assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
	+ shows "in_hhom \<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
	+ and "\<guillemotleft>\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] : dom \<mu> \<star> dom \<nu> \<star> dom \<tau> \<Rightarrow> (cod \<mu> \<star> cod \<nu>) \<star> cod \<tau>\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] : dom \<mu> \<star> dom \<nu> \<star> dom \<tau> \<Rightarrow> (cod \<mu> \<star> cod \<nu>) \<star> cod \<tau>\<guillemotright>"
	+ proof -
	+ have 1: "VVV.in_hom (\<mu>, \<nu>, \<tau>) (dom \<mu>, dom \<nu>, dom \<tau>) (cod \<mu>, cod \<nu>, cod \<tau>)"
	+ using assms VVV.in_hom_char VVV.arr_char VV.arr_char by auto
	+ have "\<guillemotleft>\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] : HoVH (dom \<mu>, dom \<nu>, dom \<tau>) \<Rightarrow> HoHV (cod \<mu>, cod \<nu>, cod \<tau>)\<guillemotright>"
	+ using 1 \<a>'_def \<alpha>'.preserves_hom by auto
	+ moreover have "HoVH (dom \<mu>, dom \<nu>, dom \<tau>) = dom \<mu> \<star> dom \<nu> \<star> dom \<tau>"
	+ using 1 HoVH_def by (simp add: VVV.in_hom_char)
	+ moreover have "HoHV (cod \<mu>, cod \<nu>, cod \<tau>) = (cod \<mu> \<star> cod \<nu>) \<star> cod \<tau>"
	+ using 1 HoHV_def by (simp add: VVV.in_hom_char)
	+ ultimately show ?thesis by simp
	+ qed
	+ thus "in_hhom \<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] (src \<tau>) (trg \<mu>)"
	+ using assms vconn_implies_hpar(1) vconn_implies_hpar(2) by auto
	+ qed
	+
	+ lemma assoc'_is_natural_1:
	+ assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
	+ shows "\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] = ((\<mu> \<star> \<nu>) \<star> \<tau>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<mu>, dom \<nu>, dom \<tau>]"
	+ using assms \<alpha>'.is_natural_1 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char
	+ VVV.dom_char HoHV_def src_dom trg_dom \<a>'_def
	+ by simp
	+
	+ lemma assoc'_is_natural_2:
	+ assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
	+ shows "\<a>\<^sup>-\<^sup>1[\<mu>, \<nu>, \<tau>] = \<a>\<^sup>-\<^sup>1[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> (\<mu> \<star> \<nu> \<star> \<tau>)"
	+ using assms \<alpha>'.is_natural_2 [of "(\<mu>, \<nu>, \<tau>)"] VVV.arr_char VV.arr_char
	+ VVV.cod_char HoVH_def src_dom trg_dom \<a>'_def
	+ by simp
	+
	+ lemma assoc'_naturality:
	+ assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>" and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
	+ shows "\<a>\<^sup>-\<^sup>1[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> (\<mu> \<star> \<nu> \<star> \<tau>) = ((\<mu> \<star> \<nu>) \<star> \<tau>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<mu>, dom \<nu>, dom \<tau>]"
	+ using assms assoc'_is_natural_1 assoc'_is_natural_2 by metis
	+
	+ lemma assoc'_in_hom [intro]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "in_hhom \<a>\<^sup>-\<^sup>1[f, g, h] (src h) (trg f)"
	+ and "\<guillemotleft>\<a>\<^sup>-\<^sup>1[f, g, h] : dom f \<star> dom g \<star> dom h \<Rightarrow> (cod f \<star> cod g) \<star> cod h\<guillemotright>"
	+ using assms assoc'_in_hom'(1-2) ideD(1) by meson+
	+
	+ lemma assoc'_simps [simp]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "arr \<a>\<^sup>-\<^sup>1[f, g, h]"
	+ and "src \<a>\<^sup>-\<^sup>1[f, g, h] = src h" and "trg \<a>\<^sup>-\<^sup>1[f, g, h] = trg f"
	+ and "dom \<a>\<^sup>-\<^sup>1[f, g, h] = dom f \<star> dom g \<star> dom h"
	+ and "cod \<a>\<^sup>-\<^sup>1[f, g, h] = (cod f \<star> cod g) \<star> cod h"
	+ using assms assoc'_in_hom by blast+
	+
	+ lemma assoc'_eq_inv_assoc [simp]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "\<a>\<^sup>-\<^sup>1[f, g, h] = inv \<a>[f, g, h]"
	+ using assms VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char \<alpha>'.map_ide_simp
	+ \<a>'_def
	+ by auto
	+
	+ lemma inverse_assoc_assoc' [intro]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "inverse_arrows \<a>[f, g, h] \<a>\<^sup>-\<^sup>1[f, g, h]"
	+ using assms VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char \<alpha>'.map_ide_simp
	+ \<alpha>'.inverts_components \<a>'_def
	+ by auto
	+
	+ lemma iso_assoc' [intro, simp]:
	+ assumes "ide f" and "ide g" and "ide h"
	+ and "src f = trg g" and "src g = trg h"
	+ shows "iso \<a>\<^sup>-\<^sup>1[f, g, h]"
	+ using assms iso_inv_iso by simp
	+
	+ lemma comp_assoc_assoc' [simp]:
	+ assumes "ide f" and "ide g" and "ide h"
	+ and "src f = trg g" and "src g = trg h"
	+ shows "\<a>[f, g, h] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, h] = f \<star> g \<star> h"
	+ and "\<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> \<a>[f, g, h] = (f \<star> g) \<star> h"
	+ using assms comp_arr_inv' comp_inv_arr' by auto
	+
	+ lemma unit_in_hom [intro, simp]:
	+ assumes "obj a"
	+ shows "\<guillemotleft>\<i>[a] : a \<rightarrow> a\<guillemotright>" and "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ using assms unit_in_vhom by simp
	+ thus "\<guillemotleft>\<i>[a] : a \<rightarrow> a\<guillemotright>"
	+ using assms src_cod trg_cod by fastforce
	+ qed
	+
	+ interpretation weak_composition V H
	+ using is_weak_composition by auto
	+
	+ lemma seq_if_composable:
	+ assumes "\<nu> \<star> \<mu> \<noteq> null"
	+ shows "src \<nu> = trg \<mu>"
	+ using assms H.is_extensional [of "(\<nu>, \<mu>)"] VV.arr_char by auto
	+
	+ lemma obj_self_composable:
	+ assumes "obj a"
	+ shows "a \<star> a \<noteq> null"
	+ and "isomorphic (a \<star> a) a"
	+ proof -
	+ show 1: "isomorphic (a \<star> a) a"
	+ using assms unit_in_hom iso_unit isomorphic_def by blast
	+ obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ using 1 isomorphic_def by blast
	+ have "ide (a \<star> a)" using 1 \<phi> ide_dom [of \<phi>] by fastforce
	+ thus "a \<star> a \<noteq> null" using ideD(1) not_arr_null by metis
	+ qed
	+
	+ lemma obj_is_weak_unit:
	+ assumes "obj a"
	+ shows "weak_unit a"
	+ proof -
	+ interpret Left_a: subcategory V \<open>left a\<close>
	+ using assms left_hom_is_subcategory by force
	+ interpret Right_a: subcategory V \<open>right a\<close>
	+ using assms right_hom_is_subcategory by force
	+
	+ text \<open>
	+ We know that \<open>H\<^sub>L a\<close> is fully faithful as a global endofunctor,
	+ but the definition of weak unit involves its restriction to a
	+ subcategory. So we have to verify that the restriction
	+ is also a fully faithful functor.
	+ \<close>
	+
	+ interpret La: endofunctor \<open>Left a\<close> \<open>H\<^sub>L a\<close>
	+ using assms obj_self_composable endofunctor_H\<^sub>L [of a] by force
	+ interpret La: fully_faithful_functor \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close>
	+ proof
	+ show "\<And>f f'. Left_a.par f f' \<Longrightarrow> H\<^sub>L a f = H\<^sub>L a f' \<Longrightarrow> f = f'"
	+ proof -
	+ fix \<mu> \<mu>'
	+ assume par: "Left_a.par \<mu> \<mu>'"
	+ assume eq: "H\<^sub>L a \<mu> = H\<^sub>L a \<mu>'"
	+ have 1: "par \<mu> \<mu>'"
	+ using par Left_a.arr_char Left_a.dom_char Left_a.cod_char left_def
	+ composable_implies_arr null_agreement
	+ by metis
	+ moreover have "L \<mu> = L \<mu>'"
	+ using par eq H\<^sub>L_def Left_a.arr_char left_def preserves_arr
	+ assms 1 seq_if_composable [of a \<mu>] not_arr_null seq_if_composable [of a \<mu>']
	+ by auto
	+ ultimately show "\<mu> = \<mu>'"
	+ using L.is_faithful by blast
	+ qed
	+ show "\<And>f g \<mu>. \<lbrakk> Left_a.ide f; Left_a.ide g; Left_a.in_hom \<mu> (H\<^sub>L a f) (H\<^sub>L a g) \<rbrakk> \<Longrightarrow>
	+ \<exists>\<nu>. Left_a.in_hom \<nu> f g \<and> H\<^sub>L a \<nu> = \<mu>"
	+ proof -
	+ fix f g \<mu>
	+ assume f: "Left_a.ide f" and g: "Left_a.ide g"
	+ and \<mu>: "Left_a.in_hom \<mu> (H\<^sub>L a f) (H\<^sub>L a g)"
	+ have 1: "a = trg f \<and> a = trg g"
	+ using assms f g Left_a.ide_char Left_a.arr_char left_def seq_if_composable [of a f]
	+ seq_if_composable [of a g]
	+ by auto
	+ show "\<exists>\<nu>. Left_a.in_hom \<nu> f g \<and> H\<^sub>L a \<nu> = \<mu>"
	+ proof -
	+ have 2: "\<exists>\<nu>. \<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> L \<nu> = \<mu>"
	+ using f g \<mu> 1 Left_a.ide_char H\<^sub>L_def L.preserves_reflects_arr Left_a.arr_char
	+ Left_a.in_hom_char L.is_full
	+ by force
	+ obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> L \<nu> = \<mu>"
	+ using 2 by blast
	+ have "Left_a.arr \<nu>"
	+ using \<nu> 1 trg_dom Left_a.arr_char left_def hseq_char' by fastforce
	+ moreover have "H\<^sub>L a \<nu> = \<mu>"
	+ using \<nu> 1 trg_dom H\<^sub>L_def by auto
	+ ultimately show ?thesis
	+ using \<nu> by force
	+ qed
	+ qed
	+ qed
	+ interpret Ra: endofunctor \<open>Right a\<close> \<open>H\<^sub>R a\<close>
	+ using assms obj_self_composable endofunctor_H\<^sub>R [of a] by force
	+ interpret Ra: fully_faithful_functor \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close>
	+ proof
	+ show "\<And>f f'. Right_a.par f f' \<Longrightarrow> H\<^sub>R a f = H\<^sub>R a f' \<Longrightarrow> f = f'"
	+ proof -
	+ fix \<mu> \<mu>'
	+ assume par: "Right_a.par \<mu> \<mu>'"
	+ assume eq: "H\<^sub>R a \<mu> = H\<^sub>R a \<mu>'"
	+ have 1: "par \<mu> \<mu>'"
	+ using par Right_a.arr_char Right_a.dom_char Right_a.cod_char right_def
	+ composable_implies_arr null_agreement
	+ by metis
	+ moreover have "R \<mu> = R \<mu>'"
	+ using par eq H\<^sub>R_def Right_a.arr_char right_def preserves_arr
	+ assms 1 seq_if_composable [of \<mu> a] not_arr_null seq_if_composable [of \<mu>' a]
	+ by auto
	+ ultimately show "\<mu> = \<mu>'"
	+ using R.is_faithful by blast
	+ qed
	+ show "\<And>f g \<mu>. \<lbrakk> Right_a.ide f; Right_a.ide g; Right_a.in_hom \<mu> (H\<^sub>R a f) (H\<^sub>R a g) \<rbrakk> \<Longrightarrow>
	+ \<exists>\<nu>. Right_a.in_hom \<nu> f g \<and> H\<^sub>R a \<nu> = \<mu>"
	+ proof -
	+ fix f g \<mu>
	+ assume f: "Right_a.ide f" and g: "Right_a.ide g"
	+ and \<mu>: "Right_a.in_hom \<mu> (H\<^sub>R a f) (H\<^sub>R a g)"
	+ have 1: "a = src f \<and> a = src g"
	+ using assms f g Right_a.ide_char Right_a.arr_char right_def seq_if_composable
	+ by auto
	+ show "\<exists>\<nu>. Right_a.in_hom \<nu> f g \<and> H\<^sub>R a \<nu> = \<mu>"
	+ proof -
	+ have 2: "\<exists>\<nu>. \<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> R \<nu> = \<mu>"
	+ using f g \<mu> 1 Right_a.ide_char H\<^sub>R_def R.preserves_reflects_arr Right_a.arr_char
	+ Right_a.in_hom_char R.is_full
	+ by force
	+ obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : f \<Rightarrow> g\<guillemotright> \<and> R \<nu> = \<mu>"
	+ using 2 by blast
	+ have "Right_a.arr \<nu>"
	+ using \<nu> 1 src_dom Right_a.arr_char right_def hseq_char' by fastforce
	+ moreover have "H\<^sub>R a \<nu> = \<mu>"
	+ using \<nu> 1 src_dom H\<^sub>R_def by auto
	+ ultimately show ?thesis
	+ using \<nu> by force
	+ qed
	+ qed
	+ qed
	+ have "isomorphic (a \<star> a) a \<and> a \<star> a \<noteq> null"
	+ using assms obj_self_composable unit_in_hom iso_unit isomorphic_def by blast
	+ thus ?thesis
	+ using La.fully_faithful_functor_axioms Ra.fully_faithful_functor_axioms weak_unit_def
	+ by blast
	+ qed
	+
	+ lemma src_in_sources:
	+ assumes "arr \<mu>"
	+ shows "src \<mu> \<in> sources \<mu>"
	+ using assms obj_is_weak_unit R.preserves_arr hseq_char' by auto
	+
	+ lemma trg_in_targets:
	+ assumes "arr \<mu>"
	+ shows "trg \<mu> \<in> targets \<mu>"
	+ using assms obj_is_weak_unit L.preserves_arr hseq_char' by auto
	+
	+ lemma weak_unit_cancel_left:
	+ assumes "weak_unit a" and "ide f" and "ide g"
	+ and "a \<star> f \<cong> a \<star> g"
	+ shows "f \<cong> g"
	+ proof -
	+ have 0: "ide a"
	+ using assms weak_unit_def by force
	+ interpret Left_a: subcategory V \<open>left a\<close>
	+ using 0 left_hom_is_subcategory by simp
	+ interpret Left_a: left_hom V H a
	+ using assms by unfold_locales auto
	+ interpret La: fully_faithful_functor \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close>
	+ using assms weak_unit_def by fast
	+ obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> f \<Rightarrow> a \<star> g\<guillemotright>"
	+ using assms by blast
	+ have 1: "Left_a.iso \<phi> \<and> Left_a.in_hom \<phi> (a \<star> f) (a \<star> g)"
	+ proof
	+ have "a \<star> \<phi> \<noteq> null"
	+ proof -
	+ have "a \<star> dom \<phi> \<noteq> null"
	+ using assms \<phi> weak_unit_self_composable
	+ by (metis arr_dom_iff_arr hseq_char' in_homE match_4)
	+ thus ?thesis
	+ using hom_connected by simp
	+ qed
	+ thus "Left_a.in_hom \<phi> (a \<star> f) (a \<star> g)"
	+ using \<phi> Left_a.hom_char left_def by auto
	+ thus "Left_a.iso \<phi>"
	+ using \<phi> Left_a.iso_char by auto
	+ qed
	+ hence 2: "Left_a.ide (a \<star> f) \<and> Left_a.ide (a \<star> g)"
	+ using Left_a.ide_dom [of \<phi>] Left_a.ide_cod [of \<phi>] by auto
	+ hence 3: "Left_a.ide f \<and> Left_a.ide g"
	+ by (metis Left_a.ideI Left_a.ide_def Left_a.null_char assms(2) assms(3) left_def)
	+ obtain \<psi> where \<psi>: "\<psi> \<in> Left_a.hom f g \<and> a \<star> \<psi> = \<phi>"
	+ using assms 1 2 3 La.is_full [of g f \<phi>] H\<^sub>L_def by auto
	+ have "Left_a.iso \<psi>"
	+ using \<psi> 1 H\<^sub>L_def La.reflects_iso by auto
	+ hence "iso \<psi> \<and> \<guillemotleft>\<psi> : f \<Rightarrow> g\<guillemotright>"
	+ using \<psi> Left_a.iso_char Left_a.in_hom_char by auto
	+ thus ?thesis by auto
	+ qed
	+
	+ lemma weak_unit_cancel_right:
	+ assumes "weak_unit a" and "ide f" and "ide g"
	+ and "f \<star> a \<cong> g \<star> a"
	+ shows "f \<cong> g"
	+ proof -
	+ have 0: "ide a"
	+ using assms weak_unit_def by force
	+ interpret Right_a: subcategory V \<open>right a\<close>
	+ using 0 right_hom_is_subcategory by simp
	+ interpret Right_a: right_hom V H a
	+ using assms by unfold_locales auto
	+ interpret R: fully_faithful_functor \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close>
	+ using assms weak_unit_def by fast
	+ obtain \<phi> where \<phi>: "iso \<phi> \<and> in_hom \<phi> (f \<star> a) (g \<star> a)"
	+ using assms by blast
	+ have 1: "Right_a.iso \<phi> \<and> \<phi> \<in> Right_a.hom (f \<star> a) (g \<star> a)"
	+ proof
	+ have "\<phi> \<star> a \<noteq> null"
	+ proof -
	+ have "dom \<phi> \<star> a \<noteq> null"
	+ using assms \<phi> weak_unit_self_composable
	+ by (metis arr_dom_iff_arr hseq_char' in_homE match_3)
	+ thus ?thesis
	+ using hom_connected by simp
	+ qed
	+ thus "\<phi> \<in> Right_a.hom (f \<star> a) (g \<star> a)"
	+ using \<phi> Right_a.hom_char right_def by simp
	+ thus "Right_a.iso \<phi>"
	+ using \<phi> Right_a.iso_char by auto
	+ qed
	+ hence 2: "Right_a.ide (f \<star> a) \<and> Right_a.ide (g \<star> a)"
	+ using Right_a.ide_dom [of \<phi>] Right_a.ide_cod [of \<phi>] by auto
	+ hence 3: "Right_a.ide f \<and> Right_a.ide g"
	+ using assms Right_a.ide_char Right_a.arr_char right_def Right_a.ide_def Right_a.null_char
	+ by metis
	+ obtain \<psi> where \<psi>: "\<psi> \<in> Right_a.hom f g \<and> \<psi> \<star> a = \<phi>"
	+ using assms 1 2 3 R.is_full [of g f \<phi>] H\<^sub>R_def by auto
	+ have "Right_a.iso \<psi>"
	+ using \<psi> 1 H\<^sub>R_def R.reflects_iso by auto
	+ hence "iso \<psi> \<and> \<guillemotleft>\<psi> : f \<Rightarrow> g\<guillemotright>"
	+ using \<psi> Right_a.iso_char Right_a.in_hom_char by auto
	+ thus ?thesis by auto
	+ qed
	+
	+ text \<open>
	+ All sources of an arrow ({\em i.e.}~weak units composable on the right with that arrow)
	+ are isomorphic to the chosen source, and similarly for targets. That these statements
	+ hold was somewhat surprising to me.
	+ \<close>
	+
	+ lemma source_iso_src:
	+ assumes "arr \<mu>" and "a \<in> sources \<mu>"
	+ shows "a \<cong> src \<mu>"
	+ proof -
	+ have 0: "ide a"
	+ using assms weak_unit_def by force
	+ have 1: "src a = trg a"
	+ using assms ide_dom sources_def weak_unit_iff_self_target seq_if_composable
	+ by simp
	+ obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ using assms weak_unit_def by blast
	+ have "a \<star> src a \<cong> src a \<star> src a"
	+ proof -
	+ have "src a \<cong> src a \<star> src a"
	+ using 0 obj_is_weak_unit weak_unit_def isomorphic_symmetric by auto
	+ moreover have "a \<star> src a \<cong> src a"
	+ proof -
	+ have "a \<star> a \<star> src a \<cong> a \<star> src a"
	+ proof -
	+ have "iso (\<phi> \<star> src a) \<and> \<guillemotleft>\<phi> \<star> src a : (a \<star> a) \<star> src a \<Rightarrow> a \<star> src a\<guillemotright>"
	+ using 0 1 \<phi> ide_in_hom(2) by auto
	+ moreover have "iso \<a>\<^sup>-\<^sup>1[a, a, src a] \<and>
	+ \<guillemotleft>\<a>\<^sup>-\<^sup>1[a, a, src a] : a \<star> a \<star> src a \<Rightarrow> (a \<star> a) \<star> src a\<guillemotright>"
	+ using 0 1 iso_assoc' by force
	+ ultimately show ?thesis
	+ using isos_compose isomorphic_def by auto
	+ qed
	+ thus ?thesis
	+ using assms 0 weak_unit_cancel_left by auto
	+ qed
	+ ultimately show ?thesis
	+ using isomorphic_transitive by meson
	+ qed
	+ hence "a \<cong> src a"
	+ using 0 weak_unit_cancel_right [of "src a" a "src a"] obj_is_weak_unit by auto
	+ thus ?thesis using assms seq_if_composable 1 by auto
	+ qed
	+
	+ lemma target_iso_trg:
	+ assumes "arr \<mu>" and "b \<in> targets \<mu>"
	+ shows "b \<cong> trg \<mu>"
	+ proof -
	+ have 0: "ide b"
	+ using assms weak_unit_def by force
	+ have 1: "trg \<mu> = src b"
	+ using assms seq_if_composable by auto
	+ obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : b \<star> b \<Rightarrow> b\<guillemotright>"
	+ using assms weak_unit_def by blast
	+ have "trg b \<star> b \<cong> trg b \<star> trg b"
	+ proof -
	+ have "trg b \<cong> trg b \<star> trg b"
	+ using 0 obj_is_weak_unit weak_unit_def isomorphic_symmetric by auto
	+ moreover have "trg b \<star> b \<cong> trg b"
	+ proof -
	+ have "(trg b \<star> b) \<star> b \<cong> trg b \<star> b"
	+ proof -
	+ have "iso (trg b \<star> \<phi>) \<and> \<guillemotleft>trg b \<star> \<phi> : trg b \<star> b \<star> b \<Rightarrow> trg b \<star> b\<guillemotright>"
	+ using assms 0 1 \<phi> ide_in_hom(2) targetsD(1) hseqI' by auto
	+ moreover have "iso \<a>[trg b, b, b] \<and>
	+ \<guillemotleft>\<a>[trg b, b, b] : (trg b \<star> b) \<star> b \<Rightarrow> trg b \<star> b \<star> b\<guillemotright>"
	+ using assms(2) 0 1 seq_if_composable targetsD(1-2) by auto
	+ ultimately show ?thesis
	+ using isos_compose isomorphic_def by auto
	+ qed
	+ thus ?thesis
	+ using assms 0 weak_unit_cancel_right by auto
	+ qed
	+ ultimately show ?thesis
	+ using isomorphic_transitive by meson
	+ qed
	+ hence "b \<cong> trg b"
	+ using 0 weak_unit_cancel_left [of "trg b" b "trg b"] obj_is_weak_unit by simp
	+ thus ?thesis
	+ using assms 0 1 seq_if_composable weak_unit_iff_self_source targetsD(1-2) source_iso_src
	+ by simp
	+ qed
	+
	+ lemma is_weak_composition_with_homs:
	+ shows "weak_composition_with_homs V H src trg"
	+ using src_in_sources trg_in_targets seq_if_composable composable_implies_arr
	+ by (unfold_locales, simp_all)
	+
	+ interpretation weak_composition_with_homs V H src trg
	+ using is_weak_composition_with_homs by auto
	+
	+ text \<open>
	+ In a bicategory, the notion of composability defined in terms of
	+ the chosen sources and targets coincides with the version defined
	+ for a weak composition, which does not involve particular choices.
	+ \<close>
	+
	+ lemma connected_iff_seq:
	+ assumes "arr \<mu>" and "arr \<nu>"
	+ shows "sources \<nu> \<inter> targets \<mu> \<noteq> {} \<longleftrightarrow> src \<nu> = trg \<mu>"
	+ proof
	+ show "src \<nu> = trg \<mu> \<Longrightarrow> sources \<nu> \<inter> targets \<mu> \<noteq> {}"
	+ using assms src_in_sources [of \<nu>] trg_in_targets [of \<mu>] by auto
	+ show "sources \<nu> \<inter> targets \<mu> \<noteq> {} \<Longrightarrow> src \<nu> = trg \<mu>"
	+ proof -
	+ assume 1: "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
	+ obtain a where a: "a \<in> sources \<nu> \<inter> targets \<mu>"
	+ using assms 1 by blast
	+ have \<mu>: "arr \<mu>"
	+ using a composable_implies_arr by auto
	+ have \<nu>: "arr \<nu>"
	+ using a composable_implies_arr by auto
	+ have 1: "\<And>a'. a' \<in> sources \<nu> \<Longrightarrow> src a' = src a \<and> trg a' = trg a"
	+ proof
	+ fix a'
	+ assume a': "a' \<in> sources \<nu>"
	+ have 1: "a' \<cong> a"
	+ using a a' \<nu> src_dom sources_dom source_iso_src isomorphic_transitive
	+ isomorphic_symmetric
	+ by (meson IntD1)
	+ obtain \<phi> where \<phi>: "iso \<phi> \<and> \<phi> \<in> hom a' a"
	+ using 1 by auto
	+ show "src a' = src a"
	+ using \<phi> src_dom src_cod by auto
	+ show "trg a' = trg a"
	+ using \<phi> trg_dom trg_cod by auto
	+ qed
	+ have 2: "\<And>a'. a' \<in> targets \<mu> \<Longrightarrow> src a' = src a \<and> trg a' = trg a"
	+ proof
	+ fix a'
	+ assume a': "a' \<in> targets \<mu>"
	+ have 1: "a' \<cong> a"
	+ using a a' \<mu> trg_dom targets_dom target_iso_trg isomorphic_transitive
	+ isomorphic_symmetric
	+ by (meson IntD2)
	+ obtain \<phi> where \<phi>: "iso \<phi> \<and> \<phi> \<in> hom a' a"
	+ using 1 by auto
	+ show "src a' = src a"
	+ using \<phi> src_dom src_cod by auto
	+ show "trg a' = trg a"
	+ using \<phi> trg_dom trg_cod by auto
	+ qed
	+ have "src \<nu> = src (src \<nu>)" using \<nu> by simp
	+ also have "... = src (trg \<mu>)"
	+ using \<nu> 1 [of "src \<nu>"] src_in_sources a weak_unit_self_composable seq_if_composable
	+ by auto
	+ also have "... = trg (trg \<mu>)" using \<mu> by simp
	+ also have "... = trg \<mu>" using \<mu> by simp
	+ finally show "src \<nu> = trg \<mu>" by blast
	+ qed
	+ qed
	+
	+ lemma is_associative_weak_composition:
	+ shows "associative_weak_composition V H \<a>"
	+ proof -
	+ have 1: "\<And>\<nu> \<mu>. \<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> src \<nu> = trg \<mu>"
	+ using H.is_extensional VV.arr_char by force
	+ show "associative_weak_composition V H \<a>"
	+ proof
	+ show "\<And>f g h. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> f \<star> g \<noteq> null \<Longrightarrow> g \<star> h \<noteq> null \<Longrightarrow>
	+ \<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
	+ using 1 by auto
	+ show "\<And>f g h. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> f \<star> g \<noteq> null \<Longrightarrow> g \<star> h \<noteq> null \<Longrightarrow>
	+ iso \<a>[f, g, h]"
	+ using 1 iso_assoc by presburger
	+ show "\<And>\<tau> \<mu> \<nu>. \<tau> \<star> \<mu> \<noteq> null \<Longrightarrow> \<mu> \<star> \<nu> \<noteq> null \<Longrightarrow>
	+ \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) = (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ using 1 assoc_naturality hseq_char hseq_char' by metis
	+ show "\<And>f g h k. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> ide k \<Longrightarrow>
	+ sources f \<inter> targets g \<noteq> {} \<Longrightarrow>
	+ sources g \<inter> targets h \<noteq> {} \<Longrightarrow>
	+ sources h \<inter> targets k \<noteq> {} \<Longrightarrow>
	+ (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k) =
	+ \<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k]"
	+ using 1 connected_iff_seq pentagon ideD(1) by auto
	+ qed
	+ qed
	+
	+ interpretation associative_weak_composition V H \<a>
	+ using is_associative_weak_composition by auto
	+
	+ theorem is_prebicategory:
	+ shows "prebicategory V H \<a>"
	+ using src_in_sources trg_in_targets by (unfold_locales, auto)
	+
	+ interpretation prebicategory V H \<a>
	+ using is_prebicategory by auto
	+
	+ corollary is_prebicategory_with_homs:
	+ shows "prebicategory_with_homs V H \<a> src trg"
	+ ..
	+
	+ interpretation prebicategory_with_homs V H \<a> src trg
	+ using is_prebicategory_with_homs by auto
	+
	+ text \<open>
	+ In a bicategory, an arrow is a weak unit if and only if it is
	+ isomorphic to its chosen source (or to its chosen target).
	+ \<close>
	+
	+ lemma weak_unit_char:
	+ shows "weak_unit a \<longleftrightarrow> a \<cong> src a"
	+ and "weak_unit a \<longleftrightarrow> a \<cong> trg a"
	+ proof -
	+ show "weak_unit a \<longleftrightarrow> a \<cong> src a"
	+ using isomorphism_respects_weak_units isomorphic_symmetric
	+ by (meson ideD(1) isomorphic_implies_ide(2) obj_is_weak_unit obj_src source_iso_src
	+ weak_unit_iff_self_source weak_unit_self_composable(1))
	+ show "weak_unit a \<longleftrightarrow> a \<cong> trg a"
	+ using isomorphism_respects_weak_units isomorphic_symmetric
	+ by (metis \<open>weak_unit a = isomorphic a (src a)\<close> ideD(1) isomorphic_implies_hpar(3)
	+ isomorphic_implies_ide(1) src_trg target_iso_trg weak_unit_iff_self_target)
	+ qed
	+
	+ interpretation H: partial_magma H
	+ using is_partial_magma by auto
	+
	+ text \<open>
	+ Every arrow with respect to horizontal composition is also an arrow with respect
	+ to vertical composition. The converse is not necessarily true.
	+ \<close>
	+
	+ lemma harr_is_varr:
	+ assumes "H.arr \<mu>"
	+ shows "arr \<mu>"
	+ proof -
	+ have "H.domains \<mu> \<noteq> {} \<Longrightarrow> arr \<mu>"
	+ proof -
	+ assume 1: "H.domains \<mu> \<noteq> {}"
	+ obtain a where a: "H.ide a \<and> \<mu> \<star> a \<noteq> null"
	+ using 1 H.domains_def by auto
	+ show "arr \<mu>"
	+ using a hseq_char' H.ide_def by blast
	+ qed
	+ moreover have "H.codomains \<mu> \<noteq> {} \<Longrightarrow> arr \<mu>"
	+ proof -
	+ assume 1: "H.codomains \<mu> \<noteq> {}"
	+ obtain a where a: "H.ide a \<and> a \<star> \<mu> \<noteq> null"
	+ using 1 H.codomains_def by auto
	+ show "arr \<mu>"
	+ using a hseq_char' ide_def by blast
	+ qed
	+ ultimately show ?thesis using assms H.arr_def by auto
	+ qed
	+
	+ text \<open>
	+ An identity for horizontal composition is also an identity for vertical composition.
	+ \<close>
	+
	+ lemma horizontal_identity_is_ide:
	+ assumes "H.ide \<mu>"
	+ shows "ide \<mu>"
	+ proof -
	+ have \<mu>: "arr \<mu>"
	+ using assms H.ide_def composable_implies_arr(2) by auto
	+ hence 1: "\<mu> \<star> dom \<mu> \<noteq> null"
	+ using assms hom_connected H.ide_def by auto
	+ have "\<mu> \<star> dom \<mu> = dom \<mu>"
	+ using assms 1 H.ide_def by simp
	+ moreover have "\<mu> \<star> dom \<mu> = \<mu>"
	+ using assms 1 H.ide_def [of \<mu>] null_agreement
	+ by (metis \<mu> cod_cod cod_dom hcomp_simps\<^sub>W\<^sub>C(3) ideD(2) ide_char' paste_1)
	+ ultimately have "dom \<mu> = \<mu>"
	+ by simp
	+ thus ?thesis
	+ using \<mu> by (metis ide_dom)
	+ qed
	+
	+ text \<open>
	+ Every identity for horizontal composition is a weak unit.
	+ \<close>
	+
	+ lemma horizontal_identity_is_weak_unit:
	+ assumes "H.ide \<mu>"
	+ shows "weak_unit \<mu>"
	+ using assms weak_unit_char
	+ by (metis H.ide_def comp_target_ide horizontal_identity_is_ide ideD(1)
	+ isomorphism_respects_weak_units null_agreement targetsD(2-3) trg_in_targets)
	+
	+ end
	+
	+ subsection "Vertically Discrete Bicategories are Categories"
	+
	+ text \<open>
	+ In this section we show that if a bicategory is discrete with respect to vertical
	+ composition, then it is a category with respect to horizontal composition.
	+ To obtain this result, we need to establish that the set of arrows for the horizontal
	+ composition coincides with the set of arrows for the vertical composition.
	+ This is not true for a general bicategory, and even with the assumption that the
	+ vertical category is discrete it is not immediately obvious from the definitions.
	+ The issue is that the notion ``arrow'' for the horizontal composition is defined
	+ in terms of the existence of ``domains'' and ``codomains'' with respect to that
	+ composition, whereas the axioms for a bicategory only relate the notion ``arrow''
	+ for the vertical category to the existence of sources and targets with respect
	+ to the horizontal composition.
	+ So we have to establish that, under the assumption of vertical discreteness,
	+ sources coincide with domains and targets coincide with codomains.
	+ We also need the fact that horizontal identities are weak units, which previously
	+ required some effort to show.
	+ \<close>
	+
	+ locale vertically_discrete_bicategory =
	+ bicategory +
	+ assumes vertically_discrete: "ide = arr"
	+ begin
	+
	+ interpretation prebicategory_with_homs V H \<a> src trg
	+ using is_prebicategory_with_homs by auto
	+
	+ interpretation H: partial_magma H
	+ using is_partial_magma(1) by auto
	+
	+ lemma weak_unit_is_horizontal_identity:
	+ assumes "weak_unit a"
	+ shows "H.ide a"
	+ proof -
	+ have "a \<star> a \<noteq> H.null"
	+ using assms by simp
	+ moreover have "\<And>f. f \<star> a \<noteq> H.null \<Longrightarrow> f \<star> a = f"
	+ proof -
	+ fix f
	+ assume "f \<star> a \<noteq> H.null"
	+ hence "f \<star> a \<cong> f"
	+ using assms comp_ide_source composable_implies_arr(2) sourcesI vertically_discrete
	+ by auto
	+ thus "f \<star> a = f"
	+ using vertically_discrete isomorphic_def by auto
	+ qed
	+ moreover have "\<And>f. a \<star> f \<noteq> H.null \<Longrightarrow> a \<star> f = f"
	+ proof -
	+ fix f
	+ assume "a \<star> f \<noteq> H.null"
	+ hence "a \<star> f \<cong> f"
	+ using assms comp_target_ide composable_implies_arr(1) targetsI vertically_discrete
	+ by auto
	+ thus "a \<star> f = f"
	+ using vertically_discrete isomorphic_def by auto
	+ qed
	+ ultimately show "H.ide a"
	+ using H.ide_def by simp
	+ qed
	+
	+ lemma sources_eq_domains:
	+ shows "sources \<mu> = H.domains \<mu>"
	+ using weak_unit_is_horizontal_identity H.domains_def sources_def
	+ horizontal_identity_is_weak_unit
	+ by auto
	+
	+ lemma targets_eq_codomains:
	+ shows "targets \<mu> = H.codomains \<mu>"
	+ using weak_unit_is_horizontal_identity H.codomains_def targets_def
	+ horizontal_identity_is_weak_unit
	+ by auto
	+
	+ lemma arr_agreement:
	+ shows "arr = H.arr"
	+ using arr_def H.arr_def arr_iff_has_src arr_iff_has_trg
	+ sources_eq_domains targets_eq_codomains
	+ by auto
	+
	+ interpretation H: category H
	+ proof
	+ show "\<And>g f. g \<star> f \<noteq> H.null \<Longrightarrow> H.seq g f"
	+ using arr_agreement hcomp_simps\<^sub>W\<^sub>C(1) by auto
	+ show "\<And>f. (H.domains f \<noteq> {}) = (H.codomains f \<noteq> {})"
	+ using sources_eq_domains targets_eq_codomains arr_iff_has_src arr_iff_has_trg
	+ by simp
	+ fix f g h
	+ show "H.seq h g \<Longrightarrow> H.seq (h \<star> g) f \<Longrightarrow> H.seq g f"
	+ using null_agreement arr_agreement H.not_arr_null preserves_arr VoV.arr_char
	+ by (metis hseq_char' match_1)
	+ show "H.seq h (g \<star> f) \<Longrightarrow> H.seq g f \<Longrightarrow> H.seq h g"
	+ using null_agreement arr_agreement H.not_arr_null preserves_arr VoV.arr_char
	+ by (metis hseq_char' match_2)
	+ show "H.seq g f \<Longrightarrow> H.seq h g \<Longrightarrow> H.seq (h \<star> g) f"
	+ using arr_agreement match_3 hseq_char(1) by auto
	+ show "H.seq g f \<Longrightarrow> H.seq h g \<Longrightarrow> (h \<star> g) \<star> f = h \<star> g \<star> f"
	+ proof -
	+ assume hg: "H.seq h g"
	+ assume gf: "H.seq g f"
	+ have "iso \<a>[h, g, f] \<and> \<guillemotleft>\<a>[h, g, f] : (h \<star> g) \<star> f \<Rightarrow> h \<star> g \<star> f\<guillemotright>"
	+ using hg gf vertically_discrete arr_agreement hseq_char assoc_in_hom iso_assoc
	+ by auto
	+ thus ?thesis
	+ using arr_agreement vertically_discrete by auto
	+ qed
	+ qed
	+
	+ proposition is_category:
	+ shows "category H"
	+ ..
	+
	+ end
	+
	+ subsection "Obtaining the Unitors"
	+
	+ text \<open>
	+ We now want to exploit the construction of unitors in a prebicategory with units,
	+ to obtain left and right unitors in a bicategory. However, a bicategory is not
	+ \emph{a priori} a prebicategory with units, because a bicategory only assigns unit
	+ isomorphisms to each \emph{object}, not to each weak unit. In order to apply the results
	+ about prebicategories with units to a bicategory, we first need to extend the bicategory to
	+ a prebicategory with units, by extending the mapping \<open>\<iota>\<close>, which provides a unit isomorphism
	+ for each object, to a mapping that assigns a unit isomorphism to all weak units.
	+ This extension can be made in an arbitrary way, as the values chosen for
	+ non-objects ultimately do not affect the components of the unitors at objects.
	+ \<close>
	+
	+ context bicategory
	+ begin
	+
	+ interpretation prebicategory V H \<a>
	+ using is_prebicategory by auto
	+
	+ definition \<i>'
	+ where "\<i>' a \<equiv> SOME \<phi>. iso \<phi> \<and> \<phi> \<in> hom (a \<star> a) a \<and> (obj a \<longrightarrow> \<phi> = \<i>[a])"
	+
	+ lemma \<i>'_extends_\<i>:
	+ assumes "weak_unit a"
	+ shows "iso (\<i>' a)" and "\<guillemotleft>\<i>' a : a \<star> a \<Rightarrow> a\<guillemotright>" and "obj a \<Longrightarrow> \<i>' a = \<i>[a]"
	+ proof -
	+ let ?P = "\<lambda>a \<phi>. iso \<phi> \<and> \<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright> \<and> (obj a \<longrightarrow> \<phi> = \<i>[a])"
	+ have "\<exists>\<phi>. ?P a \<phi>"
	+ using assms unit_in_hom iso_unit weak_unit_def isomorphic_def by blast
	+ hence 1: "?P a (\<i>' a)"
	+ using \<i>'_def someI_ex [of "?P a"] by simp
	+ show "iso (\<i>' a)" using 1 by simp
	+ show "\<guillemotleft>\<i>' a : a \<star> a \<Rightarrow> a\<guillemotright>" using 1 by simp
	+ show "obj a \<Longrightarrow> \<i>' a = \<i>[a]" using 1 by simp
	+ qed
	+
	+ proposition extends_to_prebicategory_with_units:
	+ shows "prebicategory_with_units V H \<a> \<i>'"
	+ using \<i>'_extends_\<i> by unfold_locales auto
	+
	+ interpretation PB: prebicategory_with_units V H \<a> \<i>'
	+ using extends_to_prebicategory_with_units by auto
	+ interpretation PB: prebicategory_with_homs V H \<a> src trg
	+ using is_prebicategory_with_homs by auto
	+ interpretation PB: prebicategory_with_homs_and_units V H \<a> \<i>' src trg ..
	+
	+ proposition extends_to_prebicategory_with_homs_and_units:
	+ shows "prebicategory_with_homs_and_units V H \<a> \<i>' src trg"
	+ ..
	+
	+ definition lunit ("\<l>[_]")
	+ where "\<l>[a] \<equiv> PB.lunit a"
	+
	+ definition runit ("\<r>[_]")
	+ where "\<r>[a] \<equiv> PB.runit a"
	+
	+ abbreviation lunit' ("\<l>\<^sup>-\<^sup>1[_]")
	+ where "\<l>\<^sup>-\<^sup>1[a] \<equiv> inv \<l>[a]"
	+
	+ abbreviation runit' ("\<r>\<^sup>-\<^sup>1[_]")
	+ where "\<r>\<^sup>-\<^sup>1[a] \<equiv> inv \<r>[a]"
	+
	+ text \<open>
	+ \sloppypar
	+ The characterizations of the left and right unitors that we obtain from locale
	+ @{locale prebicategory_with_homs_and_units} mention the arbitarily chosen extension \<open>\<i>'\<close>,
	+ rather than the given \<open>\<i>\<close>. We want ``native versions'' for the present context.
	+ \<close>
	+
	+ lemma lunit_char:
	+ assumes "ide f"
	+ shows "\<guillemotleft>\<l>[f] : L f \<Rightarrow> f\<guillemotright>" and "L \<l>[f] = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
	+ and "\<exists>!\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<and> L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
	+ proof -
	+ have 1: "trg (PB.lunit f) = trg f"
	+ using assms PB.lunit_char [of f] vconn_implies_hpar(2) vconn_implies_hpar(4)
	+ by metis
	+ show "\<guillemotleft>\<l>[f] : L f \<Rightarrow> f\<guillemotright>"
	+ unfolding lunit_def
	+ using assms PB.lunit_char by simp
	+ show "L \<l>[f] = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
	+ unfolding lunit_def
	+ using assms 1 PB.lunit_char obj_is_weak_unit \<i>'_extends_\<i> by simp
	+ let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<and> L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
	+ have "?P = (\<lambda>\<mu>. \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright> \<and>
	+ trg f \<star> \<mu> = (\<i>' (trg f) \<star> f) \<cdot> inv \<a>[trg f, trg f, f])"
	+ proof -
	+ have "\<And>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<longleftrightarrow> \<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright>"
	+ using assms by simp
	+ moreover have "\<And>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<Longrightarrow>
	+ L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f] \<longleftrightarrow>
	+ trg f \<star> \<mu> = (\<i>' (trg f) \<star> f) \<cdot> inv \<a>[trg f, trg f, f]"
	+ using calculation obj_is_weak_unit \<i>'_extends_\<i> by auto
	+ ultimately show ?thesis by blast
	+ qed
	+ thus "\<exists>!\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow> f\<guillemotright> \<and> L \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
	+ using assms PB.lunit_char by simp
	+ qed
	+
	+ lemma lunit_in_hom [intro]:
	+ assumes "ide f"
	+ shows "\<guillemotleft>\<l>[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<l>[f] : trg f \<star> f \<Rightarrow> f\<guillemotright>"
	+ using assms lunit_char by auto
	+ thus "\<guillemotleft>\<l>[f] : src f \<rightarrow> trg f\<guillemotright>"
	+ using src_cod trg_cod by fastforce
	+ qed
	+
	+ lemma lunit_in_vhom [simp]:
	+ assumes "ide f" and "trg f = b"
	+ shows "\<guillemotleft>\<l>[f] : b \<star> f \<Rightarrow> f\<guillemotright>"
	+ using assms by auto
	+
	+ lemma lunit_simps [simp]:
	+ assumes "ide f"
	+ shows "arr \<l>[f]" and "src \<l>[f] = src f" and "trg \<l>[f] = trg f"
	+ and "dom \<l>[f] = trg f \<star> f" and "cod \<l>[f] = f"
	+ using assms lunit_in_hom
	+ apply auto
	+ using assms lunit_in_hom
	+ apply blast
	+ using assms lunit_in_hom
	+ by blast
	+
	+ lemma runit_char:
	+ assumes "ide f"
	+ shows "\<guillemotleft>\<r>[f] : R f \<Rightarrow> f\<guillemotright>" and "R \<r>[f] = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
	+ and "\<exists>!\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<and> R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
	+ proof -
	+ have 1: "src (PB.runit f) = src f"
	+ using assms PB.runit_char [of f] vconn_implies_hpar(1) vconn_implies_hpar(3)
	+ by metis
	+ show "\<guillemotleft>\<r>[f] : R f \<Rightarrow> f\<guillemotright>"
	+ unfolding runit_def
	+ using assms PB.runit_char by simp
	+ show "R \<r>[f] = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
	+ unfolding runit_def
	+ using assms 1 PB.runit_char obj_is_weak_unit \<i>'_extends_\<i> by simp
	+ let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<and> R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
	+ have "?P = (\<lambda>\<mu>. \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright> \<and>
	+ \<mu> \<star> src f = (f \<star> \<i>' (src f)) \<cdot> \<a>[f, src f, src f])"
	+ proof -
	+ have "\<And>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<longleftrightarrow> \<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright>"
	+ using assms by simp
	+ moreover have "\<And>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<Longrightarrow>
	+ R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f] \<longleftrightarrow>
	+ \<mu> \<star> src f = (f \<star> \<i>' (src f)) \<cdot> \<a>[f, src f, src f]"
	+ using calculation obj_is_weak_unit \<i>'_extends_\<i> by auto
	+ ultimately show ?thesis by blast
	+ qed
	+ thus "\<exists>!\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow> f\<guillemotright> \<and> R \<mu> = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
	+ using assms PB.runit_char by simp
	+ qed
	+
	+ lemma runit_in_hom [intro]:
	+ assumes "ide f"
	+ shows "\<guillemotleft>\<r>[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>"
	+ using assms runit_char by auto
	+ thus "\<guillemotleft>\<r>[f] : src f \<rightarrow> trg f\<guillemotright>"
	+ using src_cod trg_cod by fastforce
	+ qed
	+
	+ lemma runit_in_vhom [simp]:
	+ assumes "ide f" and "src f = a"
	+ shows "\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>"
	+ using assms by auto
	+
	+ lemma runit_simps [simp]:
	+ assumes "ide f"
	+ shows "arr \<r>[f]" and "src \<r>[f] = src f" and "trg \<r>[f] = trg f"
	+ and "dom \<r>[f] = f \<star> src f" and "cod \<r>[f] = f"
	+ using assms runit_in_hom
	+ apply auto
	+ using assms runit_in_hom
	+ apply blast
	+ using assms runit_in_hom
	+ by blast
	+
	+ lemma lunit_eqI:
	+ assumes "ide f" and "\<guillemotleft>\<mu> : trg f \<star> f \<Rightarrow> f\<guillemotright>"
	+ and "trg f \<star> \<mu> = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
	+ shows "\<mu> = \<l>[f]"
	+ unfolding lunit_def
	+ using assms PB.lunit_eqI \<i>'_extends_\<i> trg.preserves_ide obj_is_weak_unit by simp
	+
	+ lemma runit_eqI:
	+ assumes "ide f" and "\<guillemotleft>\<mu> : f \<star> src f \<Rightarrow> f\<guillemotright>"
	+ and "\<mu> \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
	+ shows "\<mu> = \<r>[f]"
	+ unfolding runit_def
	+ using assms PB.runit_eqI \<i>'_extends_\<i> src.preserves_ide obj_is_weak_unit by simp
	+
	+ lemma lunit_naturality:
	+ assumes "arr \<mu>"
	+ shows "\<mu> \<cdot> \<l>[dom \<mu>] = \<l>[cod \<mu>] \<cdot> (trg \<mu> \<star> \<mu>)"
	+ unfolding lunit_def
	+ using assms PB.lunit_naturality by auto
	+
	+ lemma runit_naturality:
	+ assumes "arr \<mu>"
	+ shows "\<mu> \<cdot> \<r>[dom \<mu>] = \<r>[cod \<mu>] \<cdot> (\<mu> \<star> src \<mu>)"
	+ unfolding runit_def
	+ using assms PB.runit_naturality by auto
	+
	+ lemma iso_lunit [simp]:
	+ assumes "ide f"
	+ shows "iso \<l>[f]"
	+ unfolding lunit_def
	+ using assms PB.iso_lunit by blast
	+
	+ lemma iso_runit [simp]:
	+ assumes "ide f"
	+ shows "iso \<r>[f]"
	+ unfolding runit_def
	+ using assms PB.iso_runit by blast
	+
	+ lemma iso_lunit' [simp]:
	+ assumes "ide f"
	+ shows "iso \<l>\<^sup>-\<^sup>1[f]"
	+ using assms iso_lunit iso_inv_iso by blast
	+
	+ lemma iso_runit' [simp]:
	+ assumes "ide f"
	+ shows "iso \<r>\<^sup>-\<^sup>1[f]"
	+ using assms iso_runit iso_inv_iso by blast
	+
	+ lemma lunit'_in_hom [intro]:
	+ assumes "ide f"
	+ shows "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : f \<Rightarrow> trg f \<star> f\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : f \<Rightarrow> trg f \<star> f\<guillemotright>"
	+ using assms lunit_char iso_lunit by simp
	+ thus "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>"
	+ using assms src_dom trg_dom by simp
	+ qed
	+
	+ lemma lunit'_in_vhom [simp]:
	+ assumes "ide f" and "trg f = b"
	+ shows "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] : f \<Rightarrow> b \<star> f\<guillemotright>"
	+ using assms by auto
	+
	+ lemma lunit'_simps [simp]:
	+ assumes "ide f"
	+ shows "arr \<l>\<^sup>-\<^sup>1[f]" and "src \<l>\<^sup>-\<^sup>1[f] = src f" and "trg \<l>\<^sup>-\<^sup>1[f] = trg f"
	+ and "dom \<l>\<^sup>-\<^sup>1[f] = f" and "cod \<l>\<^sup>-\<^sup>1[f] = trg f \<star> f"
	+ using assms lunit'_in_hom by auto
	+
	+ lemma runit'_in_hom [intro]:
	+ assumes "ide f"
	+ shows "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f \<star> src f\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f \<star> src f\<guillemotright>"
	+ using assms runit_char iso_runit by simp
	+ thus "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : src f \<rightarrow> trg f\<guillemotright>"
	+ using src_dom trg_dom
	+ by (simp add: assms)
	+ qed
	+
	+ lemma runit'_in_vhom [simp]:
	+ assumes "ide f" and "src f = a"
	+ shows "\<guillemotleft>\<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f \<star> a\<guillemotright>"
	+ using assms by auto
	+
	+ lemma runit'_simps [simp]:
	+ assumes "ide f"
	+ shows "arr \<r>\<^sup>-\<^sup>1[f]" and "src \<r>\<^sup>-\<^sup>1[f] = src f" and "trg \<r>\<^sup>-\<^sup>1[f] = trg f"
	+ and "dom \<r>\<^sup>-\<^sup>1[f] = f" and "cod \<r>\<^sup>-\<^sup>1[f] = f \<star> src f"
	+ using assms runit'_in_hom by auto
	+
	+ interpretation L: endofunctor V L ..
	+ interpretation \<ll>: transformation_by_components V V L map lunit
	+ using lunit_in_hom lunit_naturality by unfold_locales auto
	+ interpretation \<ll>: natural_isomorphism V V L map \<ll>.map
	+ using iso_lunit by (unfold_locales, auto)
	+
	+ lemma natural_isomorphism_\<ll>:
	+ shows "natural_isomorphism V V L map \<ll>.map"
	+ ..
	+
	+ abbreviation \<ll>
	+ where "\<ll> \<equiv> \<ll>.map"
	+
	+ lemma \<ll>_ide_simp:
	+ assumes "ide f"
	+ shows "\<ll> f = \<l>[f]"
	+ using assms by simp
	+
	+ interpretation L: equivalence_functor V V L
	+ using L.isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
	+
	+ lemma equivalence_functor_L:
	+ shows "equivalence_functor V V L"
	+ ..
	+
	+ lemma lunit_commutes_with_L:
	+ assumes "ide f"
	+ shows "\<l>[L f] = L \<l>[f]"
	+ unfolding lunit_def
	+ using assms PB.lunit_commutes_with_L by blast
	+
	+ interpretation R: endofunctor V R ..
	+ interpretation \<rr>: transformation_by_components V V R map runit
	+ using runit_in_hom runit_naturality by unfold_locales auto
	+ interpretation \<rr>: natural_isomorphism V V R map \<rr>.map
	+ using iso_runit by (unfold_locales, auto)
	+
	+ lemma natural_isomorphism_\<rr>:
	+ shows "natural_isomorphism V V R map \<rr>.map"
	+ ..
	+
	+ abbreviation \<rr>
	+ where "\<rr> \<equiv> \<rr>.map"
	+
	+ lemma \<rr>_ide_simp:
	+ assumes "ide f"
	+ shows "\<rr> f = \<r>[f]"
	+ using assms by simp
	+
	+ interpretation R: equivalence_functor V V R
	+ using R.isomorphic_to_identity_is_equivalence \<rr>.natural_isomorphism_axioms by simp
	+
	+ lemma equivalence_functor_R:
	+ shows "equivalence_functor V V R"
	+ ..
	+
	+ lemma runit_commutes_with_R:
	+ assumes "ide f"
	+ shows "\<r>[R f] = R \<r>[f]"
	+ unfolding runit_def
	+ using assms PB.runit_commutes_with_R by blast
	+
	+ lemma lunit'_naturality:
	+ assumes "arr \<mu>"
	+ shows "(trg \<mu> \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu>] = \<l>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu>"
	+ using assms iso_lunit lunit_naturality invert_opposite_sides_of_square L.preserves_arr
	+ L.preserves_cod arr_cod ide_cod ide_dom lunit_simps(1) lunit_simps(4) seqI
	+ by presburger
	+
	+ lemma runit'_naturality:
	+ assumes "arr \<mu>"
	+ shows "(\<mu> \<star> src \<mu>) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>] = \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu>"
	+ using assms iso_runit runit_naturality invert_opposite_sides_of_square R.preserves_arr
	+ R.preserves_cod arr_cod ide_cod ide_dom runit_simps(1) runit_simps(4) seqI
	+ by presburger
	+
	+ end
	+
	+ subsection "Further Properties of Bicategories"
	+
	+ text \<open>
	+ Here we derive further properties of bicategories, now that we
	+ have the unitors at our disposal. This section generalizes the corresponding
	+ development in theory @{theory MonoidalCategory.MonoidalCategory},
	+ which has some diagrams to illustrate the longer calculations.
	+ The present section also includes some additional facts that are now nontrivial
	+ due to the partiality of horizontal composition.
	+ \<close>
	+
	+ context bicategory
	+ begin
	+
	+ lemma unit_simps [simp]:
	+ assumes "obj a"
	+ shows "arr \<i>[a]" and "src \<i>[a] = a" and "trg \<i>[a] = a"
	+ and "dom \<i>[a] = a \<star> a" and "cod \<i>[a] = a"
	+ using assms unit_in_hom by blast+
	+
	+ lemma triangle:
	+ assumes "ide f" and "ide g" and "src g = trg f"
	+ shows "(g \<star> \<l>[f]) \<cdot> \<a>[g, src g, f] = \<r>[g] \<star> f"
	+ proof -
	+ let ?b = "src g"
	+ have *: "(g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f] = \<r>[g] \<star> ?b \<star> f"
	+ proof -
	+ have 1: "((g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f]) \<cdot> \<a>[g \<star> ?b, ?b, f]
	+ = (\<r>[g] \<star> ?b \<star> f) \<cdot> \<a>[g \<star> ?b, ?b, f]"
	+ proof -
	+ have "((g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f]) \<cdot> \<a>[g \<star> ?b, ?b, f]
	+ = (g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> \<a>[g \<star> ?b, ?b, f]"
	+ using HoVH_def HoHV_def comp_assoc by auto
	+ also have
	+ "... = (g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> \<a>[?b, ?b, f]) \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
	+ using assms pentagon by force
	+ also have
	+ "... = ((g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> \<a>[?b, ?b, f])) \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
	+ using assms assoc_in_hom HoVH_def HoHV_def comp_assoc by auto
	+ also have
	+ "... = ((g \<star> ?b \<star> \<l>[f]) \<cdot> (g \<star> \<a>[?b, ?b, f])) \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
	+ using assms lunit_commutes_with_L lunit_in_hom by force
	+ also have "... = ((g \<star> (\<i>[?b] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[?b, ?b, f]) \<cdot> (g \<star> \<a>[?b, ?b, f]))
	+ \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
	+ using assms lunit_char(2) by force
	+ also have "... = (g \<star> ((\<i>[?b] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[?b, ?b, f]) \<cdot> \<a>[?b, ?b, f])
	+ \<cdot> \<a>[g, ?b \<star> ?b, f] \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
	+ using assms interchange [of g g "(\<i>[?b] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[?b, ?b, f]" "\<a>[?b, ?b, f]"] hseqI'
	+ by auto
	+ also have "... = ((g \<star> \<i>[?b] \<star> f) \<cdot> \<a>[g, ?b \<star> ?b, f]) \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
	+ using assms comp_arr_dom comp_assoc_assoc' hseqI' comp_assoc by auto
	+ also have "... = (\<a>[g, ?b, f] \<cdot> ((g \<star> \<i>[?b]) \<star> f)) \<cdot> (\<a>[g, ?b, ?b] \<star> f)"
	+ using assms assoc_naturality [of g "\<i>[?b]" f] by simp
	+ also have "... = \<a>[g, ?b, f] \<cdot> ((g \<star> \<i>[?b]) \<cdot> \<a>[g, ?b, ?b] \<star> f)"
	+ using assms interchange [of "g \<star> \<i>[?b]" "\<a>[g, ?b, ?b]" f f] comp_assoc hseqI' by simp
	+ also have "... = \<a>[g, ?b, f] \<cdot> ((\<r>[g] \<star> ?b) \<star> f)"
	+ using assms runit_char(2) by force
	+ also have "... = (\<r>[g] \<star> ?b \<star> f) \<cdot> \<a>[g \<star> ?b, ?b, f]"
	+ using assms assoc_naturality [of "\<r>[g]" ?b f] by auto
	+ finally show ?thesis by blast
	+ qed
	+ show "(g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f] = \<r>[g] \<star> ?b \<star> f"
	+ proof -
	+ have "epi \<a>[g \<star> ?b, ?b, f]"
	+ using assms preserves_ide iso_assoc iso_is_retraction retraction_is_epi by force
	+ thus ?thesis
	+ using assms 1 hseqI' by auto
	+ qed
	+ qed
	+ have "(g \<star> \<l>[f]) \<cdot> \<a>[g, ?b, f] = ((g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])) \<cdot>
	+ (g \<star> ?b \<star> \<l>[f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
	+ proof -
	+ have "\<a>[g, ?b, f] = (g \<star> ?b \<star> \<l>[f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
	+ proof -
	+ have "\<a>[g, ?b, f] = (g \<star> ?b \<star> f) \<cdot> \<a>[g, ?b, f]"
	+ using assms comp_cod_arr hseqI' by simp
	+ have "\<a>[g, ?b, f] = ((g \<star> ?b \<star> \<l>[f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])) \<cdot> \<a>[g, ?b, f]"
	+ using assms comp_cod_arr comp_arr_inv' whisker_left [of g]
	+ whisker_left [of ?b "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"] hseqI'
	+ by simp
	+ also have "... = (g \<star> ?b \<star> \<l>[f]) \<cdot> \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
	+ using assms iso_lunit assoc_naturality [of g ?b "\<l>\<^sup>-\<^sup>1[f]"] comp_assoc by force
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "g \<star> \<l>[f] = (g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])"
	+ proof -
	+ have "(g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f]) = g \<star> ?b \<star> f"
	+ proof -
	+ have "(g \<star> \<l>[?b \<star> f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f]) = (g \<star> ?b \<star> \<l>[f]) \<cdot> (g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f])"
	+ using assms lunit_in_hom lunit_commutes_with_L by simp
	+ also have "... = g \<star> ?b \<star> f"
	+ using assms comp_arr_inv' whisker_left [of g] whisker_left [of ?b "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"]
	+ hseqI'
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using assms comp_arr_dom hseqI' by auto
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = (g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> ((g \<star> ?b \<star> \<l>\<^sup>-\<^sup>1[f]) \<cdot> (g \<star> ?b \<star> \<l>[f])) \<cdot>
	+ \<a>[g, ?b, ?b \<star> f] \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
	+ using comp_assoc by simp
	+ also have "... = (g \<star> \<l>[f]) \<cdot> (g \<star> \<l>[?b \<star> f]) \<cdot> ((g \<star> ?b \<star> (?b \<star> f)) \<cdot>
	+ \<a>[g, ?b, ?b \<star> f]) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
	+ using assms iso_lunit comp_inv_arr' interchange [of g g "?b \<star> \<l>\<^sup>-\<^sup>1[f]" "?b \<star> \<l>[f]"]
	+ interchange [of ?b ?b "\<l>\<^sup>-\<^sup>1[f]" "\<l>[f]"] hseqI' comp_assoc
	+ by auto
	+ also have "... = (g \<star> \<l>[f]) \<cdot> ((g \<star> \<l>[?b \<star> f]) \<cdot> \<a>[g, ?b, ?b \<star> f]) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
	+ using assms comp_cod_arr comp_assoc by auto
	+ also have "... = \<r>[g] \<star> f"
	+ proof -
	+ have "\<r>[g] \<star> f = (g \<star> \<l>[f]) \<cdot> (\<r>[g] \<star> ?b \<star> f) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])"
	+ proof -
	+ have "(g \<star> \<l>[f]) \<cdot> (\<r>[g] \<star> ?b \<star> f) \<cdot> ((g \<star> ?b) \<star> \<l>\<^sup>-\<^sup>1[f])
	+ = (g \<star> \<l>[f]) \<cdot> (\<r>[g] \<cdot> (g \<star> ?b) \<star> (?b \<star> f) \<cdot> \<l>\<^sup>-\<^sup>1[f])"
	+ using assms iso_lunit interchange [of "\<r>[g]" "g \<star> ?b" "?b \<star> f" "\<l>\<^sup>-\<^sup>1[f]"]
	+ by force
	+ also have "... = (g \<star> \<l>[f]) \<cdot> (\<r>[g] \<star> \<l>\<^sup>-\<^sup>1[f])"
	+ using assms comp_arr_dom comp_cod_arr by simp
	+ also have "... = \<r>[g] \<star> \<l>[f] \<cdot> \<l>\<^sup>-\<^sup>1[f]"
	+ using assms interchange [of g "\<r>[g]" "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"] comp_cod_arr
	+ by simp
	+ also have "... = \<r>[g] \<star> f"
	+ using assms iso_lunit comp_arr_inv' by simp
	+ finally show ?thesis by argo
	+ qed
	+ thus ?thesis using assms * by argo
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+
	+ lemma lunit_hcomp_gen:
	+ assumes "ide f" and "ide g" and "ide h"
	+ and "src f = trg g" and "src g = trg h"
	+ shows "(f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h]) = f \<star> \<l>[g] \<star> h"
	+ proof -
	+ have "((f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h])) \<cdot> \<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h) =
	+ (f \<star> (\<l>[g] \<star> h)) \<cdot> \<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h)"
	+ proof -
	+ have "((f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h])) \<cdot> (\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h)) =
	+ ((f \<star> \<l>[g \<star> h]) \<cdot> \<a>[f, trg g, g \<star> h]) \<cdot> \<a>[f \<star> trg g, g, h]"
	+ using assms pentagon comp_assoc by simp
	+ also have "... = (\<r>[f] \<star> (g \<star> h)) \<cdot> \<a>[f \<star> trg g, g, h]"
	+ using assms triangle [of "g \<star> h" f] by auto
	+ also have "... = \<a>[f, g, h] \<cdot> ((\<r>[f] \<star> g) \<star> h)"
	+ using assms assoc_naturality [of "\<r>[f]" g h] by simp
	+ also have "... = (\<a>[f, g, h] \<cdot> ((f \<star> \<l>[g]) \<star> h)) \<cdot> (\<a>[f, trg g, g] \<star> h)"
	+ using assms triangle interchange [of "f \<star> \<l>[g]" "\<a>[f, trg g, g]" h h] comp_assoc hseqI'
	+ by auto
	+ also have "... = (f \<star> (\<l>[g] \<star> h)) \<cdot> (\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h))"
	+ using assms assoc_naturality [of f "\<l>[g]" h] comp_assoc by simp
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "iso (\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h))"
	+ using assms iso_assoc isos_compose hseqI' by simp
	+ ultimately show ?thesis
	+ using assms iso_is_retraction retraction_is_epi hseqI'
	+ epiE [of "\<a>[f, trg g \<star> g, h] \<cdot> (\<a>[f, trg g, g] \<star> h)"
	+ "(f \<star> \<l>[g \<star> h]) \<cdot> (f \<star> \<a>[trg g, g, h])" "f \<star> \<l>[g] \<star> h"]
	+ by auto
	+ qed
	+
	+ lemma lunit_hcomp:
	+ assumes "ide f" and "ide g" and "src f = trg g"
	+ shows "\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g] = \<l>[f] \<star> g"
	+ and "\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> g] = \<l>\<^sup>-\<^sup>1[f] \<star> g"
	+ and "\<l>[f \<star> g] = (\<l>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, g]"
	+ and "\<l>\<^sup>-\<^sup>1[f \<star> g] = \<a>[trg f, f, g] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> g)"
	+ proof -
	+ show 1: "\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g] = \<l>[f] \<star> g"
	+ proof -
	+ have "L (\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g]) = L (\<l>[f] \<star> g)"
	+ using assms interchange [of "trg f" "trg f" "\<l>[f \<star> g]" "\<a>[trg f, f, g]"] lunit_hcomp_gen
	+ by fastforce
	+ thus ?thesis
	+ using assms L.is_faithful [of "\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g]" "\<l>[f] \<star> g"] hseqI' by force
	+ qed
	+ show "\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> g] = \<l>\<^sup>-\<^sup>1[f] \<star> g"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> g] = inv (\<l>[f \<star> g] \<cdot> \<a>[trg f, f, g])"
	+ using assms by (simp add: inv_comp)
	+ also have "... = inv (\<l>[f] \<star> g)"
	+ using 1 by simp
	+ also have "... = \<l>\<^sup>-\<^sup>1[f] \<star> g"
	+ using assms by simp
	+ finally show ?thesis by simp
	+ qed
	+ show 2: "\<l>[f \<star> g] = (\<l>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, g]"
	+ using assms 1 invert_side_of_triangle(2) [of "\<l>[f] \<star> g" "\<l>[f \<star> g]" "\<a>[trg f, f, g]"]
	+ hseqI'
	+ by auto
	+ show "\<l>\<^sup>-\<^sup>1[f \<star> g] = \<a>[trg f, f, g] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> g)"
	+ proof -
	+ have "\<l>\<^sup>-\<^sup>1[f \<star> g] = inv ((\<l>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, g])"
	+ using 2 by simp
	+ also have "... = \<a>[trg f, f, g] \<cdot> inv (\<l>[f] \<star> g)"
	+ using assms inv_comp iso_inv_iso
	+ by (simp add: hseqI')
	+ also have "... = \<a>[trg f, f, g] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> g)"
	+ using assms by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma runit_hcomp_gen:
	+ assumes "ide f" and "ide g" and "ide h"
	+ and "src f = trg g" and "src g = trg h"
	+ shows "\<r>[f \<star> g] \<star> h = ((f \<star> \<r>[g]) \<star> h) \<cdot> (\<a>[f, g, src g] \<star> h)"
	+ proof -
	+ have "\<r>[f \<star> g] \<star> h = ((f \<star> g) \<star> \<l>[h]) \<cdot> \<a>[f \<star> g, src g, h]"
	+ using assms triangle by simp
	+ also have "... = (\<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> (f \<star> g \<star> \<l>[h]) \<cdot> \<a>[f, g, src g \<star> h]) \<cdot> \<a>[f \<star> g, src g, h]"
	+ using assms assoc_naturality [of f g "\<l>[h]"] invert_side_of_triangle(1) hseqI'
	+ by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> (f \<star> g \<star> \<l>[h]) \<cdot> \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
	+ using comp_assoc by simp
	+ also have "... = (\<a>\<^sup>-\<^sup>1[f, g, h] \<cdot> (f \<star> (\<r>[g] \<star> h))) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, src g, h]) \<cdot>
	+ \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
	+ using assms interchange [of f f] triangle comp_assoc hseqI'
	+ invert_side_of_triangle(2) [of "\<r>[g] \<star> h" "g \<star> \<l>[h]" "\<a>[g, src g, h]"]
	+ by simp
	+ also have "... = ((f \<star> \<r>[g]) \<star> h) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> src g, h] \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, src g, h]) \<cdot>
	+ \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
	+ using assms assoc'_naturality [of f "\<r>[g]" h] comp_assoc by simp
	+ also have "... = ((f \<star> \<r>[g]) \<star> h) \<cdot> (\<a>[f, g, src g] \<star> h)"
	+ using assms pentagon [of f g "src g" h] iso_assoc inv_hcomp
	+ invert_side_of_triangle(1)
	+ [of "\<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]" "f \<star> \<a>[g, src g, h]"
	+ "\<a>[f, g \<star> src g, h] \<cdot> (\<a>[f, g, src g] \<star> h)"]
	+ invert_side_of_triangle(1)
	+ [of "(f \<star> \<a>\<^sup>-\<^sup>1[g, src g, h]) \<cdot> \<a>[f, g, src g \<star> h] \<cdot> \<a>[f \<star> g, src g, h]"
	+ "\<a>[f, g \<star> src g, h]" "\<a>[f, g, src g] \<star> h"]
	+ by auto
	+ finally show ?thesis by blast
	+ qed
	+
	+ lemma runit_hcomp:
	+ assumes "ide f" and "ide g" and "src f = trg g"
	+ shows "\<r>[f \<star> g] = (f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g]"
	+ and "\<r>\<^sup>-\<^sup>1[f \<star> g] = \<a>\<^sup>-\<^sup>1[f, g, src g] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[g])"
	+ and "\<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g] = f \<star> \<r>[g]"
	+ and "\<a>[f, g, src g] \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> g] = f \<star> \<r>\<^sup>-\<^sup>1[g]"
	+ proof -
	+ show 1: "\<r>[f \<star> g] = (f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g]"
	+ using assms interchange [of "f \<star> \<r>[g]" "\<a>[f, g, src g]" "src g" "src g"] hseqI'
	+ runit_hcomp_gen [of f g "src g"]
	+ R.is_faithful [of "(f \<star> \<r>[g]) \<cdot> (\<a>[f, g, src g])" "\<r>[f \<star> g]"]
	+ by simp
	+ show "\<r>\<^sup>-\<^sup>1[f \<star> g] = \<a>\<^sup>-\<^sup>1[f, g, src g] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[g])"
	+ proof -
	+ have "\<r>\<^sup>-\<^sup>1[f \<star> g] = inv ((f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g])"
	+ using 1 by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[f, g, src g] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[g])"
	+ proof -
	+ have "src f = trg \<r>[g]"
	+ using assms by simp
	+ thus ?thesis
	+ using assms 1 inv_comp inv_hcomp hseqI' by simp
	+ qed
	+ finally show ?thesis
	+ using assms by simp
	+ qed
	+ show 2: "\<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g] = f \<star> \<r>[g]"
	+ proof -
	+ have "f \<star> \<r>[g] = ((f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g]) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g]"
	+ using assms comp_arr_dom comp_cod_arr comp_assoc hseqI' comp_assoc_assoc' by simp
	+ also have "... = \<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g]"
	+ using assms 1 by auto
	+ finally show ?thesis by auto
	+ qed
	+ show "\<a>[f, g, src g] \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> g] = f \<star> \<r>\<^sup>-\<^sup>1[g]"
	+ proof -
	+ have "\<a>[f, g, src g] \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> g] = inv (\<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g])"
	+ using assms inv_comp iso_inv_iso hseqI' by simp
	+ also have "... = inv (f \<star> \<r>[g])"
	+ using 2 by simp
	+ also have "... = f \<star> \<r>\<^sup>-\<^sup>1[g]"
	+ using assms inv_hcomp [of f "\<r>[g]"] by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma unitor_coincidence:
	+ assumes "obj a"
	+ shows "\<l>[a] = \<i>[a]" and "\<r>[a] = \<i>[a]"
	+ proof -
	+ have "R \<l>[a] = R \<i>[a] \<and> R \<r>[a] = R \<i>[a]"
	+ proof -
	+ have "R \<l>[a] = (a \<star> \<l>[a]) \<cdot> \<a>[a, a, a]"
	+ using assms lunit_hcomp [of a a] lunit_commutes_with_L [of a] by auto
	+ moreover have "(a \<star> \<l>[a]) \<cdot> \<a>[a, a, a] = R \<r>[a]"
	+ using assms triangle [of a a] by auto
	+ moreover have "(a \<star> \<l>[a]) \<cdot> \<a>[a, a, a] = R \<i>[a]"
	+ proof -
	+ have "(a \<star> \<l>[a]) \<cdot> \<a>[a, a, a] = ((\<i>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a]) \<cdot> \<a>[a, a, a]"
	+ using assms lunit_char(2) by force
	+ also have "... = R \<i>[a]"
	+ using assms comp_arr_dom comp_assoc hseqI' comp_assoc_assoc'
	+ apply (elim objE)
	+ by (simp add: assms)
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis by argo
	+ qed
	+ moreover have "par \<l>[a] \<i>[a] \<and> par \<r>[a] \<i>[a]"
	+ using assms by auto
	+ ultimately have 1: "\<l>[a] = \<i>[a] \<and> \<r>[a] = \<i>[a]"
	+ using R.is_faithful by blast
	+ show "\<l>[a] = \<i>[a]" using 1 by auto
	+ show "\<r>[a] = \<i>[a]" using 1 by auto
	+ qed
	+
	+ lemma unit_triangle:
	+ assumes "obj a"
	+ shows "\<i>[a] \<star> a = (a \<star> \<i>[a]) \<cdot> \<a>[a, a, a]"
	+ and "(\<i>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a] = a \<star> \<i>[a]"
	+ proof -
	+ show 1: "\<i>[a] \<star> a = (a \<star> \<i>[a]) \<cdot> \<a>[a, a, a]"
	+ using assms triangle [of a a] unitor_coincidence by auto
	+ show "(\<i>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a] = a \<star> \<i>[a]"
	+ using assms 1 invert_side_of_triangle(2) [of "\<i>[a] \<star> a" "a \<star> \<i>[a]" "\<a>[a, a, a]"]
	+ assoc'_eq_inv_assoc
	+ by (metis hseqI' iso_assoc objE obj_def' unit_simps(1) unit_simps(2))
	+ qed
	+
	+ lemma hcomp_arr_obj:
	+ assumes "arr \<mu>" and "obj a" and "src \<mu> = a"
	+ shows "\<mu> \<star> a = \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<r>[dom \<mu>]"
	+ and "\<r>[cod \<mu>] \<cdot> (\<mu> \<star> a) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
	+ proof -
	+ show "\<mu> \<star> a = \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<r>[dom \<mu>]"
	+ using assms iso_runit runit_naturality comp_cod_arr
	+ by (metis ide_cod ide_dom invert_side_of_triangle(1) runit_simps(1) runit_simps(5) seqI)
	+ show "\<r>[cod \<mu>] \<cdot> (\<mu> \<star> a) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
	+ using assms iso_runit runit_naturality [of \<mu>] comp_cod_arr
	+ by (metis ide_dom invert_side_of_triangle(2) comp_assoc runit_simps(1)
	+ runit_simps(5) seqI)
	+ qed
	+
	+ lemma hcomp_obj_arr:
	+ assumes "arr \<mu>" and "obj b" and "b = trg \<mu>"
	+ shows "b \<star> \<mu> = \<l>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<l>[dom \<mu>]"
	+ and "\<l>[cod \<mu>] \<cdot> (b \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
	+ proof -
	+ show "b \<star> \<mu> = \<l>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu> \<cdot> \<l>[dom \<mu>]"
	+ using assms iso_lunit lunit_naturality comp_cod_arr
	+ by (metis ide_cod ide_dom invert_side_of_triangle(1) lunit_simps(1) lunit_simps(5) seqI)
	+ show "\<l>[cod \<mu>] \<cdot> (b \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu>] = \<mu>"
	+ using assms iso_lunit lunit_naturality [of \<mu>] comp_cod_arr
	+ by (metis ide_dom invert_side_of_triangle(2) comp_assoc lunit_simps(1)
	+ lunit_simps(5) seqI)
	+ qed
	+
	+ lemma hcomp_reassoc:
	+ assumes "arr \<tau>" and "arr \<mu>" and "arr \<nu>"
	+ and "src \<tau> = trg \<mu>" and "src \<mu> = trg \<nu>"
	+ shows "(\<tau> \<star> \<mu>) \<star> \<nu> = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ and "\<tau> \<star> \<mu> \<star> \<nu> = \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ proof -
	+ show "(\<tau> \<star> \<mu>) \<star> \<nu> = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ proof -
	+ have "(\<tau> \<star> \<mu>) \<star> \<nu> = (\<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>]) \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
	+ using assms comp_assoc_assoc'(2) comp_cod_arr hseqI' by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
	+ using comp_assoc by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ using assms assoc_naturality by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "\<tau> \<star> \<mu> \<star> \<nu> = \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ proof -
	+ have "\<tau> \<star> \<mu> \<star> \<nu> = (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>] \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ using assms comp_assoc_assoc'(1) comp_arr_dom hseqI' by simp
	+ also have "... = ((\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ using comp_assoc by simp
	+ also have "... = (\<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ using assms assoc_naturality by simp
	+ also have "... = \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ using comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma triangle':
	+ assumes "ide f" and "ide g" and "src f = trg g"
	+ shows "(f \<star> \<l>[g]) = (\<r>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, g]"
	+ proof -
	+ have "(\<r>[f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, g] = ((f \<star> \<l>[g]) \<cdot> \<a>[f, src f, g]) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, g]"
	+ using assms triangle by auto
	+ also have "... = (f \<star> \<l>[g])"
	+ using assms comp_arr_dom comp_assoc hseqI' comp_assoc_assoc' by auto
	+ finally show ?thesis by auto
	+ qed
	+
	+ lemma pentagon':
	+ assumes "ide f" and "ide g" and "ide h" and "ide k"
	+ and "src f = trg g" and "src g = trg h" and "src h = trg k"
	+ shows "((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> k) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> h, k]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, h, k])
	+ = \<a>\<^sup>-\<^sup>1[f \<star> g, h, k] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, h \<star> k]"
	+ proof -
	+ have "((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> k) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> h, k]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, h, k])
	+ = inv ((f \<star> \<a>[g, h, k]) \<cdot> (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)))"
	+ proof -
	+ have "inv ((f \<star> \<a>[g, h, k]) \<cdot> (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k))) =
	+ inv (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)) \<cdot> inv (f \<star> \<a>[g, h, k])"
	+ proof -
	+ have "iso (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k))"
	+ using assms isos_compose hseqI' by simp
	+ moreover have "iso (f \<star> \<a>[g, h, k])"
	+ using assms by simp
	+ moreover have "seq (f \<star> \<a>[g, h, k]) (\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k))"
	+ using assms hseqI' by simp
	+ ultimately show ?thesis
	+ using inv_comp [of "\<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)" "f \<star> \<a>[g, h, k]"]
	+ by simp
	+ qed
	+ also have "... = (inv (\<a>[f, g, h] \<star> k) \<cdot> inv \<a>[f, g \<star> h, k]) \<cdot> inv (f \<star> \<a>[g, h, k])"
	+ using assms iso_assoc inv_comp hseqI' by simp
	+ also have "... = ((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> k) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> h, k]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[g, h, k])"
	+ using assms inv_hcomp by simp
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = inv (\<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k])"
	+ using assms pentagon by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[f \<star> g, h, k] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, h \<star> k]"
	+ using assms inv_comp by simp
	+ finally show ?thesis by auto
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ The following convenience locale extends @{locale bicategory} by pre-interpreting
	+ the various functors and natural transformations.
	+ \<close>
	+
	+ locale extended_bicategory =
	+ bicategory +
	+ L: equivalence_functor V V L +
	+ R: equivalence_functor V V R +
	+ \<alpha>: natural_isomorphism VVV.comp V HoHV HoVH
	+ \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> +
	+ \<alpha>': inverse_transformation VVV.comp V HoHV HoVH
	+ \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> +
	+ \<ll>: natural_isomorphism V V L map \<ll> +
	+ \<ll>': inverse_transformation V V L map \<ll> +
	+ \<rr>: natural_isomorphism V V R map \<rr> +
	+ \<rr>': inverse_transformation V V R map \<rr>
	+
	+ sublocale bicategory \<subseteq> extended_bicategory V H \<a> \<i> src trg
	+ proof -
	+ interpret L: equivalence_functor V V L using equivalence_functor_L by auto
	+ interpret R: equivalence_functor V V R using equivalence_functor_R by auto
	+ interpret \<alpha>': inverse_transformation VVV.comp V HoHV HoVH
	+ \<open>\<lambda>\<mu>\<nu>\<tau>. \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))\<close> ..
	+ interpret \<ll>: natural_isomorphism V V L map \<ll> using natural_isomorphism_\<ll> by auto
	+ interpret \<ll>': inverse_transformation V V L map \<ll> ..
	+ interpret \<rr>: natural_isomorphism V V R map \<rr> using natural_isomorphism_\<rr> by auto
	+ interpret \<rr>': inverse_transformation V V R map \<rr> ..
	+ interpret extended_bicategory V H \<a> \<i> src trg ..
	+ show "extended_bicategory V H \<a> \<i> src trg" ..
	+ qed
	+
	+end
	diff --git a/thys/Bicategory/BicategoryOfSpans.thy b/thys/Bicategory/BicategoryOfSpans.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/BicategoryOfSpans.thy
	@@ -0,0 +1,14800 @@
	+(* Title: BicategoryOfSpans
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Bicategories of Spans"
	+
	+theory BicategoryOfSpans
	+imports CanonicalIsos SpanBicategory ConcreteCategory IsomorphismClass Tabulation
	+begin
	+
	+text \<open>
	+ In this section, we prove CKS Theorem 4, which characterizes up to equivalence the
	+ bicategories of spans in a category with pullbacks.
	+ The characterization consists of three conditions:
	+ BS1: ``Every 1-cell is isomorphic to a composition \<open>g \<star> f\<^sup>*\<close>, where f and g are maps'';
	+ BS2: ``For every span of maps \<open>(f, g)\<close> there is a 2-cell \<open>\<rho>\<close> such that \<open>(f, \<rho>, g)\<close>
	+ is a tabulation''; and
	+ BS3: ``Any two 2-cells between the same pair of maps are equal and invertible.''
	+ One direction of the proof, which is the easier direction once it is established that
	+ BS1 and BS3 are respected by equivalence of bicategories, shows that if a bicategory \<open>B\<close>
	+ is biequivalent to the bicategory of spans in some category \<open>C\<close> with pullbacks,
	+ then it satisfies BS1 -- BS3.
	+ The other direction, which is harder, shows that a bicategory \<open>B\<close> satisfying BS1 -- BS3 is
	+ biequivalent to the bicategory of spans in a certain category with pullbacks that
	+ is constructed from the sub-bicategory of maps of \<open>B\<close>.
	+\<close>
	+
	+ subsection "Definition"
	+
	+ text \<open>
	+ We define a \emph{bicategory of spans} to be a bicategory that satisfies the conditions
	+ \<open>BS1\<close> -- \<open>BS3\<close> stated informally above.
	+ \<close>
	+
	+ locale bicategory_of_spans =
	+ bicategory + chosen_right_adjoints +
	+ assumes BS1: "\<And>r. ide r \<Longrightarrow> \<exists>f g. is_left_adjoint f \<and> is_left_adjoint g \<and> isomorphic r (g \<star> f\<^sup>*)"
	+ and BS2: "\<And>f g. \<lbrakk> is_left_adjoint f; is_left_adjoint g; src f = src g \<rbrakk>
	+ \<Longrightarrow> \<exists>r \<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"
	+ and BS3: "\<And>f f' \<mu> \<mu>'. \<lbrakk> is_left_adjoint f; is_left_adjoint f'; \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright>; \<guillemotleft>\<mu>' : f \<Rightarrow> f'\<guillemotright> \<rbrakk>
	+ \<Longrightarrow> iso \<mu> \<and> iso \<mu>' \<and> \<mu> = \<mu>'"
	+
	+ text \<open>
	+ Using the already-established fact \<open>equivalence_pseudofunctor.reflects_tabulation\<close>
	+ that tabulations are reflected by equivalence pseudofunctors, it is not difficult to prove
	+ that the notion `bicategory of spans' respects equivalence of bicategories.
	+ \<close>
	+
	+ lemma bicategory_of_spans_respects_equivalence:
	+ assumes "equivalent_bicategories V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D"
	+ and "bicategory_of_spans V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C"
	+ shows "bicategory_of_spans V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D"
	+ proof -
	+ interpret C: bicategory_of_spans V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C
	+ using assms by simp
	+ interpret C: chosen_right_adjoints V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C ..
	+ interpret D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ using assms equivalent_bicategories_def equivalence_pseudofunctor.axioms(1)
	+ pseudofunctor.axioms(2)
	+ by fast
	+ interpret D: chosen_right_adjoints V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D ..
	+ obtain F \<Phi> where F: "equivalence_pseudofunctor
	+ V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>"
	+ using assms equivalent_bicategories_def by blast
	+ interpret F: equivalence_pseudofunctor
	+ V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>
	+ using F by simp
	+ interpret G: converse_equivalence_pseudofunctor
	+ V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>
	+ ..
	+ write V\<^sub>C (infixr "\<cdot>\<^sub>C" 55)
	+ write V\<^sub>D (infixr "\<cdot>\<^sub>D" 55)
	+ write H\<^sub>C (infixr "\<star>\<^sub>C" 53)
	+ write H\<^sub>D (infixr "\<star>\<^sub>D" 53)
	+ write \<a>\<^sub>C ("\<a>\<^sub>C[_, _, _]")
	+ write \<a>\<^sub>D ("\<a>\<^sub>D[_, _, _]")
	+ write C.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
	+ write C.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>C _\<guillemotright>")
	+ write D.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
	+ write D.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>D _\<guillemotright>")
	+ write C.isomorphic (infix "\<cong>\<^sub>C" 50)
	+ write D.isomorphic (infix "\<cong>\<^sub>D" 50)
	+ write C.some_right_adjoint ("_\<^sup>*\<^sup>C" [1000] 1000)
	+ write D.some_right_adjoint ("_\<^sup>*\<^sup>D" [1000] 1000)
	+
	+ show "bicategory_of_spans V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D"
	+ proof
	+ show "\<And>r'. D.ide r' \<Longrightarrow>
	+ \<exists>f' g'. D.is_left_adjoint f' \<and> D.is_left_adjoint g' \<and> r' \<cong>\<^sub>D g' \<star>\<^sub>D (f')\<^sup>*\<^sup>D"
	+ proof -
	+ fix r'
	+ assume r': "D.ide r'"
	+ obtain f g where fg: "C.is_left_adjoint f \<and> C.is_left_adjoint g \<and> G.G r' \<cong>\<^sub>C g \<star>\<^sub>C f\<^sup>*\<^sup>C"
	+ using r' C.BS1 G.G\<^sub>1_props(1) G.G_ide by presburger
	+ have trg_g: "trg\<^sub>C g = G.G\<^sub>0 (trg\<^sub>D r')"
	+ using fg r' C.isomorphic_def C.hcomp_simps(2)
	+ by (metis C.ideD(1) C.in_hhomE C.isomorphic_implies_hpar(4)
	+ C.isomorphic_implies_ide(2) D.ideD(1) G.G_props(1))
	+ have trg_f: "trg\<^sub>C f = G.G\<^sub>0 (src\<^sub>D r')"
	+ using fg r' C.isomorphic_def C.hcomp_simps(1)
	+ by (metis C.ideD(1) C.in_hhomE C.isomorphic_implies_hpar(3) C.isomorphic_implies_ide(2)
	+ C.right_adjoint_simps(2) D.ideD(1) G.G_props(1))
	+ interpret e_src: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>G.e (src\<^sub>D r')\<close> \<open>G.d (src\<^sub>D r')\<close> \<open>G.\<eta> (src\<^sub>D r')\<close> \<open>G.\<epsilon> (src\<^sub>D r')\<close>
	+ using r' G.G\<^sub>0_props [of "src\<^sub>D r'"] by simp
	+ interpret e_trg: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>G.e (trg\<^sub>D r')\<close> \<open>G.d (trg\<^sub>D r')\<close> \<open>G.\<eta> (trg\<^sub>D r')\<close> \<open>G.\<epsilon> (trg\<^sub>D r')\<close>
	+ using r' G.G\<^sub>0_props [of "trg\<^sub>D r'"] by simp
	+ interpret e: two_equivalences_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>G.e (src\<^sub>D r')\<close> \<open>G.d (src\<^sub>D r')\<close> \<open>G.\<eta> (src\<^sub>D r')\<close> \<open>G.\<epsilon> (src\<^sub>D r')\<close>
	+ \<open>G.e (trg\<^sub>D r')\<close> \<open>G.d (trg\<^sub>D r')\<close> \<open>G.\<eta> (trg\<^sub>D r')\<close> \<open>G.\<epsilon> (trg\<^sub>D r')\<close>
	+ ..
	+ interpret hom: subcategory V\<^sub>D
	+ \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : src\<^sub>D (G.e (src\<^sub>D r')) \<rightarrow>\<^sub>D src\<^sub>D (G.e (trg\<^sub>D r'))\<guillemotright>\<close>
	+ using D.hhom_is_subcategory by simp
	+ interpret hom': subcategory V\<^sub>D
	+ \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : trg\<^sub>D (G.e (src\<^sub>D r')) \<rightarrow>\<^sub>D trg\<^sub>D (G.e (trg\<^sub>D r'))\<guillemotright>\<close>
	+ using D.hhom_is_subcategory by simp
	+ interpret e: equivalence_of_categories hom'.comp hom.comp e.F e.G e.\<phi> e.\<psi>
	+ using e.induces_equivalence_of_hom_categories by simp
	+
	+ define g'
	+ where "g' = G.d (trg\<^sub>D r') \<star>\<^sub>D F g"
	+ have g': "D.is_left_adjoint g'"
	+ proof -
	+ have "D.equivalence_map (G.d (trg\<^sub>D r'))"
	+ using D.equivalence_map_def e_trg.dual_equivalence by blast
	+ hence "D.is_left_adjoint (G.d (trg\<^sub>D r'))"
	+ using r' D.equivalence_is_adjoint by simp
	+ moreover have "src\<^sub>D (G.d (trg\<^sub>D r')) = trg\<^sub>D (F g)"
	+ using fg r' G.G\<^sub>0_props trg_g
	+ by (simp add: C.left_adjoint_is_ide)
	+ ultimately show ?thesis
	+ unfolding g'_def
	+ using fg r' D.left_adjoints_compose F.preserves_left_adjoint by blast
	+ qed
	+ have 1: "D.is_right_adjoint (F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r'))"
	+ proof -
	+ have "D.equivalence_map (G.e (src\<^sub>D r'))"
	+ using D.equivalence_map_def e_src.equivalence_in_bicategory_axioms by blast
	+ hence "D.is_right_adjoint (G.e (src\<^sub>D r'))"
	+ using r' D.equivalence_is_adjoint by simp
	+ moreover have "D.is_right_adjoint (F f\<^sup>*\<^sup>C)"
	+ using fg C.left_adjoint_extends_to_adjoint_pair F.preserves_adjoint_pair by blast
	+ moreover have "src\<^sub>D (F f\<^sup>*\<^sup>C) = trg\<^sub>D (G.e (src\<^sub>D r'))"
	+ using fg r' G.G\<^sub>0_props trg_f
	+ by (simp add: C.right_adjoint_is_ide)
	+ ultimately show ?thesis
	+ using fg r' D.right_adjoints_compose F.preserves_right_adjoint by blast
	+ qed
	+ obtain f' where f': "D.adjoint_pair f' (F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r'))"
	+ using 1 by auto
	+ have f': "D.is_left_adjoint f' \<and> F f\<^sup>\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r') \<cong>\<^sub>D (f')\<^sup>\<^sup>D"
	+ using f' D.left_adjoint_determines_right_up_to_iso D.left_adjoint_extends_to_adjoint_pair
	+ by blast
	+
	+ have "r' \<cong>\<^sub>D G.d (trg\<^sub>D r') \<star>\<^sub>D (G.e (trg\<^sub>D r') \<star>\<^sub>D r' \<star>\<^sub>D G.d (src\<^sub>D r')) \<star>\<^sub>D G.e (src\<^sub>D r')"
	+ using r' e.\<eta>.components_are_iso e.\<phi>_in_hom [of r'] D.isomorphic_def
	+ hom.ide_char hom.arr_char hom.iso_char
	+ by auto
	+ also have 1: "... \<cong>\<^sub>D (G.d (trg\<^sub>D r') \<star>\<^sub>D F (G.G r') \<star>\<^sub>D G.e (src\<^sub>D r'))"
	+ proof -
	+ have "G.e (trg\<^sub>D r') \<star>\<^sub>D r' \<star>\<^sub>D G.d (src\<^sub>D r') \<cong>\<^sub>D F (G.G r')"
	+ by (simp add: D.isomorphic_symmetric G.G\<^sub>1_props(3) G.G_ide r')
	+ thus ?thesis
	+ using r' D.hcomp_isomorphic_ide D.hcomp_ide_isomorphic by simp
	+ qed
	+ also have 2: "... \<cong>\<^sub>D G.d (trg\<^sub>D r') \<star>\<^sub>D (F g \<star>\<^sub>D F f\<^sup>*\<^sup>C) \<star>\<^sub>D G.e (src\<^sub>D r')"
	+ proof -
	+ have "F (G.G r') \<cong>\<^sub>D F (g \<star>\<^sub>C f\<^sup>*\<^sup>C)"
	+ using fg F.preserves_iso C.isomorphic_def D.isomorphic_def by auto
	+ also have "F (g \<star>\<^sub>C f\<^sup>\<^sup>C) \<cong>\<^sub>D F g \<star>\<^sub>D F f\<^sup>\<^sup>C"
	+ using fg
	+ by (meson C.adjoint_pair_antipar(1) C.hseqE C.ideD(1) C.isomorphic_implies_hpar(2)
	+ C.right_adjoint_simps(1) D.isomorphic_symmetric F.weakly_preserves_hcomp)
	+ finally have "D.isomorphic (F (G.G r')) (F g \<star>\<^sub>D F f\<^sup>*\<^sup>C)"
	+ by simp
	+ moreover have "\<And>f g. D.ide (H\<^sub>D f g) \<Longrightarrow> src\<^sub>D f = trg\<^sub>D g"
	+ by (metis (no_types) D.hseqE D.ideD(1))
	+ ultimately show ?thesis
	+ by (meson 1 D.hcomp_ide_isomorphic D.hcomp_isomorphic_ide D.hseqE D.ideD(1)
	+ D.isomorphic_implies_hpar(2)
	+ e_src.ide_left e_trg.ide_right)
	+ qed
	+ also have 3: "... \<cong>\<^sub>D (G.d (trg\<^sub>D r') \<star>\<^sub>D F g) \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')"
	+ proof -
	+ let ?a = "\<a>\<^sub>D\<^sup>-\<^sup>1[G.d (trg\<^sub>D r'), F g, F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')] \<cdot>\<^sub>D
	+ (G.d (trg\<^sub>D r') \<star>\<^sub>D \<a>\<^sub>D[F g, F f\<^sup>*\<^sup>C, G.e (src\<^sub>D r')])"
	+ have "\<guillemotleft>?a : G.d (trg\<^sub>D r') \<star>\<^sub>D (F g \<star>\<^sub>D F f\<^sup>*\<^sup>C) \<star>\<^sub>D G.e (src\<^sub>D r')
	+ \<Rightarrow>\<^sub>D (G.d (trg\<^sub>D r') \<star>\<^sub>D F g) \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')\<guillemotright>"
	+ proof (intro D.comp_in_homI)
	+ show "\<guillemotleft>G.d (trg\<^sub>D r') \<star>\<^sub>D \<a>\<^sub>D[F g, F f\<^sup>*\<^sup>C, G.e (src\<^sub>D r')] :
	+ G.d (trg\<^sub>D r') \<star>\<^sub>D (F g \<star>\<^sub>D F f\<^sup>*\<^sup>C) \<star>\<^sub>D G.e (src\<^sub>D r')
	+ \<Rightarrow>\<^sub>D G.d (trg\<^sub>D r') \<star>\<^sub>D F g \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')\<guillemotright>"
	+ using fg r' 2 C.left_adjoint_is_ide D.hseqE D.ideD(1) D.isomorphic_implies_ide(2)
	+ D.src_hcomp' D.hseqI' D.assoc_in_hom [of "F g" "F f\<^sup>*\<^sup>C" "G.e (src\<^sub>D r')"]
	+ apply auto
	+ by (metis C.hseqE C.ideD(1) C.isomorphic_implies_hpar(2) C.right_adjoint_simps(3)
	+ D.hcomp_in_vhom D.ideD(1) D.ide_in_hom(2) e_trg.ide_right trg_f)
	+ show "\<guillemotleft>\<a>\<^sub>D\<^sup>-\<^sup>1[G.d (trg\<^sub>D r'), F g, F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')] :
	+ G.d (trg\<^sub>D r') \<star>\<^sub>D F g \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')
	+ \<Rightarrow>\<^sub>D (G.d (trg\<^sub>D r') \<star>\<^sub>D F g) \<star>\<^sub>D F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')\<guillemotright>"
	+ using fg r' f' trg_g 2 C.left_adjoint_is_ide D.hseqE D.ideD(1)
	+ D.isomorphic_implies_ide D.src_hcomp' D.hseqI'
	+ D.assoc'_in_hom [of "G.d (trg\<^sub>D r')" "F g" "F f\<^sup>*\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r')"]
	+ apply auto
	+ by (metis (no_types, lifting) C.hseqE C.ideD(1) C.isomorphic_implies_ide(2)
	+ C.right_adjoint_simps(3) D.assoc'_eq_inv_assoc D.ideD(1) D.trg_hcomp'
	+ F.preserves_ide e_trg.ide_right)
	+ qed
	+ moreover have "D.iso ?a"
	+ using fg r' D.isos_compose
	+ by (metis 2 C.left_adjoint_is_ide C.right_adjoint_simps(1) D.arrI D.assoc_simps(3)
	+ D.iso_hcomp D.hseqE D.ideD(1) D.ide_is_iso D.iso_assoc D.iso_assoc'
	+ D.isomorphic_implies_ide(1) D.isomorphic_implies_ide(2) D.trg_hcomp'
	+ F.preserves_ide calculation e_src.ide_left e_trg.ide_right f')
	+ ultimately show ?thesis
	+ using D.isomorphic_def by auto
	+ qed
	+ also have "(G.d (trg\<^sub>D r') \<star>\<^sub>D F g) \<star>\<^sub>D F f\<^sup>\<^sup>C \<star>\<^sub>D G.e (src\<^sub>D r') \<cong>\<^sub>D g' \<star>\<^sub>D f'\<^sup>\<^sup>D"
	+ using g'_def f'
	+ by (metis 3 D.adjoint_pair_antipar(1) D.hcomp_ide_isomorphic D.hseq_char D.ideD(1)
	+ D.isomorphic_implies_ide(2) g')
	+ finally have "D.isomorphic r' (g' \<star>\<^sub>D f'\<^sup>*\<^sup>D)"
	+ by simp
	+ thus "\<exists>f' g'. D.is_left_adjoint f' \<and> D.is_left_adjoint g' \<and> r' \<cong>\<^sub>D g' \<star>\<^sub>D f'\<^sup>*\<^sup>D"
	+ using f' g' by auto
	+ qed
	+ show "\<And>f f' \<mu> \<mu>'. \<lbrakk> D.is_left_adjoint f; D.is_left_adjoint f';
	+ \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>D f'\<guillemotright>; \<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>D f'\<guillemotright> \<rbrakk> \<Longrightarrow> D.iso \<mu> \<and> D.iso \<mu>' \<and> \<mu> = \<mu>'"
	+ proof -
	+ fix f f' \<mu> \<mu>'
	+ assume f: "D.is_left_adjoint f"
	+ and f': "D.is_left_adjoint f'"
	+ and \<mu>: "\<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>D f'\<guillemotright>"
	+ and \<mu>': "\<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>D f'\<guillemotright>"
	+ have "C.is_left_adjoint (G.G f) \<and> C.is_left_adjoint (G.G f')"
	+ using f f' G.preserves_left_adjoint by simp
	+ moreover have "\<guillemotleft>G.G \<mu> : G.G f \<Rightarrow>\<^sub>C G.G f'\<guillemotright> \<and> \<guillemotleft>G.G \<mu>' : G.G f \<Rightarrow>\<^sub>C G.G f'\<guillemotright>"
	+ using \<mu> \<mu>' G.preserves_hom by simp
	+ ultimately have "C.iso (G.G \<mu>) \<and> C.iso (G.G \<mu>') \<and> G.G \<mu> = G.G \<mu>'"
	+ using C.BS3 by blast
	+ thus "D.iso \<mu> \<and> D.iso \<mu>' \<and> \<mu> = \<mu>'"
	+ using \<mu> \<mu>' G.reflects_iso G.is_faithful by blast
	+ qed
	+ show "\<And>f g. \<lbrakk> D.is_left_adjoint f; D.is_left_adjoint g; src\<^sub>D f = src\<^sub>D g \<rbrakk>
	+ \<Longrightarrow> \<exists>r \<rho>. tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D r \<rho> f g"
	+ proof -
	+ fix f g
	+ assume f: "D.is_left_adjoint f"
	+ assume g: "D.is_left_adjoint g"
	+ assume fg: "src\<^sub>D f = src\<^sub>D g"
	+ have "C.is_left_adjoint (G.G f)"
	+ using f G.preserves_left_adjoint by blast
	+ moreover have "C.is_left_adjoint (G.G g)"
	+ using g G.preserves_left_adjoint by blast
	+ moreover have "src\<^sub>C (G.G f) = src\<^sub>C (G.G g)"
	+ using f g D.left_adjoint_is_ide fg by simp
	+ ultimately have 1: "\<exists>r \<rho>. tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> (G.G f) (G.G g)"
	+ using C.BS2 by simp
	+ obtain r \<rho> where \<rho>: "tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> (G.G f) (G.G g)"
	+ using 1 by auto
	+ interpret \<rho>: tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> \<open>G.G f\<close> \<open>G.G g\<close>
	+ using \<rho> by simp
	+ obtain r' where
	+ r': "D.ide r' \<and> D.in_hhom r' (trg\<^sub>D f) (trg\<^sub>D g) \<and> C.isomorphic (G.G r') r"
	+ using f g \<rho>.ide_base \<rho>.tab_in_hom G.locally_essentially_surjective
	+ by (metis D.obj_trg G.preserves_reflects_arr G.preserves_trg \<rho>.leg0_simps(2-3)
	+ \<rho>.leg1_simps(2,4) \<rho>.base_in_hom(1))
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : r \<Rightarrow>\<^sub>C G.G r'\<guillemotright> \<and> C.iso \<phi>"
	+ using r' C.isomorphic_symmetric by blast
	+ have \<sigma>: "tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C
	+ (G.G r') (V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>) (G.G f) (G.G g)"
	+ using \<phi> \<rho>.is_preserved_by_base_iso by simp
	+ have 1: "\<exists>\<rho>'. \<guillemotleft>\<rho>' : g \<Rightarrow>\<^sub>D H\<^sub>D r' f\<guillemotright> \<and>
	+ G.G \<rho>' = V\<^sub>C (G.\<Phi> (r', f)) (V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>)"
	+ proof -
	+ have "D.ide g"
	+ by (simp add: D.left_adjoint_is_ide g)
	+ moreover have "D.ide (H\<^sub>D r' f)"
	+ using f r' D.left_adjoint_is_ide by auto
	+ moreover have "src\<^sub>D g = src\<^sub>D (H\<^sub>D r' f)"
	+ using fg by (simp add: calculation(2))
	+ moreover have "trg\<^sub>D g = trg\<^sub>D (H\<^sub>D r' f)"
	+ using calculation(2) r' by auto
	+ moreover have
	+ "\<guillemotleft>V\<^sub>C (G.\<Phi> (r', f)) (V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>) : G.G g \<Rightarrow>\<^sub>C G.G (H\<^sub>D r' f)\<guillemotright>"
	+ using f g r' \<phi> C.hseqI' G.\<Phi>_in_hom [of r' f] D.left_adjoint_is_ide \<rho>.ide_base
	+ by (intro C.comp_in_homI, auto)
	+ ultimately show ?thesis
	+ using G.locally_full by simp
	+ qed
	+ obtain \<rho>' where \<rho>': "\<guillemotleft>\<rho>' : g \<Rightarrow>\<^sub>D H\<^sub>D r' f\<guillemotright> \<and>
	+ G.G \<rho>' = V\<^sub>C (G.\<Phi> (r', f)) (V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>)"
	+ using 1 by auto
	+ have "tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D r' \<rho>' f g"
	+ proof -
	+ have "V\<^sub>C (C.inv (G.\<Phi> (r', f))) (G.G \<rho>') = V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>"
	+ using r' f \<rho>' C.comp_assoc C.comp_cod_arr G.\<Phi>_components_are_iso
	+ C.invert_side_of_triangle(1)
	+ [of "G.G \<rho>'" "G.\<Phi> (r', f)" "V\<^sub>C (H\<^sub>C \<phi> (G.G f)) \<rho>"]
	+ by (metis (no_types, lifting) D.arrI D.in_hhom_def D.left_adjoint_is_ide G.preserves_arr)
	+ thus ?thesis
	+ using \<sigma> \<rho>' G.reflects_tabulation
	+ by (simp add: D.left_adjoint_is_ide f r')
	+ qed
	+ thus "\<exists>r' \<rho>'. tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D r' \<rho>' f g"
	+ by auto
	+ qed
	+ qed
	+ qed
	+
	+ subsection "Span(C) is a Bicategory of Spans"
	+
	+ text \<open>
	+ We first consider an arbitrary 1-cell \<open>r\<close> in \<open>Span(C)\<close>, and show that it has a tabulation
	+ as a span of maps. This is CKS Proposition 3 (stated more strongly to assert that
	+ the ``output leg'' can also be taken to be a map, which the proof shows already).
	+ \<close>
	+
	+ locale identity_arrow_in_span_bicategory =
	+ span_bicategory C prj0 prj1 +
	+ r: identity_arrow_of_spans C r
	+ for C :: "'a comp" (infixr "\<cdot>" 55)
	+ and prj0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>0[_, _]")
	+ and prj1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>1[_, _]")
	+ and r :: "'a arrow_of_spans_data"
	+ begin
	+ text \<open>
	+ CKS say: ``Suppose \<open>r = (r\<^sub>0, R, r\<^sub>1): A \<rightarrow> B\<close> and put \<open>f = (1, R, r\<^sub>0)\<close>, \<open>g = (1, R, r\<^sub>1)\<close>.
	+ Let \<open>k\<^sub>0, k\<^sub>1\<close> form a kernel pair for \<open>r\<^sub>0\<close> and define \<open>\<rho>\<close> by \<open>k\<^sub>0\<rho> = k\<^sub>1\<rho> = 1\<^sub>R\<close>.''
	+ \<close>
	+ abbreviation ra where "ra \<equiv> r.dom.apex"
	+ abbreviation r0 where "r0 \<equiv> r.dom.leg0"
	+ abbreviation r1 where "r1 \<equiv> r.dom.leg1"
	+ abbreviation f where "f \<equiv> mkIde ra r0"
	+ abbreviation g where "g \<equiv> mkIde ra r1"
	+ abbreviation k0 where "k0 \<equiv> \<p>\<^sub>0[r0, r0]"
	+ abbreviation k1 where "k1 \<equiv> \<p>\<^sub>1[r0, r0]"
	+ text \<open>
	+ Here \<open>ra\<close> is the apex \<open>R\<close> of the span \<open>(r\<^sub>0, R, r\<^sub>1)\<close>, and the spans \<open>f\<close> and \<open>g\<close> also have
	+ that same 0-cell as their apex. The tabulation 2-cell \<open>\<rho>\<close> has to be an arrow of spans
	+ from \<open>g = (1, R, r\<^sub>1)\<close> to \<open>r \<star> f\<close>, which is the span \<open>(k\<^sub>0, r\<^sub>1 \<cdot> k\<^sub>1)\<close>.
	+ \<close>
	+ abbreviation \<rho> where "\<rho> \<equiv> \<lparr>Chn = \<langle>ra \<lbrakk>r0, r0\<rbrakk> ra\<rangle>,
	+ Dom = \<lparr>Leg0 = ra, Leg1 = r1\<rparr>,
	+ Cod = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<rparr>"
	+
	+ lemma has_tabulation:
	+ shows "tabulation vcomp hcomp assoc unit src trg r \<rho> f g"
	+ and "is_left_adjoint f" and "is_left_adjoint g"
	+ proof -
	+ have ide_f: "ide f"
	+ using ide_mkIde r.dom.leg_in_hom(1) C.arr_dom C.dom_dom r.dom.apex_def r.dom.leg_simps(1)
	+ by presburger
	+ interpret f: identity_arrow_of_spans C f
	+ using ide_f ide_char' by auto
	+ have ide_g: "ide g"
	+ using ide_mkIde r.dom.leg_in_hom
	+ by (metis C.arr_dom C.dom_dom r.dom.leg_simps(3) r.dom.leg_simps(4))
	+ interpret g: identity_arrow_of_spans C g
	+ using ide_g ide_char' by auto
	+
	+ show "is_left_adjoint f"
	+ using is_left_adjoint_char [of f] ide_f by simp
	+ show "is_left_adjoint g"
	+ using is_left_adjoint_char [of g] ide_g by simp
	+
	+ have ide_r: "ide r"
	+ using ide_char' r.identity_arrow_of_spans_axioms by auto
	+ have src_r: "src r = mkObj (C.cod r0)"
	+ by (simp add: ide_r src_def)
	+ have trg_r: "trg r = mkObj (C.cod r1)"
	+ by (simp add: ide_r trg_def)
	+ have src_f: "src f = mkObj ra"
	+ using ide_f src_def by auto
	+ have trg_f: "trg f = mkObj (C.cod r0)"
	+ using ide_f trg_def by auto
	+ have src_g: "src g = mkObj ra"
	+ using ide_g src_def by auto
	+ have trg_g: "trg g = mkObj (C.cod r1)"
	+ using ide_g trg_def by auto
	+
	+ have hseq_rf: "hseq r f"
	+ using ide_r ide_f src_r trg_f by simp
	+ interpret rf: two_composable_arrows_of_spans C prj0 prj1 r f
	+ using hseq_rf hseq_char by (unfold_locales, auto)
	+ interpret rf: two_composable_identity_arrows_of_spans C prj0 prj1 r f ..
	+ interpret rf: identity_arrow_of_spans C \<open>r \<star> f\<close>
	+ using rf.ide_composite ide_char' by auto
	+ let ?rf = "r \<star> f"
	+ (* TODO: Put this expansion into two_composable_identity_arrows_of_spans. *)
	+ have rf: "?rf = \<lparr>Chn = r0 \<down>\<down> r0,
	+ Dom = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>,
	+ Cod = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<rparr>"
	+ unfolding hcomp_def chine_hcomp_def
	+ using hseq_rf C.comp_cod_arr by auto
	+
	+ interpret Cod_rf: span_in_category C \<open>\<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<close>
	+ using ide_r ide_f rf C.comp_cod_arr
	+ by (unfold_locales, auto)
	+
	+ have Dom_g: "Dom g = \<lparr>Leg0 = ra, Leg1 = r1\<rparr>" by simp
	+ interpret Dom_g: span_in_category C \<open>\<lparr>Leg0 = ra, Leg1 = r1\<rparr>\<close>
	+ using Dom_g g.dom.span_in_category_axioms by simp
	+ interpret Dom_\<rho>: span_in_category C \<open>Dom \<rho>\<close>
	+ using Dom_g g.dom.span_in_category_axioms by simp
	+ interpret Cod_\<rho>: span_in_category C \<open>Cod \<rho>\<close>
	+ using rf Cod_rf.span_in_category_axioms by simp
	+ interpret \<rho>: arrow_of_spans C \<rho>
	+ using Dom_\<rho>.apex_def Cod_\<rho>.apex_def C.comp_assoc C.comp_arr_dom
	+ by (unfold_locales, auto)
	+ have \<rho>: "\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>"
	+ proof
	+ show 1: "arr \<rho>"
	+ using arr_char \<rho>.arrow_of_spans_axioms by simp
	+ show "dom \<rho> = g"
	+ using 1 dom_char ideD(2) ide_g by fastforce
	+ show "cod \<rho> = r \<star> f"
	+ using 1 cod_char rf Cod_rf.apex_def by simp
	+ qed
	+
	+ show "tabulation vcomp hcomp assoc unit src trg r \<rho> f g"
	+ proof -
	+ interpret T: tabulation_data vcomp hcomp assoc unit src trg r \<rho> f g
	+ using ide_f \<rho> by (unfold_locales, auto)
	+ show ?thesis
	+ proof
	+ show T1: "\<And>u \<omega>.
	+ \<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
	+ \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
	+ proof -
	+ fix u \<omega>
	+ assume u: "ide u"
	+ assume \<omega>: "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
	+ show "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
	+ proof -
	+ interpret u: identity_arrow_of_spans C u
	+ using u ide_char' by auto
	+ have v: "ide (dom \<omega>)"
	+ using \<omega> by auto
	+ interpret v: identity_arrow_of_spans C \<open>dom \<omega>\<close>
	+ using v ide_char' by auto
	+ interpret \<omega>: arrow_of_spans C \<omega>
	+ using \<omega> arr_char by auto
	+ have hseq_ru: "hseq r u"
	+ using u \<omega> ide_cod by fastforce
	+ interpret ru: two_composable_arrows_of_spans C prj0 prj1 r u
	+ using hseq_ru hseq_char by (unfold_locales, auto)
	+ interpret ru: two_composable_identity_arrows_of_spans C prj0 prj1 r u ..
	+ text \<open>
	+ CKS say:
	+ ``We must show that \<open>(f, \<rho>, g)\<close> is a wide tabulation of \<open>r\<close>.
	+ Take \<open>u = (u\<^sub>0, U, u\<^sub>1): X \<rightarrow> A\<close>, \<open>v = (v\<^sub>0, V, v\<^sub>1): X \<rightarrow> B\<close>,
	+ \<open>\<omega>: v \<Rightarrow> ru\<close> as in \<open>T1\<close>. Let \<open>P\<close> be the pullback of \<open>u\<^sub>1, r\<^sub>0\<close>.
	+ Let \<open>w = (v\<^sub>0, V, p\<^sub>1\<omega>): X \<rightarrow> R\<close>, \<open>\<theta> = p\<^sub>0\<omega>: fw \<Rightarrow> u\<close>,
	+ \<open>\<nu> = 1: v \<Rightarrow> gw\<close>; so \<open>\<omega> = (r\<theta>)(\<rho>w)\<nu>\<close> as required.''
	+ \<close>
	+ let ?R = "r.apex"
	+ let ?A = "C.cod r0"
	+ let ?B = "C.cod r1"
	+ let ?U = "u.apex"
	+ let ?u0 = "u.leg0"
	+ let ?u1 = "u.leg1"
	+ let ?X = "C.cod ?u0"
	+ let ?V = "v.apex"
	+ let ?v0 = "v.leg0"
	+ let ?v1 = "v.leg1"
	+ let ?\<omega> = "\<omega>.chine"
	+ let ?P = "r0 \<down>\<down> ?u1"
	+ let ?p0 = "\<p>\<^sub>0[r0, ?u1]"
	+ let ?p1 = "\<p>\<^sub>1[r0, ?u1]"
	+ let ?w1 = "?p1 \<cdot> ?\<omega>"
	+ define w where "w = mkIde ?v0 ?w1"
	+ let ?Q = "?R \<down>\<down> ?w1"
	+ let ?q1 = "\<p>\<^sub>1[?R, ?w1]"
	+ let ?\<rho> = "\<langle>?R \<lbrakk>r0, r0\<rbrakk> ?R\<rangle>"
	+
	+ have P: "?P = ru.apex"
	+ using ru.apex_composite by auto
	+
	+ have Chn_\<omega>: "\<guillemotleft>?\<omega> : ?V \<rightarrow>\<^sub>C ?P\<guillemotright>"
	+ using P Chn_in_hom \<omega> by force
	+ have p0\<omega>: "\<guillemotleft>?p0 \<cdot> ?\<omega> : ?V \<rightarrow>\<^sub>C ?U\<guillemotright>"
	+ using Chn_\<omega> ru.legs_form_cospan by auto
	+ have w1: "\<guillemotleft>?w1 : ?V \<rightarrow>\<^sub>C ?R\<guillemotright>"
	+ using Chn_\<omega> ru.legs_form_cospan r.dom.apex_def by blast
	+ have r1w1: "r1 \<cdot> ?w1 = ?v1"
	+ by (metis C.comp_assoc T.base_simps(3) \<omega> \<omega>.leg1_commutes
	+ arrow_of_spans_data.select_convs(3) cod_char dom_char ideD(1) ideD(2)
	+ in_homE ru.composite_in_hom ru.leg1_composite u v)
	+
	+ have w: "ide w"
	+ unfolding w_def
	+ using P \<omega> w1 by (intro ide_mkIde, auto)
	+ interpret w: identity_arrow_of_spans C w
	+ using w_def w ide_char' by auto
	+
	+ have hseq_fw: "hseq f w"
	+ using w_def ide_f w src_def trg_def w1 by auto
	+ interpret fw: two_composable_arrows_of_spans C prj0 prj1 f w
	+ using w_def hseq_fw hseq_char by (unfold_locales, auto)
	+ interpret fw: two_composable_identity_arrows_of_spans C prj0 prj1 f w ..
	+
	+ have hseq_gw: "hseq g w"
	+ using w_def ide_g w src_def trg_def w1 by auto
	+ interpret gw: two_composable_arrows_of_spans C prj0 prj1 g w
	+ using hseq_gw hseq_char by (unfold_locales, auto)
	+ interpret gw: two_composable_identity_arrows_of_spans C prj0 prj1 g w ..
	+
	+ interpret rfw: three_composable_arrows_of_spans C prj0 prj1 r f w ..
	+ interpret rfw: three_composable_identity_arrows_of_spans C prj0 prj1 r f w ..
	+ have arfw: "\<guillemotleft>\<a>[r, f, w] : (r \<star> f) \<star> w \<Rightarrow> r \<star> f \<star> w\<guillemotright>"
	+ using fw.composable ide_f ide_r w rf.composable by auto
	+
	+ have fw_apex_eq: "fw.apex = ?R \<down>\<down> ?w1"
	+ using w_def fw.dom.apex_def hcomp_def hseq_fw hseq_char \<omega> C.arr_dom_iff_arr
	+ C.pbdom_def fw.chine_eq_apex fw.chine_simps(1)
	+ by auto
	+ have gw_apex_eq: "gw.apex = ?R \<down>\<down> ?w1"
	+ using w_def \<omega> w1 gw.dom.apex_def hcomp_def hseq_gw hseq_char by auto
	+ text \<open>
	+ Well, CKS say take \<open>\<theta> = p\<^sub>0\<omega>\<close>, but taking this literally and trying to define
	+ \<open>\<theta>\<close> so that \<open>Chn \<theta> = ?p\<^sub>0 \<cdot> ?\<omega>\<close>, does not yield the required \<open>dom \<theta> = ?R \<down>\<down> ?w1\<close>.
	+ We need \<open>\<guillemotleft>Chn \<theta> : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C ?U\<guillemotright>\<close>, so we have to compose with a
	+ projection, which leads to: \<open>Chn \<theta> = ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]\<close>.
	+ What CKS say is only correct if the projection \<open>\<p>\<^sub>0[?R, ?w1]\<close> is an identity,
	+ which can't be guaranteed for an arbitrary choice of pullbacks.
	+ \<close>
	+ define \<theta>
	+ where
	+ "\<theta> = \<lparr>Chn = ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1], Dom = Dom (f \<star> w), Cod = Cod u\<rparr>"
	+
	+ interpret Dom_\<theta>: span_in_category C \<open>Dom \<theta>\<close>
	+ using \<theta>_def fw.dom.span_in_category_axioms by simp
	+ interpret Cod_\<theta>: span_in_category C \<open>Cod \<theta>\<close>
	+ using \<theta>_def u.cod.span_in_category_axioms by simp
	+
	+ have Dom_\<theta>_leg0_eq: "Dom_\<theta>.leg0 = ?v0 \<cdot> \<p>\<^sub>0[?R, ?w1]"
	+ using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
	+ have Dom_\<theta>_leg1_eq: "Dom_\<theta>.leg1 = r0 \<cdot> ?q1"
	+ using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
	+ have Cod_\<theta>_leg0_eq: "Cod_\<theta>.leg0 = ?u0"
	+ using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
	+ have Cod_\<theta>_leg1_eq: "Cod_\<theta>.leg1 = ?u1"
	+ using w_def \<theta>_def hcomp_def hseq_fw hseq_char by simp
	+ have Chn_\<theta>_eq: "Chn \<theta> = ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]"
	+ using \<theta>_def by simp
	+
	+ interpret \<theta>: arrow_of_spans C \<theta>
	+ proof
	+ show 1: "\<guillemotleft>Chn \<theta> : Dom_\<theta>.apex \<rightarrow>\<^sub>C Cod_\<theta>.apex\<guillemotright>"
	+ using \<theta>_def Chn_\<omega> ru.legs_form_cospan fw_apex_eq
	+ by (intro C.in_homI, auto)
	+ show "Cod_\<theta>.leg0 \<cdot> Chn \<theta> = Dom_\<theta>.leg0"
	+ proof -
	+ have "Cod_\<theta>.leg0 \<cdot> Chn \<theta> = ?u0 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]"
	+ using Cod_\<theta>_leg0_eq Chn_\<theta>_eq by simp
	+ also have "... = ?v0 \<cdot> \<p>\<^sub>0[?R, ?w1]"
	+ proof -
	+ have "?u0 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1] = (?u0 \<cdot> ?p0 \<cdot> ?\<omega>) \<cdot> \<p>\<^sub>0[?R, ?w1]"
	+ using C.comp_assoc by simp
	+ also have "... = ?v0 \<cdot> \<p>\<^sub>0[?R, ?w1]"
	+ proof -
	+ have "?u0 \<cdot> ?p0 \<cdot> ?\<omega> = (?u0 \<cdot> ?p0) \<cdot> ?\<omega>"
	+ using C.comp_assoc by simp
	+ also have "... = \<omega>.cod.leg0 \<cdot> ?\<omega>"
	+ proof -
	+ have "\<omega>.cod.leg0 = ru.leg0"
	+ using \<omega> cod_char hcomp_def hseq_ru by auto
	+ also have "... = ?u0 \<cdot> ?p0"
	+ using hcomp_def hseq_ru by auto
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = \<omega>.dom.leg0"
	+ using \<omega>.leg0_commutes by simp
	+ also have "... = ?v0"
	+ using \<omega> dom_char by auto
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = Dom_\<theta>.leg0"
	+ using Dom_\<theta>_leg0_eq by simp
	+ finally show ?thesis by blast
	+ qed
	+ show "Cod_\<theta>.leg1 \<cdot> Chn \<theta> = Dom_\<theta>.leg1"
	+ proof -
	+ have "Cod_\<theta>.leg1 \<cdot> Chn \<theta> = ?u1 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1]"
	+ using Cod_\<theta>_leg1_eq Chn_\<theta>_eq by simp
	+ also have "... = r0 \<cdot> ?q1"
	+ proof -
	+ have "?u1 \<cdot> ?p0 \<cdot> ?\<omega> \<cdot> \<p>\<^sub>0[?R, ?w1] = ((?u1 \<cdot> ?p0) \<cdot> ?\<omega>) \<cdot> \<p>\<^sub>0[?R, ?w1]"
	+ using C.comp_assoc by fastforce
	+ also have "... = ((r0 \<cdot> ?p1) \<cdot> ?\<omega>) \<cdot> \<p>\<^sub>0[?R, ?w1]"
	+ using C.pullback_commutes' ru.legs_form_cospan by simp
	+ also have "... = r0 \<cdot> ?w1 \<cdot> \<p>\<^sub>0[?R, ?w1]"
	+ using C.comp_assoc by fastforce
	+ also have "... = r0 \<cdot> ?R \<cdot> ?q1"
	+ using \<omega> C.in_homE C.pullback_commutes' w1 by auto
	+ also have "... = r0 \<cdot> ?q1"
	+ using \<omega> w1 C.comp_cod_arr by auto
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = Dom_\<theta>.leg1"
	+ using Dom_\<theta>_leg1_eq by simp
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ text \<open>
	+ Similarly, CKS say to take \<open>\<nu> = 1: v \<Rightarrow> gw\<close>, but obviously this can't be
	+ interpreted literally, either, because \<open>v.apex\<close> and \<open>gw.apex\<close> are not equal.
	+ Instead, we have to define \<open>\<nu>\<close> so that \<open>Chn \<nu> = C.inv \<p>\<^sub>0[?R, ?w1]\<close>,
	+ noting that \<open>\<p>\<^sub>0[?R, ?w1]\<close> is the pullback of an identity,
	+ hence is an isomorphism. Then \<open>?v0 \<cdot> \<p>\<^sub>0[?R, ?w1] \<cdot> Chn \<nu> = ?v0\<close> and
	+ \<open>?v1 \<cdot> \<p>\<^sub>1[?R, ?w1] \<cdot> Chn \<nu> = ?v1 \<cdot> ?w1\<close>, showing that \<open>\<nu>\<close> is an arrow
	+ of spans.
	+ \<close>
	+ let ?\<nu>' = "\<p>\<^sub>0[?R, ?w1]"
	+ define \<nu>
	+ where
	+ "\<nu> = \<lparr>Chn = C.inv ?\<nu>', Dom = Dom (dom \<omega>), Cod = Cod (g \<star> w)\<rparr>"
	+ have iso_\<nu>: "C.inverse_arrows ?\<nu>' (Chn \<nu>)"
	+ using \<nu>_def \<omega> w1 C.iso_pullback_ide
	+ by (metis C.inv_is_inverse C.seqE arrow_of_spans_data.select_convs(1)
	+ r.chine_eq_apex r.chine_simps(1) r.chine_simps(3) r.cod_simps(1)
	+ r.dom.apex_def r.dom.ide_apex r.dom.is_span r1w1 v.dom.leg_simps(3))
	+ text \<open>
	+$$
	+\xymatrix{
	+ && X \\
	+ && V \ar[u]_{v_0} \ar[d]_{\omega} \ar@/ul50pt/[ddddll]_{v_1} \ar@/l30pt/[dd]_<>(0.7){w_1}\\
	+ & R\downarrow\downarrow w_1 \ar[ur]^{\nu'} \ar[dd]_{q_1}
	+ & r_0\downarrow\downarrow u_1 \ar[d]_{p_1} \ar@/dl10pt/[drr]_<>(0.4){p_0}
	+ & R\downarrow\downarrow w_1 \ar[ul]_{\nu'} \ar[dd]^<>(0.7){q_1} \ar@ {.>}[dr]_{\theta}\\
	+ && R && U \ar@/ur20pt/[uuull]_{u_0} \ar[dd]^{u_1} \\
	+ & R \ar[dl]_{r_1} \ar@ {<->}[ur]_{R} \ar@ {.>}[dr]^{\rho} \ar@/dl5pt/[ddr]_<>(0.4){R}
	+ && R \ar@ {<->}[ul]^{R} \ar[dr]^{r_0} \ar[ur]_{r_1}\\
	+ B && r_0\downarrow\downarrow r_0 \ar[uu]_{k_0} \ar[d]^{k_1} \ar[uu] \ar[ur]_{k_0} && A \\
	+ & & R \ar[ull]^{r_1} \ar[urr]_{r_0} \\
	+}
	+$$
	+ \<close>
	+ have w1_eq: "?w1 = ?q1 \<cdot> C.inv ?\<nu>'"
	+ proof -
	+ have "?R \<cdot> ?q1 = ?w1 \<cdot> ?\<nu>'"
	+ using iso_\<nu> \<omega> w1 C.pullback_commutes [of ?R ?w1] by blast
	+ hence "?q1 = ?w1 \<cdot> ?\<nu>'"
	+ using \<omega> w1 C.comp_cod_arr by auto
	+ thus ?thesis
	+ using iso_\<nu> \<omega> w1 r.dom.apex_def r.cod.apex_def r.chine_eq_apex
	+ C.invert_side_of_triangle(2)
	+ by (metis C.isoI C.prj1_simps(1) arrow_of_spans_data.select_convs(3)
	+ fw.legs_form_cospan(2) span_data.simps(1-2) w_def)
	+ qed
	+
	+ interpret Dom_\<nu>: span_in_category C \<open>Dom \<nu>\<close>
	+ using \<nu>_def v.dom.span_in_category_axioms by simp
	+ interpret Cod_\<nu>: span_in_category C \<open>Cod \<nu>\<close>
	+ using \<nu>_def gw.cod.span_in_category_axioms by simp
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ proof
	+ show 1: "\<guillemotleft>Chn \<nu> : Dom_\<nu>.apex \<rightarrow>\<^sub>C Cod_\<nu>.apex\<guillemotright>"
	+ proof
	+ show "C.arr (Chn \<nu>)"
	+ using iso_\<nu> by auto
	+ show "C.dom (Chn \<nu>) = Dom_\<nu>.apex"
	+ using \<nu>_def iso_\<nu> w1 gw_apex_eq by fastforce
	+ show "C.cod (Chn \<nu>) = Cod_\<nu>.apex"
	+ using \<nu>_def iso_\<nu> gw_apex_eq C.comp_inv_arr C.pbdom_def
	+ by (metis C.cod_comp arrow_of_spans_data.select_convs(3)
	+ gw.apex_composite gw.chine_composite gw.chine_simps(1) gw.chine_simps(3))
	+ qed
	+ show "Cod_\<nu>.leg0 \<cdot> Chn \<nu> = Dom_\<nu>.leg0"
	+ using w_def \<nu>_def 1 iso_\<nu> hcomp_def hseq_gw C.comp_arr_inv
	+ C.comp_assoc v.leg0_commutes
	+ by auto
	+ show "Cod_\<nu>.leg1 \<cdot> Chn \<nu> = Dom_\<nu>.leg1"
	+ using w_def \<nu>_def hcomp_def hseq_gw C.comp_assoc w1_eq r1w1
	+ by auto
	+ qed
	+ text \<open>
	+ Now we can proceed to establishing the conclusions of \<open>T1\<close>.
	+ \<close>
	+ have "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> dom \<rho> \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
	+ proof (intro conjI)
	+ show ide_w: "ide w"
	+ using w by blast
	+ show \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
	+ using \<theta>_def \<theta>.arrow_of_spans_axioms arr_char dom_char cod_char hseq_fw hseq_char
	+ hcomp_def fw.chine_eq_apex
	+ by auto
	+ show \<nu>: "\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> dom \<rho> \<star> w\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright>"
	+ using \<nu>_def \<omega> \<nu>.arrow_of_spans_axioms arr_char dom_char cod_char hseq_gw
	+ hseq_char hcomp_def gw.chine_eq_apex
	+ apply (intro in_homI) by auto
	+ thus ?thesis
	+ using T.tab_in_hom by simp
	+ qed
	+ show "iso \<nu>"
	+ using iso_\<nu> iso_char arr_char \<nu>.arrow_of_spans_axioms by auto
	+ show "T.composite_cell w \<theta> \<bullet> \<nu> = \<omega>"
	+ proof (intro arr_eqI)
	+ have \<rho>w: "\<guillemotleft>\<rho> \<star> w : g \<star> w \<Rightarrow> (r \<star> f) \<star> w\<guillemotright>"
	+ using w_def \<rho> ide_w hseq_rf hseq_fw hseq_gw by auto
	+ have r\<theta>: "\<guillemotleft>r \<star> \<theta> : r \<star> f \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
	+ using arfw ide_r \<theta> fw.composite_simps(2) rf.composable by auto
	+ have 1: "\<guillemotleft>T.composite_cell w \<theta> \<bullet> \<nu> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
	+ using \<nu> \<rho>w arfw r\<theta> by auto
	+ show "par (T.composite_cell w \<theta> \<bullet> \<nu>) \<omega>"
	+ using 1 \<omega> by (elim in_homE, auto)
	+ show "Chn (T.composite_cell w \<theta> \<bullet> \<nu>) = ?\<omega>"
	+ proof -
	+ have 2: "Chn (T.composite_cell w \<theta> \<bullet> \<nu>) =
	+ Chn (r \<star> \<theta>) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
	+ proof -
	+ have "Chn (T.composite_cell w \<theta> \<bullet> \<nu>) =
	+ Chn (T.composite_cell w \<theta>) \<cdot> Chn \<nu>"
	+ using 1 Chn_vcomp by blast
	+ also have "... = (Chn (r \<star> \<theta>) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w)) \<cdot> Chn \<nu>"
	+ proof -
	+ have "seq (r \<star> \<theta>) (\<a>[r, f, w] \<bullet> (\<rho> \<star> w)) \<and> seq \<a>[r, f, w] (\<rho> \<star> w)"
	+ using 1 by blast
	+ thus ?thesis
	+ using 1 Chn_vcomp by presburger
	+ qed
	+ finally show ?thesis
	+ using C.comp_assoc by auto
	+ qed
	+ also have "... = ?\<omega>"
	+ proof -
	+ let ?LHS = "Chn (r \<star> \<theta>) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
	+ have Chn_r\<theta>: "Chn (r \<star> \<theta>) = \<langle>r.chine \<cdot> \<p>\<^sub>1[r0, r0 \<cdot> ?q1]
	+ \<lbrakk>r0, ?u1\<rbrakk>
	+ \<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?q1]\<rangle>"
	+ using r\<theta> hcomp_def \<theta>_def chine_hcomp_def Dom_\<theta>_leg1_eq
	+ by (metis arrI arrow_of_spans_data.select_convs(1,3)
	+ hseq_char r.cod_simps(2) u.cod_simps(3))
	+ have Chn_arfw: "Chn \<a>[r, f, w] = rfw.chine_assoc"
	+ using \<alpha>_ide ide_f rf.composable fw.composable w by auto
	+ have Chn_\<rho>w: "Chn (\<rho> \<star> w) = \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
	+ proof -
	+ have "Chn (\<rho> \<star> w) =
	+ chine_hcomp
	+ \<lparr>Chn = ?\<rho>,
	+ Dom = \<lparr>Leg0 = ?R, Leg1 = r1\<rparr>,
	+ Cod = \<lparr>Leg0 = k0, Leg1 = r1 \<cdot> k1\<rparr>\<rparr>
	+ \<lparr>Chn = v.apex,
	+ Dom = \<lparr>Leg0 = ?v0, Leg1 = ?w1\<rparr>,
	+ Cod = \<lparr>Leg0 = ?v0, Leg1 = ?w1\<rparr>\<rparr>"
	+ using \<rho> ide_w hseq_rf hseq_char hcomp_def src_def trg_def
	+ by (metis (no_types, lifting) \<rho>w arrI arrow_of_spans_data.select_convs(1)
	+ v.dom.apex_def w_def)
	+ also have "... = \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?V \<cdot> ?\<nu>'\<rangle>"
	+ unfolding chine_hcomp_def by simp
	+ also have "... = \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
	+ proof -
	+ have "?V \<cdot> ?\<nu>' = ?\<nu>'"
	+ using C.comp_ide_arr v.dom.ide_apex \<rho> w1 by auto
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+
	+ have 3: "C.seq ?p1 ?\<omega>"
	+ using w1 by blast
	+ moreover have 4: "C.seq ?p1 ?LHS"
	+ proof
	+ show "\<guillemotleft>?LHS : v.apex \<rightarrow>\<^sub>C ru.apex\<guillemotright>"
	+ by (metis (no_types, lifting) 1 2 Chn_in_hom ru.chine_eq_apex
	+ v.chine_eq_apex)
	+ show "\<guillemotleft>?p1 : ru.apex \<rightarrow>\<^sub>C ?R\<guillemotright>"
	+ using P C.prj1_in_hom ru.legs_form_cospan by fastforce
	+ qed
	+ moreover have "?p0 \<cdot> ?LHS = ?p0 \<cdot> ?\<omega>"
	+ proof -
	+ have "?p0 \<cdot> ?LHS =
	+ (?p0 \<cdot> Chn (r \<star> \<theta>)) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
	+ using C.comp_assoc by simp
	+ also have "... = (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?q1]) \<cdot>
	+ Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
	+ proof -
	+ have "?p0 \<cdot> Chn (r \<star> \<theta>) = \<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?q1]"
	+ by (metis C.prj_tuple(1) Chn_r\<theta> \<theta>_def arrI Dom_\<theta>_leg1_eq
	+ arrow_of_spans_data.select_convs(3) chine_hcomp_props(2)
	+ hseq_char r.cod_simps(2) r\<theta> u.cod_simps(3))
	+ thus ?thesis by argo
	+ qed
	+ also have
	+ "... = ?p0 \<cdot> ?\<omega> \<cdot> (rfw.Prj\<^sub>0\<^sub>0 \<cdot> Chn \<a>[r, f, w]) \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
	+ using w_def \<theta>_def C.comp_assoc by simp
	+ also have "... = ?p0 \<cdot> ?\<omega> \<cdot> (rfw.Prj\<^sub>0 \<cdot> Chn (\<rho> \<star> w)) \<cdot> Chn \<nu>"
	+ using Chn_arfw rfw.prj_chine_assoc C.comp_assoc by simp
	+ also have "... = ?p0 \<cdot> ?\<omega> \<cdot> ?\<nu>' \<cdot> Chn \<nu>"
	+ proof -
	+ have "rfw.Prj\<^sub>0 \<cdot> Chn (\<rho> \<star> w) = \<p>\<^sub>0[k0, ?w1] \<cdot> \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
	+ using w_def Chn_\<rho>w C.comp_cod_arr by simp
	+ also have "... = ?\<nu>'"
	+ by (metis (no_types, lifting) C.not_arr_null C.prj_tuple(1) C.seqE
	+ C.tuple_is_extensional Chn_\<rho>w 4)
	+ finally have "rfw.Prj\<^sub>0 \<cdot> Chn (\<rho> \<star> w) = ?\<nu>'"
	+ by blast
	+ thus ?thesis by simp
	+ qed
	+ also have "... = ?p0 \<cdot> ?\<omega>"
	+ using iso_\<nu> C.comp_arr_dom
	+ by (metis (no_types, lifting) C.comp_arr_inv C.dom_comp \<nu>_def
	+ \<omega>.chine_simps(1) 3 arrow_of_spans_data.simps(1) w1_eq)
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "?p1 \<cdot> ?LHS = ?w1"
	+ proof -
	+ have "?p1 \<cdot> ?LHS =
	+ (?p1 \<cdot> Chn (r \<star> \<theta>)) \<cdot> Chn \<a>[r, f, w] \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
	+ using C.comp_assoc by simp
	+ also have "... = (r.chine \<cdot> \<p>\<^sub>1[r0, r0 \<cdot> ?q1]) \<cdot> Chn \<a>[r, f, w] \<cdot>
	+ Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
	+ by (metis (no_types, lifting) C.not_arr_null C.prj_tuple(2) C.seqE
	+ C.tuple_is_extensional Chn_r\<theta> 4)
	+ also have "... = r.chine \<cdot> (rfw.Prj\<^sub>1 \<cdot> Chn \<a>[r, f, w]) \<cdot> Chn (\<rho> \<star> w) \<cdot> Chn \<nu>"
	+ using w_def Dom_\<theta>_leg1_eq C.comp_assoc by simp
	+ also have "... = r.chine \<cdot> (rfw.Prj\<^sub>1\<^sub>1 \<cdot> Chn (\<rho> \<star> w)) \<cdot> Chn \<nu>"
	+ using Chn_arfw rfw.prj_chine_assoc(1) C.comp_assoc by simp
	+ also have "... = r.chine \<cdot> ?q1 \<cdot> Chn \<nu>"
	+ proof -
	+ have "rfw.Prj\<^sub>1\<^sub>1 \<cdot> Chn (\<rho> \<star> w) =
	+ (k1 \<cdot> \<p>\<^sub>1[k0, ?w1]) \<cdot> \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
	+ using w_def Chn_\<rho>w C.comp_cod_arr by simp
	+ also have "... = k1 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<langle>?\<rho> \<cdot> ?q1 \<lbrakk>k0, ?w1\<rbrakk> ?\<nu>'\<rangle>"
	+ using C.comp_assoc by simp
	+ also have "... = k1 \<cdot> ?\<rho> \<cdot> ?q1"
	+ by (metis (no_types, lifting) C.not_arr_null C.prj_tuple(2)
	+ C.seqE C.tuple_is_extensional Chn_\<rho>w 4)
	+ also have "... = (k1 \<cdot> ?\<rho>) \<cdot> ?q1"
	+ using C.comp_assoc by presburger
	+ also have "... = ?R \<cdot> ?q1"
	+ by simp
	+ also have "... = ?q1"
	+ by (metis Dom_\<theta>_leg1_eq C.comp_ide_arr C.prj1_simps(3)
	+ C.prj1_simps_arr C.seqE C.seqI Dom_\<theta>.leg_simps(3)
	+ r.dom.ide_apex)
	+ finally have "rfw.Prj\<^sub>1\<^sub>1 \<cdot> Chn (\<rho> \<star> w) = ?q1"
	+ by blast
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (r.chine \<cdot> ?p1) \<cdot> ?\<omega>"
	+ using \<nu>_def w1_eq C.comp_assoc by simp
	+ also have "... = ?w1"
	+ using C.comp_cod_arr r.chine_eq_apex ru.prj_simps(1) by auto
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis
	+ using ru.legs_form_cospan C.prj_joint_monic by blast
	+ qed
	+ finally show ?thesis by argo
	+ qed
	+ qed
	+ qed
	+ thus ?thesis
	+ using w_def by auto
	+ qed
	+ qed
	+
	+ show T2: "\<And>u w w' \<theta> \<theta>' \<beta>.
	+ \<lbrakk> ide w; ide w';
	+ \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
	+ T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<bullet> \<beta> \<rbrakk> \<Longrightarrow>
	+ \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>)"
	+ proof -
	+ fix u w w' \<theta> \<theta>' \<beta>
	+ assume ide_w: "ide w"
	+ assume ide_w': "ide w'"
	+ assume \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
	+ assume \<theta>': "\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>"
	+ assume \<beta>: "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
	+ assume E: "T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<bullet> \<beta>"
	+ interpret T: uw\<theta>w'\<theta>'\<beta> vcomp hcomp assoc unit src trg r \<rho> f g u w \<theta> w' \<theta>' \<beta>
	+ using ide_w ide_w' \<theta> \<theta>' \<beta> E comp_assoc
	+ by (unfold_locales, auto)
	+
	+ show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>)"
	+ proof
	+ interpret u: identity_arrow_of_spans C u
	+ using T.uw\<theta>.u_simps(1) ide_char' by auto
	+ interpret w: identity_arrow_of_spans C w
	+ using ide_w ide_char' by auto
	+ interpret w': identity_arrow_of_spans C w'
	+ using ide_w' ide_char' by auto
	+ let ?u0 = u.leg0
	+ let ?u1 = u.leg1
	+ let ?w0 = w.leg0
	+ let ?w1 = w.leg1
	+ let ?wa = "w.apex"
	+ let ?w0' = w'.leg0
	+ let ?w1' = w'.leg1
	+ let ?wa' = "w'.apex"
	+ let ?R = ra
	+ let ?p0 = "\<p>\<^sub>0[?R, ?w1]"
	+ let ?p0' = "\<p>\<^sub>0[?R, ?w1']"
	+ let ?p1 = "\<p>\<^sub>1[?R, ?w1]"
	+ let ?p1' = "\<p>\<^sub>1[?R, ?w1']"
	+
	+ interpret fw: two_composable_identity_arrows_of_spans C prj0 prj1 f w
	+ using hseq_char by (unfold_locales, auto)
	+ interpret fw': two_composable_identity_arrows_of_spans C prj0 prj1 f w'
	+ using hseq_char by (unfold_locales, auto)
	+
	+ have hseq_gw: "hseq g w"
	+ using T.leg1_in_hom by auto
	+ interpret gw: two_composable_identity_arrows_of_spans C prj0 prj1 g w
	+ using hseq_gw hseq_char by (unfold_locales, auto)
	+
	+ have hseq_gw': "hseq g w'"
	+ using T.leg1_in_hom by auto
	+ interpret gw': two_composable_identity_arrows_of_spans C prj0 prj1 g w'
	+ using hseq_gw' hseq_char by (unfold_locales, auto)
	+
	+ interpret rfw: three_composable_identity_arrows_of_spans C prj0 prj1 r f w ..
	+ interpret rfw: identity_arrow_of_spans C \<open>r \<star> f \<star> w\<close>
	+ using rfw.composites_are_identities ide_char' by auto
	+ interpret rfw': three_composable_arrows_of_spans C prj0 prj1 r f w' ..
	+ interpret rfw': three_composable_identity_arrows_of_spans C prj0 prj1 r f w' ..
	+ interpret rfw': identity_arrow_of_spans C \<open>r \<star> f \<star> w'\<close>
	+ using rfw'.composites_are_identities ide_char' by auto
	+
	+ have \<rho>w: "\<guillemotleft>\<rho> \<star> w : g \<star> w \<Rightarrow> (r \<star> f) \<star> w\<guillemotright>"
	+ using \<rho> hseq_gw by blast
	+ interpret \<rho>w: two_composable_arrows_of_spans C prj0 prj1 \<rho> w
	+ using \<rho>w by (unfold_locales, auto)
	+ have \<rho>w': "\<guillemotleft>\<rho> \<star> w' : g \<star> w' \<Rightarrow> (r \<star> f) \<star> w'\<guillemotright>"
	+ using \<rho> hseq_gw' by blast
	+ interpret \<rho>w': two_composable_arrows_of_spans C prj0 prj1 \<rho> w'
	+ using \<rho>w' by (unfold_locales, auto)
	+
	+ have arfw: "\<guillemotleft>\<a>[r, f, w] : (r \<star> f) \<star> w \<Rightarrow> r \<star> f \<star> w\<guillemotright>"
	+ using fw.composable ide_f ide_r ide_w rf.composable by auto
	+ have arfw': "\<guillemotleft>\<a>[r, f, w'] : (r \<star> f) \<star> w' \<Rightarrow> r \<star> f \<star> w'\<guillemotright>"
	+ using fw'.composable ide_f ide_r ide_w' rf.composable by auto
	+
	+ have r\<theta>: "\<guillemotleft>r \<star> \<theta> : r \<star> f \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
	+ by fastforce
	+ interpret Dom_\<theta>: span_in_category C \<open>Dom \<theta>\<close>
	+ using fw.dom.span_in_category_axioms
	+ by (metis \<theta> arrow_of_spans_data.select_convs(2) in_homE dom_char)
	+ interpret Cod_\<theta>: span_in_category C \<open>Cod \<theta>\<close>
	+ using \<theta> u.cod.span_in_category_axioms cod_char by auto
	+ interpret \<theta>: arrow_of_spans C \<theta>
	+ using arr_char by auto
	+ interpret r\<theta>: two_composable_arrows_of_spans C prj0 prj1 r \<theta>
	+ using r\<theta> by (unfold_locales, auto)
	+
	+ have r\<theta>': "\<guillemotleft>r \<star> \<theta>' : r \<star> f \<star> w' \<Rightarrow> r \<star> u\<guillemotright>"
	+ by fastforce
	+ interpret Dom_\<theta>': span_in_category C \<open>Dom \<theta>'\<close>
	+ using fw'.dom.span_in_category_axioms
	+ by (metis \<theta>' arrow_of_spans_data.select_convs(2) in_homE dom_char)
	+ interpret Cod_\<theta>': span_in_category C \<open>Cod \<theta>'\<close>
	+ using \<theta>' u.cod.span_in_category_axioms cod_char by auto
	+ interpret \<theta>': arrow_of_spans C \<theta>'
	+ using arr_char by auto
	+ interpret r\<theta>': two_composable_arrows_of_spans C prj0 prj1 r \<theta>'
	+ using r\<theta>' by (unfold_locales, auto)
	+
	+ have 7: "\<guillemotleft>T.composite_cell w' \<theta>' \<bullet> \<beta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
	+ using \<beta> \<rho>w' arfw' r\<theta>' by auto
	+ have 8: "\<guillemotleft>T.composite_cell w \<theta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
	+ using \<rho>w arfw r\<theta> by auto
	+
	+ interpret ru: two_composable_identity_arrows_of_spans C prj0 prj1 r u
	+ using hseq_char by (unfold_locales, auto)
	+
	+ interpret Dom_\<beta>: span_in_category C \<open>Dom \<beta>\<close>
	+ using \<beta> fw.dom.span_in_category_axioms arr_char
	+ by (metis comp_arr_dom in_homE gw.cod.span_in_category_axioms seq_char)
	+ interpret Cod_\<beta>: span_in_category C \<open>Cod \<beta>\<close>
	+ using \<beta> fw.cod.span_in_category_axioms arr_char
	+ by (metis (no_types, lifting) comp_arr_dom ideD(2) in_homI
	+ gw'.cod.span_in_category_axioms gw'.chine_is_identity hseq_gw' seqI'
	+ seq_char ide_char)
	+ interpret \<beta>: arrow_of_spans C \<beta>
	+ using \<beta> arr_char by auto
	+ text \<open>
	+ CKS say: ``Take \<open>u\<close>, \<open>w\<close>, \<open>w'\<close>, \<open>\<theta>\<close>, \<open>\<theta>'\<close> as in \<open>T2\<close> and note that
	+ \<open>fw = (w\<^sub>0, W, r\<^sub>0 w\<^sub>1)\<close>, \<open>gw = (w\<^sub>0, W, r\<^sub>1 w\<^sub>1)\<close>, \emph{etc}.
	+ So \<open>\<beta>: W \<rightarrow> W'\<close> satisfies \<open>w\<^sub>0 = w\<^sub>0' \<beta>\<close>, \<open>r\<^sub>1 w\<^sub>1 = r\<^sub>1 w\<^sub>1' \<beta>\<close>.
	+ But the equation \<open>(r\<theta>)(\<rho>w) = (r\<theta>')(\<rho>w')\<beta>\<close> gives \<open>w\<^sub>1 = w\<^sub>1'\<close>.
	+ So \<open>\<gamma> = \<beta> : w \<Rightarrow> w'\<close> is unique with \<open>\<beta> = g \<gamma>, \<theta> = \<theta>' (f \<gamma>).\<close>''
	+
	+ Once again, there is substantial punning in the proof sketch given by CKS.
	+ We can express \<open>fw\<close> and \<open>gw\<close> almost in the form they indicate, but projections
	+ are required.
	+ \<close>
	+ have cospan: "C.cospan ?R ?w1"
	+ using hseq_char [of \<rho> w] src_def trg_def by auto
	+ have cospan': "C.cospan ?R ?w1'"
	+ using hseq_char [of \<rho> w'] src_def trg_def by auto
	+ have fw: "f \<star> w = \<lparr>Chn = ?R \<down>\<down> ?w1,
	+ Dom = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r0 \<cdot> ?p1\<rparr>,
	+ Cod = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r0 \<cdot> ?p1\<rparr>\<rparr>"
	+ using ide_f hseq_char hcomp_def chine_hcomp_def fw.dom.apex_def cospan
	+ fw.chine_eq_apex
	+ by auto
	+ have gw: "g \<star> w = \<lparr>Chn = ?R \<down>\<down> ?w1,
	+ Dom = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>,
	+ Cod = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>\<rparr>"
	+ using hseq_gw hseq_char hcomp_def chine_hcomp_def gw.dom.apex_def cospan
	+ gw.chine_eq_apex
	+ by auto
	+ have fw': "f \<star> w' = \<lparr>Chn = ?R \<down>\<down> ?w1',
	+ Dom = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r0 \<cdot> ?p1'\<rparr>,
	+ Cod = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r0 \<cdot> ?p1'\<rparr>\<rparr>"
	+ using ide_f hseq_char hcomp_def chine_hcomp_def fw'.dom.apex_def cospan'
	+ fw'.chine_eq_apex
	+ by auto
	+ have gw': "g \<star> w' = \<lparr>Chn = ?R \<down>\<down> ?w1',
	+ Dom = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>,
	+ Cod = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>\<rparr>"
	+ using hseq_gw' hseq_char hcomp_def chine_hcomp_def gw'.dom.apex_def cospan'
	+ gw'.chine_eq_apex
	+ by auto
	+ text \<open>
	+ Note that \<open>?p0\<close> and \<open>?p0'\<close> are only isomorphisms, not identities,
	+ and we have \<open>?p1\<close> (which equals \<open>?w1 \<cdot> ?p0\<close>) and \<open>?p1'\<close> (which equals \<open>?w1' \<cdot> ?p0'\<close>)
	+ in place of \<open>?w1\<close> and \<open>?w1'\<close>.
	+ \<close>
	+ text \<open>
	+ The following diagram summarizes the
	+ various given and defined arrows involved in the proof.
	+ We have deviated slightly here from the nomenclature used in in CKS.
	+ We prefer to use \<open>W\<close> and \<open>W'\<close> to denote the apexes of
	+ \<open>w\<close> and \<open>w'\<close>, respectively.
	+ We already have the expressions \<open>?R \<down>\<down> ?w1\<close> and \<open>?R \<down>\<down> ?w1'\<close> for the
	+ apexes of \<open>fw\<close> and \<open>fw'\<close> (which are the same as the apexes of
	+ \<open>gw\<close> and \<open>gw'\<close>, respectively) and we will not use any abbreviation for them.
	+ \<close>
	+ text \<open>
	+$$
	+\xymatrix{
	+ &&& X \\
	+ && W \ar[ur]^{w_0} \ar[dr]_{w_1} \ar@ {.>}[rr]^{\gamma}
	+ && W' \ar[ul]_{w_0'} \ar[dl]^{w_1'} && U \ar@/r10pt/[dddl]^{u_1} \ar@/u7pt/[ulll]_{u_0}\\
	+ & R\downarrow\downarrow w_1 \ar[ur]_{p_0} \ar[dr]^{p_1} \ar@/d15pt/[rrrr]_{\beta}
	+ \ar@/u100pt/[urrrrr]^{\theta}
	+ && R && R \downarrow\downarrow w_1' \ar[ul]^{p_0'} \ar[dl]^{p_1'} \ar[ur]_{\theta'} \\
	+ && R \ar@ {.>}[dr]_{\rho} \ar@/dl7pt/[ddr]_{R} \ar[ur]_{R} \ar[dl]_{r_1} \ar@ {<->}[rr]_{R}
	+ && R \ar[ul]^{R} \ar[dr]_{r_0} \\
	+ & B && r_0 \downarrow\downarrow r_0 \ar[d]^{k_1} \ar[ur]_{k_0} && A \\
	+ &&& R \ar@/dr10pt/[urr]_{r_0} \ar@/dl5pt/[ull]^{r_1}
	+}
	+$$
	+ \<close>
	+ have Chn_\<beta>: "\<guillemotleft>\<beta>.chine: ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C ?R \<down>\<down> ?w1'\<guillemotright>"
	+ using gw gw' Chn_in_hom \<beta> gw'.chine_eq_apex gw.chine_eq_apex by force
	+ have \<beta>_eq: "\<beta> = \<lparr>Chn = \<beta>.chine,
	+ Dom = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>,
	+ Cod = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>\<rparr>"
	+ using \<beta> gw gw' dom_char cod_char by auto
	+ have Dom_\<beta>_eq: "Dom \<beta> = \<lparr>Leg0 = ?w0 \<cdot> ?p0, Leg1 = r1 \<cdot> ?p1\<rparr>"
	+ using \<beta> gw gw' dom_char cod_char by auto
	+ have Cod_\<beta>_eq: "Cod \<beta> = \<lparr>Leg0 = ?w0' \<cdot> ?p0', Leg1 = r1 \<cdot> ?p1'\<rparr>"
	+ using \<beta> gw gw' dom_char cod_char by auto
	+
	+ have \<beta>0: "?w0 \<cdot> ?p0 = ?w0' \<cdot> ?p0' \<cdot> \<beta>.chine"
	+ using Dom_\<beta>_eq Cod_\<beta>_eq \<beta>.leg0_commutes C.comp_assoc by simp
	+ have \<beta>1: "r1 \<cdot> ?p1 = r1 \<cdot> ?p1' \<cdot> \<beta>.chine"
	+ using Dom_\<beta>_eq Cod_\<beta>_eq \<beta>.leg1_commutes C.comp_assoc by simp
	+
	+ have Dom_\<theta>_0: "Dom_\<theta>.leg0 = ?w0 \<cdot> ?p0"
	+ using arrI dom_char fw T.uw\<theta>.\<theta>_simps(4) by auto
	+ have Cod_\<theta>_0: "Cod_\<theta>.leg0 = ?u0"
	+ using \<theta> cod_char by auto
	+ have Dom_\<theta>_1: "Dom_\<theta>.leg1 = r0 \<cdot> ?p1"
	+ using arrI dom_char fw T.uw\<theta>.\<theta>_simps(4) by auto
	+ have Cod_\<theta>_1: "Cod_\<theta>.leg1 = ?u1"
	+ using T.uw\<theta>.\<theta>_simps(5) cod_char by auto
	+ have Dom_\<theta>'_0: "Dom_\<theta>'.leg0 = ?w0' \<cdot> ?p0'"
	+ using dom_char fw' T.uw'\<theta>'.\<theta>_simps(4) by auto
	+ have Cod_\<theta>'_0: "Cod_\<theta>'.leg0 = ?u0"
	+ using T.uw'\<theta>'.\<theta>_simps(5) cod_char by auto
	+ have Dom_\<theta>'_1: "Dom_\<theta>'.leg1 = r0 \<cdot> ?p1'"
	+ using dom_char fw' T.uw'\<theta>'.\<theta>_simps(4) by auto
	+ have Cod_\<theta>'_1: "Cod_\<theta>'.leg1 = ?u1"
	+ using T.uw'\<theta>'.\<theta>_simps(5) cod_char by auto
	+ have Dom_\<rho>_0: "Dom_\<rho>.leg0 = ?R"
	+ by simp
	+ have Dom_\<rho>_1: "Dom_\<rho>.leg1 = r1"
	+ by simp
	+ have Cod_\<rho>_0: "Cod_\<rho>.leg0 = k0"
	+ by simp
	+ have Cod_\<rho>_1: "Cod_\<rho>.leg1 = r1 \<cdot> k1"
	+ by simp
	+
	+ have Chn_r\<theta>: "\<guillemotleft>r\<theta>.chine : rfw.chine \<rightarrow>\<^sub>C ru.chine\<guillemotright>"
	+ using r\<theta>.chine_composite_in_hom ru.chine_composite rfw.chine_composite
	+ Cod_\<theta>_1 Dom_\<theta>_1 fw.leg1_composite
	+ by auto
	+ have Chn_r\<theta>_eq: "r\<theta>.chine = \<langle>\<p>\<^sub>1[r0, r0 \<cdot> ?p1] \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1]\<rangle>"
	+ using r\<theta>.chine_composite Cod_\<theta>_1 Dom_\<theta>_1 fw.leg1_composite C.comp_cod_arr
	+ by (metis arrow_of_spans_data.simps(2) fw r.chine_eq_apex r.cod_simps(2)
	+ rfw.prj_simps(10) rfw.prj_simps(16) span_data.simps(2))
	+
	+ have r\<theta>_cod_apex_eq: "r\<theta>.cod.apex = r0 \<down>\<down> ?u1"
	+ using Cod_\<theta>_1 r\<theta>.chine_composite_in_hom by auto
	+ hence r\<theta>'_cod_apex_eq: "r\<theta>'.cod.apex = r0 \<down>\<down> ?u1"
	+ using Cod_\<theta>'_1 r\<theta>'.chine_composite_in_hom by auto
	+
	+ have Chn_r\<theta>': "\<guillemotleft>r\<theta>'.chine : rfw'.chine \<rightarrow>\<^sub>C ru.chine\<guillemotright>"
	+ using r\<theta>'.chine_composite_in_hom ru.chine_composite rfw'.chine_composite
	+ Cod_\<theta>'_1 Dom_\<theta>'_1 fw'.leg1_composite
	+ by auto
	+ have Chn_r\<theta>'_eq: "r\<theta>'.chine =
	+ \<langle>\<p>\<^sub>1[r0, r0 \<cdot> ?p1'] \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1']\<rangle>"
	+ using r\<theta>'.chine_composite Cod_\<theta>'_1 Dom_\<theta>'_1 fw'.leg1_composite C.comp_cod_arr
	+ by (metis arrow_of_spans_data.simps(2) fw' r.chine_eq_apex r.cod_simps(2)
	+ rfw'.prj_simps(10) rfw'.prj_simps(16) span_data.simps(2))
	+
	+ have Chn_\<rho>w: "\<guillemotleft>\<rho>w.chine : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C k0 \<down>\<down> ?w1\<guillemotright>"
	+ using \<rho>w.chine_composite_in_hom by simp
	+ have Chn_\<rho>w_eq: "\<rho>w.chine = \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
	+ using \<rho>w.chine_composite C.comp_cod_arr ide_w
	+ by (simp add: chine_hcomp_arr_ide hcomp_def)
	+ have Chn_\<rho>w': "\<guillemotleft>\<rho>w'.chine : ?R \<down>\<down> ?w1' \<rightarrow>\<^sub>C k0 \<down>\<down> ?w1'\<guillemotright>"
	+ using \<rho>w'.chine_composite_in_hom by simp
	+ have Chn_\<rho>w'_eq: "\<rho>w'.chine = \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> ?p0'\<rangle>"
	+ using \<rho>w'.chine_composite C.comp_cod_arr ide_w' Dom_\<rho>_0 Cod_\<rho>_0
	+ by (metis \<rho>w'.composite_is_arrow chine_hcomp_arr_ide chine_hcomp_def hseq_char
	+ w'.cod_simps(3))
	+
	+ text \<open>
	+ The following are some collected commutativity properties that are used
	+ subsequently.
	+ \<close>
	+ have "C.commutative_square r0 ?u1 ?p1 \<theta>.chine"
	+ using ru.legs_form_cospan(1) Dom_\<theta>.is_span Dom_\<theta>_1 Cod_\<theta>_1 \<theta>.leg1_commutes
	+ apply (intro C.commutative_squareI) by auto
	+ have "C.commutative_square r0 ?u1 (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
	+ proof
	+ have 1: "r0 \<cdot> ?p1' = ?u1 \<cdot> \<theta>'.chine"
	+ using \<theta>'.leg1_commutes Cod_\<theta>'_1 Dom_\<theta>'_1 fw'.leg1_composite by simp
	+ show "C.cospan r0 ?u1"
	+ using ru.legs_form_cospan(1) by blast
	+ show "C.span (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
	+ using \<beta>.chine_in_hom \<theta>'.chine_in_hom
	+ by (metis "1" C.dom_comp C.in_homE C.prj1_simps(1) C.prj1_simps(2)
	+ C.seqI Cod_\<theta>'_1 Dom_\<theta>'.leg_simps(3) Chn_\<beta> \<theta>'.leg1_commutes cospan')
	+ show "C.dom r0 = C.cod (?p1' \<cdot> \<beta>.chine)"
	+ using \<beta>.chine_in_hom
	+ by (metis C.cod_comp C.prj1_simps(3)
	+ \<open>C.span (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>
	+ cospan' r.dom.apex_def r.chine_eq_apex r.chine_simps(2))
	+ show "r0 \<cdot> ?p1' \<cdot> \<beta>.chine = ?u1 \<cdot> \<theta>'.chine \<cdot> \<beta>.chine"
	+ using 1 \<beta>.chine_in_hom C.comp_assoc by metis
	+ qed
	+ have "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1] (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])"
	+ using ru.legs_form_cospan(1) Dom_\<theta>.is_span Dom_\<theta>_1
	+ C.comp_assoc C.pullback_commutes' r\<theta>.legs_form_cospan(1)
	+ apply (intro C.commutative_squareI)
	+ apply auto
	+ by (metis C.comp_assoc Cod_\<theta>_1 \<theta>.leg1_commutes)
	+ hence "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1] (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])"
	+ using fw.leg1_composite by auto
	+ have "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1'] (\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])"
	+ using C.tuple_is_extensional Chn_r\<theta>'_eq r\<theta>'.chine_simps(1) fw' by force
	+ have "C.commutative_square ra ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0"
	+ using C.pullback_commutes' gw.legs_form_cospan(1) rfw.prj_simps(2) C.comp_assoc
	+ C.comp_cod_arr
	+ apply (intro C.commutative_squareI) by auto
	+ have "C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0"
	+ using cospan'
	+ apply (intro C.commutative_squareI)
	+ apply simp_all
	+ by (metis C.comp_assoc C.prj0_simps_arr C.pullback_commutes'
	+ arrow_of_spans_data.select_convs(2) rfw'.prj_simps(3)
	+ span_data.select_convs(1-2))
	+ have "C.commutative_square r0 (r0 \<cdot> ?p1) rfw.Prj\<^sub>1\<^sub>1 \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>"
	+ proof -
	+ have "C.arr rfw.chine_assoc"
	+ by (metis C.seqE rfw.prj_chine_assoc(1) rfw.prj_simps(1))
	+ thus ?thesis
	+ using C.tuple_is_extensional rfw.chine_assoc_def by fastforce
	+ qed
	+ have "C.commutative_square r0 (r0 \<cdot> ?p1') rfw'.Prj\<^sub>1\<^sub>1 \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>"
	+ by (metis (no_types, lifting) C.not_arr_null C.seqE C.tuple_is_extensional
	+ arrow_of_spans_data.select_convs(2) rfw'.chine_assoc_def
	+ rfw'.prj_chine_assoc(1) rfw'.prj_simps(1) span_data.select_convs(1-2))
	+ have "C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0"
	+ using C.tuple_is_extensional Chn_\<rho>w_eq \<rho>w.chine_simps(1) by fastforce
	+ have "C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')"
	+ using C.tuple_is_extensional \<rho>w'.chine_composite \<rho>w'.chine_simps(1) by force
	+ have "C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') ?p0'"
	+ using C.tuple_is_extensional Chn_\<rho>w'_eq \<rho>w'.chine_simps(1) by force
	+ text \<open>
	+ Now, derive the consequences of the equation:
	+ \[
	+ \<open>(r \<star> \<theta>) \<bullet> \<a>[r, ?f, w] \<bullet> (?\<rho> \<star> w) = (r \<star> \<theta>') \<bullet> \<a>[r, ?f, w'] \<bullet> (?\<rho> \<star> w') \<bullet> \<beta>\<close>
	+ \]
	+ The strategy is to expand and simplify the left and right hand side to tuple form,
	+ then compose with projections and equate corresponding components.
	+
	+ We first work on the right-hand side.
	+ \<close>
	+ have R: "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) =
	+ \<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
	+ proof -
	+ have "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) =
	+ r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
	+ proof -
	+ have 1: "\<guillemotleft>T.composite_cell w' \<theta>' \<bullet> \<beta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
	+ using \<beta> \<rho>w' arfw' r\<theta>' by auto
	+ have "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) = Chn (T.composite_cell w' \<theta>') \<cdot> \<beta>.chine"
	+ using 1 Chn_vcomp by blast
	+ also have "... = (r\<theta>'.chine \<cdot> Chn (\<a>[r, f, w'] \<bullet> (\<rho> \<star> w'))) \<cdot> \<beta>.chine"
	+ proof -
	+ have "seq (r \<star> \<theta>') (\<a>[r, f, w'] \<bullet> (\<rho> \<star> w'))"
	+ using 1 by blast
	+ thus ?thesis
	+ using 1 Chn_vcomp by presburger
	+ qed
	+ also have "... = (r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
	+ proof -
	+ have "seq \<a>[r, f, w'] (\<rho> \<star> w')"
	+ using 1 by blast
	+ thus ?thesis
	+ using 1 Chn_vcomp by presburger
	+ qed
	+ finally show ?thesis
	+ using C.comp_assoc by auto
	+ qed
	+ also have "... = \<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
	+ proof -
	+ let ?LHS = "r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
	+ let ?RHS = "\<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
	+
	+ have LHS: "\<guillemotleft>?LHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
	+ proof (intro C.comp_in_homI)
	+ show "\<guillemotleft>\<beta>.chine : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C ?R \<down>\<down> ?w1'\<guillemotright>"
	+ using Chn_\<beta> by simp
	+ show "\<guillemotleft>\<rho>w'.chine : ?R \<down>\<down> ?w1' \<rightarrow>\<^sub>C Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1\<guillemotright>"
	+ using Chn_\<rho>w' by simp
	+ show "\<guillemotleft>Chn \<a>[r, f, w'] : Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1 \<rightarrow>\<^sub>C rfw'.chine\<guillemotright>"
	+ using arfw'
	+ by (metis (no_types, lifting) Chn_in_hom Cod_\<rho>_0
	+ arrow_of_spans_data.simps(2) rf rf.leg0_composite rfw'.chine_composite(1)
	+ span_data.select_convs(1) w'.cod_simps(3))
	+ show "\<guillemotleft>r\<theta>'.chine : rfw'.chine \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
	+ using Chn_r\<theta>' by auto
	+ qed
	+ have 2: "C.commutative_square r0 ?u1
	+ (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
	+ by fact
	+ have RHS: "\<guillemotleft>?RHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
	+ using 2 Chn_\<beta> r\<theta>'_cod_apex_eq
	+ C.tuple_in_hom [of r0 ?u1 "?p1' \<cdot> \<beta>.chine" "\<theta>'.chine \<cdot> \<beta>.chine"]
	+ by fastforce
	+
	+ show ?thesis
	+ proof (intro C.prj_joint_monic [of r0 ?u1 ?LHS ?RHS])
	+ show "C.cospan r0 ?u1"
	+ using ru.legs_form_cospan(1) by blast
	+ show "C.seq ru.prj\<^sub>1 ?LHS"
	+ using LHS r\<theta>'_cod_apex_eq by auto
	+ show "C.seq ru.prj\<^sub>1 ?RHS"
	+ using RHS r\<theta>'_cod_apex_eq by auto
	+ show "ru.prj\<^sub>0 \<cdot> ?LHS = ru.prj\<^sub>0 \<cdot> ?RHS"
	+ proof -
	+ have "ru.prj\<^sub>0 \<cdot> ?LHS =
	+ (ru.prj\<^sub>0 \<cdot> r\<theta>'.chine) \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
	+ using C.comp_assoc by simp
	+ also have "... = ((\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1']) \<cdot> Chn \<a>[r, f, w']) \<cdot>
	+ \<rho>w'.chine \<cdot> \<beta>.chine"
	+ using Chn_r\<theta>'_eq C.comp_assoc fw'
	+ \<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1']
	+ (\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])\<close>
	+ by simp
	+ also have "... = \<theta>'.chine \<cdot> (\<p>\<^sub>0[r0, r0 \<cdot> ?p1'] \<cdot> Chn \<a>[r, f, w']) \<cdot>
	+ \<rho>w'.chine \<cdot> \<beta>.chine"
	+ using C.comp_assoc by simp
	+ also have "... = \<theta>'.chine \<cdot> (\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine) \<cdot>
	+ \<beta>.chine"
	+ using ide_f hseq_rf hseq_char \<alpha>_ide C.comp_assoc
	+ rfw'.chine_assoc_def fw'.leg1_composite C.prj_tuple(1)
	+ \<open>C.commutative_square r0 (r0 \<cdot> ?p1')
	+ rfw'.Prj\<^sub>1\<^sub>1 \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>\<close>
	+ by simp
	+ also have "... = \<theta>'.chine \<cdot> \<beta>.chine"
	+ proof -
	+ have "\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine = gw'.apex"
	+ proof (intro C.prj_joint_monic
	+ [of ?R ?w1' "\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine"
	+ gw'.apex])
	+ show "C.cospan ?R ?w1'"
	+ using fw'.legs_form_cospan(1) by simp
	+ show "C.seq ?p1' (\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine)"
	+ proof (intro C.seqI' C.comp_in_homI)
	+ show "\<guillemotleft>\<rho>w'.chine : Dom_\<rho>.leg0 \<down>\<down> w'.leg1 \<rightarrow>\<^sub>C Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1\<guillemotright>"
	+ using \<rho>w'.chine_composite_in_hom by simp
	+ show "\<guillemotleft>\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, w'.leg1\<rbrakk> rfw'.Prj\<^sub>0\<rangle> :
	+ Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1 \<rightarrow>\<^sub>C ?R \<down>\<down> w'.leg1\<guillemotright>"
	+ using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close>
	+ C.tuple_in_hom [of ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0]
	+ rf rf.leg0_composite
	+ by auto
	+ show "\<guillemotleft>?p1' : ?R \<down>\<down> w'.leg1 \<rightarrow>\<^sub>C f.apex\<guillemotright>"
	+ using fw'.prj_in_hom(1) by auto
	+ qed
	+ show "C.seq ?p1' gw'.apex"
	+ using gw'.dom.apex_def gw'.leg0_composite fw'.prj_in_hom by auto
	+ show "?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
	+ ?p0' \<cdot> gw'.apex"
	+ proof -
	+ have "?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
	+ (?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w'.chine"
	+ using C.comp_assoc by simp
	+ also have "... = rfw'.Prj\<^sub>0 \<cdot> \<rho>w'.chine"
	+ using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close> by auto
	+ also have
	+ "... = \<p>\<^sub>0[k0, ?w1'] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> w'.chine \<cdot> ?p0'\<rangle>"
	+ using \<rho>w'.chine_composite Dom_\<rho>_0 Cod_\<rho>_0 C.comp_cod_arr by simp
	+ also have "... = w'.chine \<cdot> ?p0'"
	+ using \<open>C.commutative_square k0 ?w1'
	+ (\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')\<close>
	+ by simp
	+ also have "... = ?p0' \<cdot> gw'.apex"
	+ using cospan C.comp_cod_arr C.comp_arr_dom gw'.chine_is_identity
	+ gw'.chine_eq_apex gw'.chine_composite fw'.prj_in_hom
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ show "?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
	+ ?p1' \<cdot> gw'.apex"
	+ proof -
	+ have "?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
	+ (?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w'.chine"
	+ using C.comp_assoc by simp
	+ also have "... = rfw'.Prj\<^sub>0\<^sub>1 \<cdot> \<rho>w'.chine"
	+ using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close> by simp
	+ also have
	+ "... = k0 \<cdot> \<p>\<^sub>1[k0, ?w1'] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> w'.chine \<cdot> ?p0'\<rangle>"
	+ using \<rho>w'.chine_composite Cod_\<rho>_0 C.comp_assoc C.comp_cod_arr
	+ by simp
	+ also have "... = k0 \<cdot> \<rho>.chine \<cdot> ?p1'"
	+ using \<open>C.commutative_square k0 ?w1'
	+ (\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')\<close>
	+ by simp
	+ also have "... = (k0 \<cdot> \<rho>.chine) \<cdot> ?p1'"
	+ using C.comp_assoc by metis
	+ also have "... = ?p1'"
	+ using \<rho>.leg0_commutes C.comp_cod_arr cospan' by simp
	+ also have "... = ?p1' \<cdot> gw'.apex"
	+ using C.comp_arr_dom cospan' gw'.chine_eq_apex gw'.chine_composite
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using Chn_\<beta> C.comp_cod_arr gw'.apex_composite by auto
	+ qed
	+ also have "... = \<p>\<^sub>0[r0, ?u1] \<cdot> ?RHS"
	+ using RHS 2 C.prj_tuple [of r0 ?u1] by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "ru.prj\<^sub>1 \<cdot> ?LHS = ru.prj\<^sub>1 \<cdot> ?RHS"
	+ proof -
	+ have "ru.prj\<^sub>1 \<cdot> ?LHS =
	+ (ru.prj\<^sub>1 \<cdot> r\<theta>'.chine) \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
	+ using C.comp_assoc by simp
	+ also have "... = \<p>\<^sub>1[r0, fw'.leg1] \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
	+ using Chn_r\<theta>' Chn_r\<theta>'_eq fw'
	+ \<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1']
	+ (\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])\<close>
	+ by simp
	+ also have "... = (rfw'.Prj\<^sub>1 \<cdot> rfw'.chine_assoc) \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
	+ using ide_f ide_w' hseq_rf hseq_char \<alpha>_ide fw'.leg1_composite C.comp_assoc
	+ by auto
	+ also have "... = (rfw'.Prj\<^sub>1\<^sub>1 \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
	+ using rfw'.prj_chine_assoc C.comp_assoc by simp
	+ also have "... = ((k1 \<cdot> \<p>\<^sub>1[k0, ?w1']) \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
	+ using C.comp_cod_arr by simp
	+ also have "... = (k1 \<cdot> \<p>\<^sub>1[k0, ?w1'] \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
	+ using C.comp_assoc by simp
	+ also have "... = (k1 \<cdot> \<rho>.chine \<cdot> ?p1') \<cdot> \<beta>.chine"
	+ using Chn_\<rho>w'_eq Dom_\<rho>_0 Cod_\<rho>_0
	+ \<open>C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') ?p0'\<close>
	+ by simp
	+ also have "... = (k1 \<cdot> \<rho>.chine) \<cdot> ?p1' \<cdot> \<beta>.chine"
	+ using C.comp_assoc by metis
	+ also have "... = (?R \<cdot> ?p1') \<cdot> \<beta>.chine"
	+ using C.comp_assoc by simp
	+ also have "... = ?p1' \<cdot> \<beta>.chine"
	+ using C.comp_cod_arr C.prj1_in_hom [of ?R ?w1'] cospan' by simp
	+ also have "... = ru.prj\<^sub>1 \<cdot> ?RHS"
	+ using RHS 2 by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ text \<open>
	+ Now we work on the left-hand side.
	+ \<close>
	+ have L: "Chn (T.composite_cell w \<theta>) = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
	+ proof -
	+ have "Chn (T.composite_cell w \<theta>) = r\<theta>.chine \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
	+ using Chn_vcomp arfw C.comp_assoc by auto
	+ moreover have "... = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
	+ proof -
	+ let ?LHS = "r\<theta>.chine \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
	+ let ?RHS = "\<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
	+ have 2: "C.commutative_square r0 ?u1 ?p1 \<theta>.chine" by fact
	+ have LHS: "\<guillemotleft>?LHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r0 \<down>\<down> ?u1\<guillemotright>"
	+ using Chn_r\<theta> Chn_\<rho>w rfw.chine_assoc_in_hom
	+ by (metis (no_types, lifting) "8" Chn_in_hom Dom_\<rho>_0
	+ arrow_of_spans_data.simps(2) calculation gw.chine_composite
	+ r\<theta>_cod_apex_eq ru.chine_composite)
	+ have RHS: "\<guillemotleft>?RHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r0 \<down>\<down> ?u1\<guillemotright>"
	+ using 2 C.tuple_in_hom [of r0 ?u1 "?p1" \<theta>.chine] cospan r\<theta>_cod_apex_eq
	+ by simp
	+ show ?thesis
	+ proof (intro C.prj_joint_monic [of r0 ?u1 ?LHS ?RHS])
	+ show "C.cospan r0 ?u1"
	+ using ru.legs_form_cospan(1) by blast
	+ show "C.seq ru.prj\<^sub>1 ?LHS"
	+ using LHS r\<theta>_cod_apex_eq by auto
	+ show "C.seq ru.prj\<^sub>1 ?RHS"
	+ using RHS r\<theta>_cod_apex_eq by auto
	+ show "ru.prj\<^sub>0 \<cdot> ?LHS = ru.prj\<^sub>0 \<cdot> ?RHS"
	+ proof -
	+ have "ru.prj\<^sub>0 \<cdot> ?LHS = (ru.prj\<^sub>0 \<cdot> r\<theta>.chine) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
	+ using C.comp_assoc by simp
	+ also have "... = (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, f.leg1 \<cdot> fw.prj\<^sub>1]) \<cdot>
	+ Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
	+ using Chn_r\<theta>_eq Dom_\<theta>_1 Cod_\<theta>_1 fw.leg1_composite
	+ \<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1]
	+ (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])\<close>
	+ by simp
	+ also have "... = \<theta>.chine \<cdot> (\<p>\<^sub>0[r0, r0 \<cdot> ?p1] \<cdot> Chn \<a>[r, f, w]) \<cdot> \<rho>w.chine"
	+ using C.comp_assoc by simp
	+ also have "... = \<theta>.chine \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine"
	+ proof -
	+ have "Chn \<a>[r, f, w] = rfw.chine_assoc"
	+ using ide_f ide_w hseq_rf hseq_char \<alpha>_ide by auto
	+ moreover have "\<p>\<^sub>0[r0, r0 \<cdot> ?p1] \<cdot> rfw.chine_assoc =
	+ \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>"
	+ using rfw.chine_assoc_def
	+ \<open>C.commutative_square r0 (r0 \<cdot> ?p1) rfw.Prj\<^sub>1\<^sub>1
	+ \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>\<close>
	+ by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = \<theta>.chine \<cdot> (?R \<down>\<down> ?w1)"
	+ proof -
	+ have "\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine = ?R \<down>\<down> ?w1"
	+ proof (intro C.prj_joint_monic
	+ [of ?R ?w1 "\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine"
	+ "?R \<down>\<down> ?w1"])
	+ show "C.cospan ?R ?w1" by fact
	+ show "C.seq ?p1 (\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine)"
	+ proof -
	+ have "C.seq rfw.Prj\<^sub>0\<^sub>1 \<rho>w.chine"
	+ by (meson C.seqI' Chn_in_hom \<rho>w rfw.prj_in_hom(2)
	+ \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close>)
	+ thus ?thesis
	+ using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close>
	+ by (metis (no_types) C.comp_assoc C.prj_tuple(2))
	+ qed
	+ show "C.seq ?p1 (?R \<down>\<down> ?w1)"
	+ using gw.dom.apex_def gw.leg0_composite gw.prj_in_hom by auto
	+ show "?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
	+ ?p0 \<cdot> (?R \<down>\<down> ?w1)"
	+ proof -
	+ have "?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
	+ (?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w.chine"
	+ using C.comp_assoc by simp
	+ also have "... = rfw.Prj\<^sub>0 \<cdot> \<rho>w.chine"
	+ using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close> by simp
	+ also have "... = \<p>\<^sub>0[k0, ?w1] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
	+ using Chn_\<rho>w_eq C.comp_cod_arr by simp
	+ also have "... = ?p0"
	+ using \<open>C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0\<close>
	+ C.prj_tuple(1)
	+ by blast
	+ also have "... = ?p0 \<cdot> (?R \<down>\<down> ?w1)"
	+ using C.comp_arr_dom gw.chine_eq_apex gw.chine_is_identity
	+ by (metis C.arr_dom_iff_arr C.pbdom_def Dom_g gw.chine_composite
	+ gw.chine_simps(1) span_data.select_convs(1))
	+ finally show ?thesis by simp
	+ qed
	+ show "?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
	+ ?p1 \<cdot> (?R \<down>\<down> ?w1)"
	+ proof -
	+ have "?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
	+ (?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w.chine"
	+ using C.comp_assoc by simp
	+ also have "... = rfw.Prj\<^sub>0\<^sub>1 \<cdot> \<rho>w.chine"
	+ using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close> by simp
	+ also have "... = (k0 \<cdot> \<p>\<^sub>1[k0, ?w1]) \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
	+ using Chn_\<rho>w_eq C.comp_cod_arr by simp
	+ also have "... = k0 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
	+ using C.comp_assoc by simp
	+ also have "... = k0 \<cdot> \<rho>.chine \<cdot> ?p1"
	+ using \<open>C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0\<close> by simp
	+ also have "... = (k0 \<cdot> \<rho>.chine) \<cdot> ?p1"
	+ using C.comp_assoc by metis
	+ also have "... = ?p1 \<cdot> (?R \<down>\<down> ?w1)"
	+ using C.comp_arr_dom C.comp_cod_arr cospan by simp
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<theta>.chine"
	+ using C.comp_arr_dom \<theta>.chine_in_hom gw.chine_eq_apex gw.chine_is_identity
	+ Dom_\<theta>_0 Cod_\<theta>_0 Dom_\<theta>.apex_def Cod_\<theta>.apex_def
	+ by (metis Dom_g \<theta>.chine_simps(1) \<theta>.chine_simps(2) gw.chine_composite
	+ gw.dom.apex_def gw.leg0_composite span_data.select_convs(1))
	+ also have "... = ru.prj\<^sub>0 \<cdot> ?RHS"
	+ using 2 by simp
	+ finally show ?thesis by blast
	+ qed
	+ show "ru.prj\<^sub>1 \<cdot> ?LHS = ru.prj\<^sub>1 \<cdot> ?RHS"
	+ proof -
	+ have "ru.prj\<^sub>1 \<cdot> ?LHS = (ru.prj\<^sub>1 \<cdot> r\<theta>.chine) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
	+ using C.comp_assoc by simp
	+ also have "... = (r.chine \<cdot> \<p>\<^sub>1[r0, r0 \<cdot> ?p1]) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
	+ proof -
	+ have "r\<theta>.chine \<noteq> C.null \<Longrightarrow>
	+ \<p>\<^sub>1[r.cod.leg0, Cod_\<theta>.leg1] \<cdot> r\<theta>.chine =
	+ r.chine \<cdot> \<p>\<^sub>1[r0, Dom_\<theta>.leg1]"
	+ by (metis (lifting) C.prj_tuple(2) C.tuple_is_extensional r.cod_simps(2)
	+ r\<theta>.chine_composite)
	+ thus ?thesis
	+ using Cod_\<theta>_1 Dom_\<theta>_1 r\<theta>.chine_simps(1) fw by fastforce
	+ qed
	+ also have "... = r.chine \<cdot> (rfw.Prj\<^sub>1 \<cdot> Chn \<a>[r, f, w]) \<cdot> \<rho>w.chine"
	+ using C.comp_assoc fw.leg1_composite by simp
	+ also have "... = r.chine \<cdot> rfw.Prj\<^sub>1\<^sub>1 \<cdot> \<rho>w.chine"
	+ using ide_f ide_w hseq_rf hseq_char \<alpha>_ide
	+ rfw.prj_chine_assoc(1)
	+ by auto
	+ also have "... = r.chine \<cdot> k1 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<rho>w.chine"
	+ using C.comp_cod_arr C.comp_assoc by simp
	+ also have "... = r.chine \<cdot> k1 \<cdot> \<rho>.chine \<cdot> \<p>\<^sub>1[Dom_\<rho>.leg0, ?w1]"
	+ using Chn_\<rho>w_eq
	+ \<open>C.commutative_square k0 ?w1
	+ (\<rho>.chine \<cdot> \<p>\<^sub>1[ra, w.leg1]) \<p>\<^sub>0[ra, w.leg1]\<close>
	+ by auto
	+ also have "... = r.chine \<cdot> (k1 \<cdot> \<rho>.chine) \<cdot> ?p1"
	+ using C.comp_assoc Dom_\<rho>_0 by metis
	+ also have "... = r.chine \<cdot> ra \<cdot> ?p1"
	+ by simp
	+ also have "... = r.chine \<cdot> ?p1"
	+ using C.comp_cod_arr
	+ by (metis C.comp_assoc r.cod_simps(1) r.chine_eq_apex r.chine_simps(1)
	+ r.chine_simps(3))
	+ also have "... = ?p1"
	+ using C.comp_cod_arr r.chine_eq_apex r.chine_is_identity
	+ by (metis 2 C.commutative_squareE r.dom.apex_def)
	+ also have "... = ru.prj\<^sub>1 \<cdot> ?RHS"
	+ using 2 by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+ text \<open>
	+ This is the main point: the equation E boils down to the following:
	+ \[
	+ \<open>?p1' \<cdot> \<beta>.chine = ?p1 \<and> \<theta>'.chine \<cdot> \<beta>.chine = \<theta>.chine\<close>
	+ \]
	+ The first equation gets us close to what we need, but we still need
	+ \<open>?p1 \<cdot> C.inv ?p0 = ?w1\<close>, which follows from the fact that ?p0 is the
	+ pullback of ?R.
	+ \<close>
	+ have *: "\<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle> = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
	+ using L R E by simp
	+ have **: "?p1' \<cdot> \<beta>.chine = ?p1"
	+ by (metis "*" C.in_homE C.not_arr_null C.prj_tuple(2) C.tuple_in_hom
	+ C.tuple_is_extensional
	+ \<open>C.commutative_square r0 u.leg1
	+ (\<p>\<^sub>1[ra, w'.leg1] \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>)
	+ have ***: "\<theta>'.chine \<cdot> \<beta>.chine = \<theta>.chine"
	+ by (metis "*" C.prj_tuple(1) \<open>C.commutative_square r0 ?u1
	+ (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>
	+ \<open>C.commutative_square r0 ?u1 ?p1 \<theta>.chine\<close>)
	+ text \<open>
	+ CKS say to take \<open>\<gamma> = \<beta>\<close>, but obviously this cannot work as
	+ literally described, because \<open>\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>\<close>, whereas we must have
	+ \<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>\<close>. Instead, we have to define \<open>\<gamma>\<close> by transporting \<open>\<beta>\<close> along the
	+ projections from \<open>?R \<down>\<down> ?w1\<close> to \<open>?W\<close> and \<open>?R \<down>\<down> ?w1'\<close> to \<open>?W'\<close>.
	+ These are isomorphisms by virtue of their being pullbacks of identities,
	+ but they are not themselves necessarily identities.
	+ Specifically, we take \<open>Chn \<gamma> = ?p0' \<cdot> Chn \<beta> \<cdot> C.inv ?p0\<close>.
	+ \<close>
	+ let ?\<gamma> = "\<lparr>Chn = ?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0, Dom = Dom w, Cod = Cod w'\<rparr>"
	+ interpret Dom_\<gamma>: span_in_category C \<open>Dom ?\<gamma>\<close>
	+ using w.dom.span_in_category_axioms by simp
	+ interpret Cod_\<gamma>: span_in_category C \<open>Cod ?\<gamma>\<close>
	+ using w'.cod.span_in_category_axioms by simp
	+ text \<open>
	+ It has to be shown that \<open>\<gamma>\<close> is an arrow of spans.
	+ \<close>
	+ interpret \<gamma>: arrow_of_spans C ?\<gamma>
	+ proof
	+ show "\<guillemotleft>Chn ?\<gamma> : Dom_\<gamma>.apex \<rightarrow>\<^sub>C Cod_\<gamma>.apex\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>Chn \<beta>: gw.apex \<rightarrow>\<^sub>C gw'.apex\<guillemotright>"
	+ using Chn_in_hom \<beta> gw'.chine_eq_apex gw.chine_eq_apex by force
	+ moreover have "\<guillemotleft>?p0' : gw'.apex \<rightarrow>\<^sub>C w'.apex\<guillemotright>"
	+ using cospan' hseq_gw' hseq_char hcomp_def gw'.dom.apex_def w'.dom.apex_def
	+ by auto
	+ moreover have "\<guillemotleft>C.inv ?p0 : w.apex \<rightarrow>\<^sub>C gw.apex\<guillemotright>"
	+ using cospan hseq_gw hseq_char hcomp_def gw.dom.apex_def w.dom.apex_def
	+ C.iso_pullback_ide
	+ by auto
	+ ultimately show ?thesis
	+ using Dom_\<gamma>.apex_def Cod_\<gamma>.apex_def by auto
	+ qed
	+ text \<open>
	+ The commutativity property for the ``input leg'' follows directly from that
	+ for \<open>\<beta>\<close>.
	+ \<close>
	+ show "Cod_\<gamma>.leg0 \<cdot> Chn ?\<gamma> = Dom_\<gamma>.leg0"
	+ using C.comp_assoc C.comp_arr_dom cospan C.iso_pullback_ide C.comp_arr_inv'
	+ by (metis C.invert_side_of_triangle(2) Dom_\<beta>.leg_simps(1) Dom_\<beta>_eq \<beta>0
	+ arrow_of_spans_data.select_convs(1,3) arrow_of_spans_data.simps(2)
	+ r.dom.ide_apex span_data.select_convs(1) w'.cod_simps(2))
	+ text \<open>
	+ The commutativity property for the ``output leg'' is a bit more subtle.
	+ \<close>
	+ show "Cod_\<gamma>.leg1 \<cdot> Chn ?\<gamma> = Dom_\<gamma>.leg1"
	+ proof -
	+ have "Cod_\<gamma>.leg1 \<cdot> Chn ?\<gamma> = ((?w1' \<cdot> ?p0') \<cdot> \<beta>.chine) \<cdot> C.inv ?p0"
	+ using C.comp_assoc by simp
	+ also have "... = ((?R \<cdot> ?p1') \<cdot> Chn \<beta>) \<cdot> C.inv ?p0"
	+ using cospan' C.pullback_commutes [of ?R ?w1'] by auto
	+ also have "... = (?p1' \<cdot> \<beta>.chine) \<cdot> C.inv ?p0"
	+ using cospan' C.comp_cod_arr by simp
	+ also have "... = ?p1 \<cdot> C.inv ?p0"
	+ using ** by simp
	+ also have "... = ?w1"
	+ text \<open>
	+ Sledgehammer found this at a time when I was still struggling to
	+ understand what was going on.
	+ \<close>
	+ by (metis C.comp_cod_arr C.invert_side_of_triangle(2) C.iso_pullback_ide
	+ C.prj1_simps(1,3) C.pullback_commutes' cospan r.dom.ide_apex
	+ r.chine_eq_apex r.chine_simps(2))
	+ also have "... = Dom_\<gamma>.leg1" by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ text \<open>
	+ What remains to be shown is that \<open>\<gamma>\<close> is unique with the properties asserted
	+ by \<open>T2\<close>; \emph{i.e.} \<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>)\<close>.
	+ CKS' assertion that the equation \<open>(r\<theta>)(\<rho>w) = (r\<theta>')(\<rho>w')\<beta>\<close> gives \<open>w\<^sub>1 = w\<^sub>1'\<close>
	+ does not really seem to be true. The reason \<open>\<gamma>\<close> is unique is because it is
	+ obtained by transporting \<open>\<beta>\<close> along isomorphisms.
	+ \<close>
	+ have \<gamma>: "\<guillemotleft>?\<gamma> : w \<Rightarrow> w'\<guillemotright>"
	+ using \<gamma>.arrow_of_spans_axioms arr_char dom_char cod_char by auto
	+ have hseq_f\<gamma>: "hseq f ?\<gamma>"
	+ using \<gamma> src_def trg_def arrI fw.composable hseqI' rf.are_arrows(2) by auto
	+ have hseq_g\<gamma>: "hseq g ?\<gamma>"
	+ using \<gamma> src_def trg_def fw.composable gw.are_arrows(1) hseqI' src_f by auto
	+ interpret f\<gamma>: two_composable_arrows_of_spans C prj0 prj1 f ?\<gamma>
	+ using hseq_f\<gamma> hseq_char by (unfold_locales, simp)
	+ interpret f\<gamma>: arrow_of_spans C \<open>f \<star> ?\<gamma>\<close>
	+ using f\<gamma>.composite_is_arrow arr_char by simp
	+ interpret g\<gamma>: two_composable_arrows_of_spans C prj0 prj1 g ?\<gamma>
	+ using hseq_g\<gamma> hseq_char by (unfold_locales, simp)
	+ interpret g\<gamma>: arrow_of_spans C \<open>g \<star> ?\<gamma>\<close>
	+ using g\<gamma>.composite_is_arrow arr_char by simp
	+ have Chn_g\<gamma>: "Chn (g \<star> ?\<gamma>) = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> ?p0' \<cdot> \<beta>.chine\<rangle>"
	+ proof -
	+ have "Chn (g \<star> ?\<gamma>) = \<langle>?R \<cdot> ?p1 \<lbrakk>?R, ?w1'\<rbrakk> (?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0) \<cdot> ?p0\<rangle>"
	+ using g\<gamma>.chine_composite by simp
	+ also have "... = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> (?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0) \<cdot> ?p0\<rangle>"
	+ using C.comp_cod_arr cospan by simp
	+ also have "... = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> ?p0' \<cdot> \<beta>.chine\<rangle>"
	+ proof -
	+ have "(?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0) \<cdot> ?p0 = ?p0' \<cdot> \<beta>.chine"
	+ using C.comp_assoc C.iso_pullback_ide [of ?R ?w1] C.comp_inv_arr
	+ C.comp_arr_dom Chn_\<beta>
	+ by (metis C.comp_inv_arr' C.in_homE C.pbdom_def cospan r.dom.ide_apex)
	+ thus ?thesis by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ have Chn_\<beta>_eq: "\<beta>.chine = Chn (g \<star> ?\<gamma>)"
	+ proof -
	+ have "Chn (g \<star> ?\<gamma>) = \<langle>?p1 \<lbrakk>?R, ?w1'\<rbrakk> ?p0' \<cdot> Chn \<beta>\<rangle>"
	+ using Chn_g\<gamma> by simp
	+ also have "... = \<beta>.chine"
	+ text \<open>Here was another score by sledgehammer while I was still trying
	+ to understand it.\<close>
	+ using ** C.prj_joint_monic
	+ by (metis C.prj1_simps(1) C.tuple_prj cospan cospan')
	+ finally show ?thesis by simp
	+ qed
	+ have \<beta>_eq_g\<gamma>: "\<beta> = g \<star> ?\<gamma>"
	+ proof (intro arr_eqI)
	+ show "par \<beta> (g \<star> ?\<gamma>)"
	+ proof -
	+ have "\<guillemotleft>g \<star> ?\<gamma> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
	+ using ide_g \<gamma> T.leg1_simps(3)
	+ by (intro hcomp_in_vhom, auto)
	+ thus ?thesis
	+ using \<beta> by (elim in_homE, auto)
	+ qed
	+ show "\<beta>.chine = Chn (g \<star> ?\<gamma>)"
	+ using Chn_\<beta>_eq by simp
	+ qed
	+ moreover have "\<theta> = \<theta>' \<bullet> (f \<star> ?\<gamma>)"
	+ proof (intro arr_eqI)
	+ have f\<gamma>: "\<guillemotleft>f \<star> ?\<gamma> : f \<star> w \<Rightarrow> f \<star> w'\<guillemotright>"
	+ using \<gamma> ide_f by auto
	+ show par: "par \<theta> (\<theta>' \<bullet> (f \<star> ?\<gamma>))"
	+ using \<theta> \<theta>' f\<gamma> by (elim in_homE, auto)
	+ show "\<theta>.chine = Chn (\<theta>' \<bullet> (f \<star> ?\<gamma>))"
	+ using par "***" Chn_vcomp calculation f\<gamma>.chine_composite g\<gamma>.chine_composite
	+ by auto
	+ qed
	+ ultimately show 2: "\<guillemotleft>?\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> ?\<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> ?\<gamma>)"
	+ using \<gamma> by simp
	+ show "\<And>\<gamma>'. \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma>' \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>') \<Longrightarrow> \<gamma>' = ?\<gamma>"
	+ proof -
	+ fix \<gamma>'
	+ assume 1: "\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma>' \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>')"
	+ interpret \<gamma>': arrow_of_spans C \<gamma>'
	+ using 1 arr_char by auto
	+ have hseq_g\<gamma>': \<open>hseq g \<gamma>'\<close>
	+ using 1 \<beta> by auto
	+ interpret g\<gamma>': two_composable_arrows_of_spans C prj0 prj1 g \<gamma>'
	+ using hseq_g\<gamma>' hseq_char by (unfold_locales, auto)
	+ interpret g\<gamma>': arrow_of_spans C \<open>g \<star> \<gamma>'\<close>
	+ using g\<gamma>'.composite_is_arrow arr_char by simp
	+ show "\<gamma>' = ?\<gamma>"
	+ proof (intro arr_eqI)
	+ show par: "par \<gamma>' ?\<gamma>"
	+ using 1 \<gamma> by fastforce
	+ show "\<gamma>'.chine = \<gamma>.chine"
	+ proof -
	+ have "C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>'.chine \<cdot> ?p0)"
	+ proof
	+ show "C.cospan ?R ?w1'" by fact
	+ show 3: "C.span (g.chine \<cdot> ?p1) (\<gamma>'.chine \<cdot> ?p0)"
	+ proof (intro conjI)
	+ show "C.seq g.chine ?p1"
	+ using cospan by auto
	+ show "C.seq \<gamma>'.chine ?p0"
	+ using cospan 2 par arrow_of_spans_data.simps(1)
	+ dom_char in_homE w.chine_eq_apex
	+ by auto
	+ thus "C.dom (g.chine \<cdot> ?p1) = C.dom (\<gamma>'.chine \<cdot> ?p0)"
	+ using g.chine_eq_apex cospan by simp
	+ qed
	+ show "C.dom ra = C.cod (g.chine \<cdot> ?p1)"
	+ using cospan by auto
	+ show "?R \<cdot> g.chine \<cdot> ?p1 = ?w1' \<cdot> \<gamma>'.chine \<cdot> ?p0"
	+ proof -
	+ have "?w1' \<cdot> \<gamma>'.chine \<cdot> ?p0 = (?w1' \<cdot> \<gamma>'.chine) \<cdot> ?p0"
	+ using C.comp_assoc by simp
	+ moreover have "... = ?w1 \<cdot> ?p0"
	+ using 1 \<gamma>'.leg1_commutes dom_char cod_char by auto
	+ also have "... = ?R \<cdot> ?p1"
	+ using cospan C.pullback_commutes [of ra ?w1] by auto
	+ also have "... = ?R \<cdot> g.chine \<cdot> ?p1"
	+ using 3 C.comp_cod_arr g.chine_is_identity g.chine_eq_apex g.dom.apex_def
	+ by auto
	+ finally show ?thesis by auto
	+ qed
	+ qed
	+ have "C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>.chine \<cdot> ?p0)"
	+ proof
	+ show "C.cospan ?R ?w1'" by fact
	+ show 3: "C.span (g.chine \<cdot> ?p1) (\<gamma>.chine \<cdot> ?p0)"
	+ using cospan \<gamma>.chine_in_hom by auto
	+ show "C.dom ?R = C.cod (g.chine \<cdot> ?p1)"
	+ using cospan by auto
	+ show "?R \<cdot> g.chine \<cdot> ?p1 = ?w1' \<cdot> \<gamma>.chine \<cdot> ?p0"
	+ proof -
	+ have "?w1' \<cdot> \<gamma>.chine \<cdot> ?p0 = (?w1' \<cdot> \<gamma>.chine) \<cdot> ?p0"
	+ using C.comp_assoc by simp
	+ moreover have "... = ?w1 \<cdot> ?p0"
	+ using 1 \<gamma>.leg1_commutes dom_char cod_char by auto
	+ also have "... = ?R \<cdot> ?p1"
	+ using cospan C.pullback_commutes [of ra ?w1] by auto
	+ also have "... = ?R \<cdot> g.chine \<cdot> ?p1"
	+ using 3 C.comp_cod_arr g.chine_is_identity g.chine_eq_apex g.dom.apex_def
	+ by auto
	+ finally show ?thesis by auto
	+ qed
	+ qed
	+ have "\<gamma>'.chine \<cdot> ?p0 = \<gamma>.chine \<cdot> ?p0"
	+ proof -
	+ have "\<gamma>'.chine \<cdot> ?p0 = ?p0' \<cdot> g\<gamma>'.chine"
	+ using 1 dom_char cod_char g\<gamma>'.chine_composite
	+ \<open>C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>'.chine \<cdot> ?p0)\<close>
	+ by auto
	+ also have "... = ?p0' \<cdot> \<beta>.chine"
	+ using 1 by simp
	+ also have "... = ?p0' \<cdot> g\<gamma>.chine"
	+ using Chn_\<beta>_eq by simp
	+ also have "... = \<gamma>.chine \<cdot> ?p0"
	+ using g\<gamma>.chine_composite
	+ \<open>C.commutative_square ?R ?w1' (g.chine \<cdot> ?p1) (\<gamma>.chine \<cdot> ?p0)\<close>
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using C.iso_pullback_ide C.iso_is_retraction C.retraction_is_epi
	+ C.epiE [of "?p0" \<gamma>'.chine \<gamma>.chine] cospan \<gamma>.chine_in_hom
	+ \<gamma>'.chine_in_hom
	+ by auto
	+ qed
	+ qed
	+ qed
	+ qed
	+ qed
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ context span_bicategory
	+ begin
	+
	+ interpretation chosen_right_adjoints vcomp hcomp assoc unit src trg ..
	+ notation some_right_adjoint ("_\<^sup>" [1000] 1000) ( TODO: Why is this needed? *)
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ text \<open>
	+ \<open>Span(C)\<close> is a bicategory of spans.
	+ \<close>
	+
	+ lemma is_bicategory_of_spans:
	+ shows "bicategory_of_spans vcomp hcomp assoc unit src trg"
	+ proof
	+ text \<open>
	+ Every 1-cell \<open>r\<close> is isomorphic to the composition of a map and the right adjoint
	+ of a map. The proof is to obtain a tabulation of \<open>r\<close> as a span of maps \<open>(f, g)\<close>
	+ and then observe that \<open>r\<close> is isomorphic to \<open>g \<star> f\<^sup>*\<close>.
	+ \<close>
	+ show "\<And>r. ide r \<Longrightarrow> \<exists>f g. is_left_adjoint f \<and> is_left_adjoint g \<and> r \<cong> g \<star> f\<^sup>*"
	+ proof -
	+ fix r
	+ assume r: "ide r"
	+ interpret r: identity_arrow_of_spans C r
	+ using r ide_char' by auto
	+ interpret r: identity_arrow_in_span_bicategory C prj0 prj1 r ..
	+ have \<rho>: "tabulation (\<bullet>) (\<star>) assoc unit src trg r r.\<rho> r.f r.g \<and>
	+ is_left_adjoint r.f \<and> is_left_adjoint r.g"
	+ using r r.has_tabulation by blast
	+ interpret \<rho>: tabulation vcomp hcomp assoc unit src trg r r.\<rho> r.f r.g
	+ using \<rho> by fast
	+ have 1: "r \<cong> r.g \<star> r.f\<^sup>*"
	+ using \<rho> \<rho>.yields_isomorphic_representation' \<rho>.T0.is_map
	+ left_adjoint_extends_to_adjoint_pair
	+ isomorphic_def [of "r.g \<star> r.f\<^sup>*" r] isomorphic_symmetric
	+ by auto
	+ thus "\<exists>f g. is_left_adjoint f \<and> is_left_adjoint g \<and> r \<cong> g \<star> f\<^sup>*"
	+ using \<rho> by blast
	+ qed
	+ text \<open>
	+ Every span of maps extends to a tabulation.
	+ \<close>
	+ show "\<And>f g. \<lbrakk> is_left_adjoint f; is_left_adjoint g; src f = src g \<rbrakk> \<Longrightarrow>
	+ \<exists>r \<rho>. tabulation (\<bullet>) (\<star>) assoc unit src trg r \<rho> f g"
	+ proof -
	+ text \<open>
	+ The proof idea is as follows: Let maps \<open>f = (f\<^sub>1, f\<^sub>0)\<close> and \<open>g = (g\<^sub>1, g\<^sub>0)\<close> be given.
	+ Let \<open>f' = (f\<^sub>1 \<cdot> C.inv f\<^sub>0, C.cod f\<^sub>0)\<close> and \<open>g' = (g\<^sub>1 \<cdot> C.inv g\<^sub>0, C.cod g\<^sub>0)\<close>;
	+ then \<open>f'\<close> and \<open>g'\<close> are maps isomorphic to \<open>f\<close> and \<open>g\<close>, respectively.
	+ By a previous result, \<open>f'\<close> and \<open>g'\<close> extend to a tabulation \<open>(f', \<tau>, g')\<close> of
	+ \<open>r = (f\<^sub>1 \<cdot> C.inv f\<^sub>0, g\<^sub>1 \<cdot> C.inv g\<^sub>0)\<close>.
	+ Compose with isomorphisms \<open>\<guillemotleft>\<phi> : f' \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<psi> : g \<Rightarrow> g'\<guillemotright>\<close> to obtain
	+ \<open>(f, (r \<star> \<phi>) \<cdot> \<tau> \<cdot> \<psi>, g)\<close> and show it must also be a tabulation.
	+ \<close>
	+ fix f g
	+ assume f: "is_left_adjoint f"
	+ assume g: "is_left_adjoint g"
	+ assume fg: "src f = src g"
	+ show "\<exists>r \<rho>. tabulation (\<bullet>) (\<star>) assoc unit src trg r \<rho> f g"
	+ proof -
	+ text \<open>We have to unpack the hypotheses to get information about f and g.\<close>
	+ obtain f\<^sub>a \<eta>\<^sub>f \<epsilon>\<^sub>f
	+ where ff\<^sub>a: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta>\<^sub>f \<epsilon>\<^sub>f"
	+ using f adjoint_pair_def by auto
	+ interpret ff\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta>\<^sub>f \<epsilon>\<^sub>f
	+ using ff\<^sub>a by simp
	+ interpret f: arrow_of_spans C f
	+ using ide_char [of f] by simp
	+ interpret f: identity_arrow_of_spans C f
	+ using ide_char [of f] by (unfold_locales, auto)
	+ obtain g\<^sub>a \<eta>\<^sub>g \<epsilon>\<^sub>g
	+ where G: "adjunction_in_bicategory vcomp hcomp assoc unit src trg g g\<^sub>a \<eta>\<^sub>g \<epsilon>\<^sub>g"
	+ using g adjoint_pair_def by auto
	+ interpret gg\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg g g\<^sub>a \<eta>\<^sub>g \<epsilon>\<^sub>g
	+ using G by simp
	+ interpret g: arrow_of_spans C g
	+ using ide_char [of g] by simp
	+ interpret g: identity_arrow_of_spans C g
	+ using ide_char [of g] by (unfold_locales, auto)
	+
	+ let ?f' = "mkIde (C.cod f.leg0) (f.dom.leg1 \<cdot> C.inv f.leg0)"
	+ have f': "ide ?f'"
	+ proof -
	+ have "C.span (C.cod f.leg0) (f.leg1 \<cdot> C.inv f.leg0)"
	+ using f is_left_adjoint_char by auto
	+ thus ?thesis
	+ using ide_mkIde by blast
	+ qed
	+ interpret f': arrow_of_spans C ?f'
	+ using f' ide_char by blast
	+ interpret f': identity_arrow_of_spans C ?f'
	+ using f' ide_char by (unfold_locales, auto)
	+
	+ let ?g' = "mkIde (C.cod g.leg0) (g.dom.leg1 \<cdot> C.inv g.leg0)"
	+ have g': "ide ?g'"
	+ proof -
	+ have "C.span (C.cod g.leg0) (g.leg1 \<cdot> C.inv g.leg0)"
	+ using g is_left_adjoint_char by auto
	+ thus ?thesis
	+ using ide_mkIde by blast
	+ qed
	+ interpret g': arrow_of_spans C ?g'
	+ using g' ide_char by blast
	+ interpret g': identity_arrow_of_spans C ?g'
	+ using g' ide_char by (unfold_locales, auto)
	+
	+ let ?r = "mkIde (f'.leg1) (g'.leg1)"
	+ have r: "ide ?r"
	+ proof -
	+ have "C.span (f'.leg1) (g'.leg1)"
	+ using f g fg src_def is_left_adjoint_char by simp
	+ thus ?thesis
	+ using ide_mkIde by blast
	+ qed
	+ interpret r: arrow_of_spans C ?r
	+ using r ide_char by blast
	+ interpret r: identity_arrow_of_spans C ?r
	+ using r ide_char by (unfold_locales, auto)
	+ interpret r: identity_arrow_in_span_bicategory C prj0 prj1 ?r ..
	+
	+ have "r.f = ?f'"
	+ using f r.chine_eq_apex is_left_adjoint_char by auto
	+ have "r.g = ?g'"
	+ using f r.chine_eq_apex fg src_def is_left_adjoint_char by simp
	+
	+ interpret \<rho>: tabulation \<open>(\<bullet>)\<close> \<open>(\<star>)\<close> assoc unit src trg ?r r.\<rho> r.f r.g
	+ using r.has_tabulation by simp
	+ have \<rho>_eq: "r.\<rho> = \<lparr>Chn = \<langle>C.cod f.leg0 \<lbrakk>f'.leg1, f'.leg1\<rbrakk> C.cod f.leg0\<rangle>,
	+ Dom = \<lparr>Leg0 = C.cod f.leg0, Leg1 = g'.leg1\<rparr>,
	+ Cod = \<lparr>Leg0 = \<p>\<^sub>0[f'.leg1, f'.leg1],
	+ Leg1 = g'.leg1 \<cdot> \<p>\<^sub>1[f'.leg1, f'.leg1]\<rparr>\<rparr>"
	+ using \<open>r.f = ?f'\<close> by auto
	+
	+ text \<open>Obtain the isomorphism from \<open>f'\<close> to \<open>f\<close>.\<close>
	+ let ?\<phi> = "\<lparr>Chn = C.inv f.leg0, Dom = Dom ?f', Cod = Dom f\<rparr>"
	+ interpret Dom_\<phi>: span_in_category C
	+ \<open>Dom \<lparr>Chn = C.inv f.leg0,
	+ Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
	+ Cod = Dom f\<rparr>\<close>
	+ using f'.dom.span_in_category_axioms by simp
	+ interpret Cod_\<phi>: span_in_category C
	+ \<open>Cod \<lparr>Chn = C.inv f.leg0,
	+ Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
	+ Cod = Dom f\<rparr>\<close>
	+ using f.dom.span_in_category_axioms by simp
	+ interpret \<phi>: arrow_of_spans C ?\<phi>
	+ proof
	+ show "\<guillemotleft>Chn \<lparr>Chn = C.inv f.leg0,
	+ Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
	+ Cod = Dom f\<rparr> : Dom_\<phi>.apex \<rightarrow>\<^sub>C Cod_\<phi>.apex\<guillemotright>"
	+ using f f.dom.apex_def f'.dom.apex_def is_left_adjoint_char by auto
	+ show "Cod_\<phi>.leg0 \<cdot> Chn \<lparr>Chn = C.inv f.leg0,
	+ Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
	+ Cod = Dom f\<rparr> =
	+ Dom_\<phi>.leg0"
	+ using f f.dom.apex_def is_left_adjoint_char C.comp_arr_inv C.inv_is_inverse
	+ by simp
	+ show "Cod_\<phi>.leg1 \<cdot> Chn \<lparr>Chn = C.inv f.leg0,
	+ Dom = Dom (mkIde f.dsrc (f.leg1 \<cdot> C.inv f.leg0)),
	+ Cod = Dom f\<rparr> =
	+ Dom_\<phi>.leg1"
	+ by simp
	+ qed
	+ have \<phi>: "\<guillemotleft>?\<phi> : ?f' \<Rightarrow> f\<guillemotright> \<and> iso ?\<phi>"
	+ using f is_left_adjoint_char iso_char arr_char dom_char cod_char
	+ \<phi>.arrow_of_spans_axioms C.iso_inv_iso f'.dom.apex_def f.dom.apex_def
	+ by auto
	+
	+ text \<open>
	+ Obtain the isomorphism from \<open>g\<close> to \<open>g'\<close>.
	+ Recall: \<open>g' = mkIde (C.cod g.leg0) (g.dom.leg1 \<cdot> C.inv g.leg0)\<close>.
	+ The isomorphism is given by \<open>g.leg0\<close>.
	+ \<close>
	+ let ?\<psi> = "\<lparr>Chn = g.leg0, Dom = Dom g, Cod = Dom ?g'\<rparr>"
	+ interpret Dom_\<psi>: span_in_category C
	+ \<open>Dom \<lparr>Chn = g.leg0,
	+ Dom = Dom g,
	+ Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr>\<close>
	+ using g.dom.span_in_category_axioms by simp
	+ interpret Cod_\<psi>: span_in_category C
	+ \<open>Cod \<lparr>Chn = g.leg0,
	+ Dom = Dom g,
	+ Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr>\<close>
	+ using g'.dom.span_in_category_axioms by simp
	+ interpret \<psi>: arrow_of_spans C ?\<psi>
	+ proof
	+ show "\<guillemotleft>Chn \<lparr>Chn = g.leg0,
	+ Dom = Dom g,
	+ Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr> :
	+ Dom_\<psi>.apex \<rightarrow>\<^sub>C Cod_\<psi>.apex\<guillemotright>"
	+ using g g.dom.apex_def g'.dom.apex_def is_left_adjoint_char by auto
	+ show "Cod_\<psi>.leg0 \<cdot> Chn \<lparr>Chn = g.leg0,
	+ Dom = Dom g,
	+ Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr> =
	+ Dom_\<psi>.leg0"
	+ using C.comp_cod_arr by simp
	+ show "Cod_\<psi>.leg1 \<cdot> Chn \<lparr>Chn = g.leg0,
	+ Dom = Dom g,
	+ Cod = Dom (mkIde g.dsrc (g.leg1 \<cdot> C.inv g.leg0))\<rparr> =
	+ Dom_\<psi>.leg1"
	+ using g g.dom.apex_def is_left_adjoint_char C.comp_inv_arr C.inv_is_inverse
	+ C.comp_assoc C.comp_arr_dom
	+ by simp
	+ qed
	+ have \<psi>: "\<guillemotleft>?\<psi> : g \<Rightarrow> ?g'\<guillemotright> \<and> iso ?\<psi>"
	+ using g is_left_adjoint_char iso_char arr_char dom_char cod_char
	+ \<psi>.arrow_of_spans_axioms C.iso_inv_iso g.dom.apex_def g'.dom.apex_def
	+ by auto
	+ have \<rho>\<psi>: "tabulation (\<bullet>) (\<star>) assoc unit src trg ?r (r.\<rho> \<bullet> ?\<psi>) r.f g"
	+ using \<psi> `r.g = ?g'` iso_inv_iso r.has_tabulation \<rho>.preserved_by_output_iso by simp
	+ interpret \<tau>\<psi>: tabulation vcomp hcomp assoc unit src trg ?r \<open>r.\<rho> \<bullet> ?\<psi>\<close> r.f g
	+ using \<rho>\<psi> by auto
	+ have "tabulation (\<bullet>) (\<star>) assoc unit src trg ?r ((?r \<star> ?\<phi>) \<bullet> r.\<rho> \<bullet> ?\<psi>) f g"
	+ using \<phi> `r.f = ?f'` \<tau>\<psi>.preserved_by_input_iso [of ?\<phi> f] by argo
	+ thus ?thesis by auto
	+ qed
	+ qed
	+
	+ text \<open>The sub-bicategory of maps is locally essentially discrete.\<close>
	+ show "\<And>f f' \<mu> \<mu>'. \<lbrakk> is_left_adjoint f; is_left_adjoint f'; \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright>; \<guillemotleft>\<mu>' : f \<Rightarrow> f'\<guillemotright> \<rbrakk>
	+ \<Longrightarrow> iso \<mu> \<and> iso \<mu>' \<and> \<mu> = \<mu>'"
	+ proof -
	+ fix f f' \<mu> \<mu>'
	+ assume f: "is_left_adjoint f" and f': "is_left_adjoint f'"
	+ assume \<mu>: "\<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright>" and \<mu>': "\<guillemotleft>\<mu>' : f \<Rightarrow> f'\<guillemotright>"
	+ obtain f\<^sub>a \<eta> \<epsilon>
	+ where f\<^sub>a: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta> \<epsilon>"
	+ using f adjoint_pair_def by auto
	+ obtain f'\<^sub>a \<eta>' \<epsilon>'
	+ where f'\<^sub>a: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f' f'\<^sub>a \<eta>' \<epsilon>'"
	+ using f' adjoint_pair_def adjunction_def by auto
	+ interpret f\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg f f\<^sub>a \<eta> \<epsilon>
	+ using f\<^sub>a by simp
	+ interpret f'\<^sub>a: adjunction_in_bicategory vcomp hcomp assoc unit src trg f' f'\<^sub>a \<eta>' \<epsilon>'
	+ using f'\<^sub>a by simp
	+ interpret f: identity_arrow_of_spans C f
	+ using ide_char' [of f] by simp
	+ interpret f': identity_arrow_of_spans C f'
	+ using ide_char' [of f'] by simp
	+ interpret \<mu>: arrow_of_spans C \<mu> using \<mu> arr_char by auto
	+ interpret \<mu>': arrow_of_spans C \<mu>' using \<mu>' arr_char by auto
	+ have 1: "C.iso f.leg0 \<and> C.iso f'.leg0"
	+ using f f' is_left_adjoint_char by simp
	+ have 2: "\<mu>.chine = C.inv f'.leg0 \<cdot> f.leg0"
	+ using \<mu> 1 dom_char cod_char \<mu>.leg0_commutes C.invert_side_of_triangle by auto
	+ moreover have "\<mu>'.chine = C.inv f'.leg0 \<cdot> f.leg0"
	+ using \<mu>' 1 dom_char cod_char \<mu>'.leg0_commutes C.invert_side_of_triangle by auto
	+ ultimately have 3: "\<mu>.chine = \<mu>'.chine" by simp
	+ have "iso \<mu>"
	+ using 1 2 C.isos_compose C.iso_inv_iso \<mu> dom_char cod_char
	+ iso_char arr_char \<mu>.arrow_of_spans_axioms
	+ by auto
	+ hence "iso \<mu>'"
	+ using 3 iso_char arr_char \<mu>'.arrow_of_spans_axioms by simp
	+ moreover have "\<mu> = \<mu>'"
	+ using 3 \<mu> \<mu>' dom_char cod_char by fastforce
	+ ultimately show "iso \<mu> \<and> iso \<mu>' \<and> \<mu> = \<mu>'"
	+ by simp
	+ qed
	+ qed
	+
	+ text \<open>
	+ We can now prove the easier half of the main result (CKS Theorem 4):
	+ If \<open>B\<close> is biequivalent to \<open>Span(C)\<close>, where \<open>C\<close> is a category with pullbacks,
	+ then \<open>B\<close> is a bicategory of spans.
	+ (Well, it is easier given that we have already done the work to show that the notion
	+ ``bicategory of spans'' is respected by equivalence of bicategories.)
	+ \<close>
	+
	+ theorem equivalent_implies_bicategory_of_spans:
	+ assumes "equivalent_bicategories vcomp hcomp assoc unit src trg V\<^sub>1 H\<^sub>1 \<a>\<^sub>1 \<i>\<^sub>1 src\<^sub>1 trg\<^sub>1"
	+ shows "bicategory_of_spans V\<^sub>1 H\<^sub>1 \<a>\<^sub>1 \<i>\<^sub>1 src\<^sub>1 trg\<^sub>1"
	+ using assms is_bicategory_of_spans bicategory_of_spans_respects_equivalence by blast
	+
	+ end
	+
	+ subsection "Properties of Bicategories of Spans"
	+
	+ text \<open>
	+ We now develop consequences of the axioms for a bicategory of spans, in preparation for
	+ proving the other half of the main result.
	+ \<close>
	+
	+ context bicategory_of_spans
	+ begin
	+
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ text \<open>
	+ The following is a convenience version of \<open>BS2\<close> that gives us what we generally want:
	+ given specified \<open>f, g\<close> obtain \<open>\<rho>\<close> that makes \<open>(f, \<rho>, g)\<close> a tabulation of \<open>g \<star> f\<^sup>*\<close>,
	+ not a tabulation of some \<open>r\<close> isomorphic to \<open>g \<star> f\<^sup>*\<close>.
	+ \<close>
	+
	+ lemma BS2':
	+ assumes "is_left_adjoint f" and "is_left_adjoint g" and "src f = src g"
	+ and "isomorphic (g \<star> f\<^sup>*) r"
	+ shows "\<exists>\<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"
	+ proof -
	+ have 1: "is_left_adjoint f \<and> is_left_adjoint g \<and> g \<star> f\<^sup>* \<cong> r"
	+ using assms BS1 by simp
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"
	+ using 1 isomorphic_def by blast
	+ obtain r' \<rho>' where \<rho>': "tabulation V H \<a> \<i> src trg r' \<rho>' f g"
	+ using assms 1 BS2 by blast
	+ interpret \<rho>': tabulation V H \<a> \<i> src trg r' \<rho>' f g
	+ using \<rho>' by simp
	+ let ?\<psi> = "\<rho>'.T0.trnr\<^sub>\<epsilon> r' \<rho>'"
	+ have \<psi>: "\<guillemotleft>?\<psi> : g \<star> f\<^sup>* \<Rightarrow> r'\<guillemotright> \<and> iso ?\<psi>"
	+ using \<rho>'.yields_isomorphic_representation by blast
	+ have "\<guillemotleft>\<phi> \<cdot> inv ?\<psi> : r' \<Rightarrow> r\<guillemotright> \<and> iso (\<phi> \<cdot> inv ?\<psi>)"
	+ using \<phi> \<psi> iso_inv_iso isos_compose inv_in_hom by blast
	+ hence 3: "tabulation V H \<a> \<i> src trg r ((\<phi> \<cdot> inv ?\<psi> \<star> f) \<cdot> \<rho>') f g"
	+ using \<rho>'.is_preserved_by_base_iso by blast
	+ hence "\<exists>\<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"
	+ by blast
	+ thus ?thesis
	+ using someI_ex [of "\<lambda>\<rho>. tabulation V H \<a> \<i> src trg r \<rho> f g"] by simp
	+ qed
	+
	+ text \<open>
	+ The following observation is made by CKS near the beginning of the proof of Theorem 4:
	+ If \<open>w\<close> is an arbitrary 1-cell, and \<open>g\<close> and \<open>g \<star> w\<close> are maps, then \<open>w\<close> is in fact a map.
	+ It is applied frequently.
	+ \<close>
	+
	+ lemma BS4:
	+ assumes "is_left_adjoint g" and "ide w" and "is_left_adjoint (g \<star> w)"
	+ shows "is_left_adjoint w"
	+ proof -
	+ text \<open>
	+ CKS say: ``by (i) there are maps \<open>m, n\<close> with \<open>w \<cong> nm\<^sup>*\<close>, so, by (ii), we have two
	+ tabulations \<open>(1, \<rho>, gw)\<close>, \<open>(m, \<sigma>, gn)\<close> of \<open>gw\<close>; since tabulations are unique
	+ up to equivalence, \<open>m\<close> is invertible and \<open>w \<cong> nm\<^sup>*\<close> is a map.''
	+ \<close>
	+ have ex_\<rho>: "\<exists>\<rho>. tabulation V H \<a> \<i> src trg (g \<star> w) \<rho> (src w) (g \<star> w)"
	+ proof -
	+ have "(g \<star> w) \<star> src w \<cong> g \<star> w"
	+ by (metis assms(3) ideD(1) iso_runit isomorphic_def left_adjoint_is_ide
	+ runit_in_hom(2) hcomp_simps(1))
	+ moreover have "isomorphic ((g \<star> w) \<star> (src w)\<^sup>*) (g \<star> w)"
	+ proof -
	+ have "(g \<star> w) \<star> src (g \<star> w) \<cong> g \<star> w"
	+ using calculation isomorphic_implies_ide(2) by auto
	+ moreover have "isomorphic (src (g \<star> w)) (src w)\<^sup>*"
	+ proof -
	+ interpret src_w: map_in_bicategory V H \<a> \<i> src trg \<open>src w\<close>
	+ using assms obj_is_self_adjoint by (unfold_locales, auto)
	+ interpret src_w: adjunction_in_bicategory V H \<a> \<i> src trg
	+ \<open>src w\<close> \<open>(src w)\<^sup>*\<close> src_w.\<eta> src_w.\<epsilon>
	+ using src_w.is_map left_adjoint_extends_to_adjunction by simp
	+ have "adjoint_pair (src w) (src w)"
	+ using assms obj_is_self_adjoint by simp
	+ moreover have "adjoint_pair (src w) (src w)\<^sup>*"
	+ using adjoint_pair_def src_w.adjunction_in_bicategory_axioms by auto
	+ ultimately have "src w \<cong> (src w)\<^sup>*"
	+ using left_adjoint_determines_right_up_to_iso by simp
	+ moreover have "src w = src (g \<star> w)"
	+ using assms isomorphic_def hcomp_simps(1) left_adjoint_is_ide by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ moreover have "src (g \<star> w) = trg (src (g \<star> w))"
	+ using assms left_adjoint_is_ide by simp
	+ ultimately show ?thesis
	+ using assms left_adjoint_is_ide isomorphic_transitive isomorphic_symmetric
	+ hcomp_ide_isomorphic
	+ by blast
	+ qed
	+ ultimately show ?thesis
	+ using assms obj_is_self_adjoint
	+ left_adjoint_is_ide BS2' [of "src w" "g \<star> w" "g \<star> w"]
	+ by auto
	+ qed
	+ obtain \<rho> where \<rho>: "tabulation V H \<a> \<i> src trg (g \<star> w) \<rho> (src w) (g \<star> w)"
	+ using ex_\<rho> by auto
	+ obtain m n where mn: "is_left_adjoint m \<and> is_left_adjoint n \<and> isomorphic w (n \<star> m\<^sup>*)"
	+ using assms BS1 [of w] by auto
	+ have m\<^sub>a: "adjoint_pair m m\<^sup>* \<and> isomorphic w (n \<star> m\<^sup>*)"
	+ using mn adjoint_pair_def left_adjoint_extends_to_adjoint_pair by blast
	+ have ex_\<sigma>: "\<exists>\<sigma>. tabulation V H \<a> \<i> src trg (g \<star> w) \<sigma> m (g \<star> n)"
	+ proof -
	+ have "hseq n m\<^sup>*"
	+ using mn isomorphic_implies_ide by auto
	+ have "trg (n \<star> m\<^sup>*) = trg w"
	+ using mn m\<^sub>a isomorphic_def
	+ by (metis (no_types, lifting) arr_inv dom_inv in_homE trg_dom trg_inv)
	+ hence "trg n = trg w"
	+ using mn by (metis assms(2) ideD(1) trg.preserves_reflects_arr trg_hcomp')
	+ hence "hseq g n"
	+ using assms mn left_adjoint_is_ide ideD(1) by blast
	+ have "hseq g w"
	+ using assms left_adjoint_is_ide by simp
	+ have "src m = src n"
	+ using mn m\<^sub>a `hseq n m\<^sup>` adjoint_pair_antipar [of m "m\<^sup>"] by fastforce
	+
	+ have "is_left_adjoint (g \<star> n)"
	+ using assms mn left_adjoints_compose `hseq g n` by blast
	+ moreover have "src m = src (g \<star> n)"
	+ using assms mn `hseq g n` `src m = src n` by simp
	+ moreover have "(g \<star> n) \<star> m\<^sup>* \<cong> g \<star> w"
	+ proof -
	+ have 1: "src g = trg (n \<star> m\<^sup>*)"
	+ using assms `trg (n \<star> m\<^sup>*) = trg w` `hseq g w` by fastforce
	+ hence "(g \<star> n) \<star> m\<^sup>* \<cong> g \<star> n \<star> m\<^sup>*"
	+ using assms mn m\<^sub>a assoc_in_hom iso_assoc `hseq g n` `hseq n m\<^sup>*`
	+ isomorphic_def left_adjoint_is_ide right_adjoint_is_ide
	+ by (metis hseqE ideD(2) ideD(3))
	+ also have "... \<cong> g \<star> w"
	+ using assms 1 mn m\<^sub>a isomorphic_symmetric hcomp_ide_isomorphic left_adjoint_is_ide
	+ by simp
	+ finally show ?thesis
	+ using isomorphic_transitive by blast
	+ qed
	+ ultimately show ?thesis
	+ using assms mn m\<^sub>a BS2' by blast
	+ qed
	+ obtain \<sigma> where \<sigma>: "tabulation V H \<a> \<i> src trg (g \<star> w) \<sigma> m (g \<star> n)"
	+ using ex_\<sigma> by auto
	+
	+ interpret \<rho>: tabulation V H \<a> \<i> src trg \<open>g \<star> w\<close> \<rho> \<open>src w\<close> \<open>g \<star> w\<close>
	+ using \<rho> by auto
	+ interpret \<sigma>: tabulation V H \<a> \<i> src trg \<open>g \<star> w\<close> \<sigma> m \<open>g \<star> n\<close>
	+ using \<sigma> by auto
	+ text \<open>
	+ As usual, the sketch given by CKS seems more suggestive than it is a precise recipe.
	+ We can obtain an equivalence map \<open>\<guillemotleft>e : src w \<rightarrow> src m\<guillemotright>\<close> and \<open>\<theta>\<close> such that
	+ \<open>\<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright>\<close>.
	+ We can also obtain an equivalence map \<open>\<guillemotleft>e' : src m \<rightarrow> src w\<guillemotright>\<close> and \<open>\<theta>'\<close> such that
	+ \<open>\<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright>\<close>. If \<open>\<theta>'\<close> can be taken to be an isomorphism; then we have
	+ \<open>e' \<cong> src w \<star> e' \<cong> m\<close>. Since \<open>e'\<close> is an equivalence, this shows \<open>m\<close> is an equivalence,
	+ hence its right adjoint \<open>m\<^sup>*\<close> is also an equivalence and therefore a map.
	+ But \<open>w = n \<star> m\<^sub>a\<close>, so this shows that \<open>w\<close> is a map.
	+
	+ Now, we may assume without loss of generality that \<open>e\<close> and \<open>e'\<close> are part of an
	+ adjoint equivalence.
	+ We have \<open>\<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright>\<close> and \<open>\<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright>\<close>.
	+ We may take the transpose of \<open>\<theta>\<close> to obtain \<open>\<guillemotleft>\<zeta> : m \<Rightarrow> src w \<star> e'\<guillemotright>\<close>;
	+ then \<open>\<guillemotleft>\<theta>' \<cdot> \<zeta> : m \<Rightarrow> m\<guillemotright>\<close> and \<open>\<guillemotleft>\<zeta> \<cdot> \<theta>' : src w \<star> e' \<Rightarrow> src w \<star> e'\<guillemotright>\<close>.
	+ Since \<open>m\<close> and \<open>src w \<star> e'\<close> are maps, by \<open>BS3\<close> it must be that \<open>\<zeta>\<close> and \<open>\<theta>'\<close> are inverses.
	+ \<close>
	+ text \<open>
	+ {\bf Note:} CKS don't cite \<open>BS3\<close> here. I am not sure whether this result can be proved
	+ without \<open>BS3\<close>. For example, I am interested in knowing whether it can still be
	+ proved under the the assumption that 2-cells between maps are unique, but not
	+ necessarily invertible, or maybe even in a more general situation. It looks like
	+ the invertibility part of \<open>BS3\<close> is not used in the proof below.
	+ \<close>
	+ have 2: "\<exists>e e' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'.
	+ equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg e e' \<phi> \<psi> \<and>
	+ \<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<star> n \<Rightarrow> (g \<star> w) \<star> e'\<guillemotright> \<and> iso \<nu> \<and>
	+ \<sigma> = \<rho>.composite_cell e' \<theta>' \<cdot> \<nu> \<and>
	+ \<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright> \<and> \<guillemotleft>\<nu>' : g \<star> w \<Rightarrow> (g \<star> n) \<star> e\<guillemotright> \<and> iso \<nu>' \<and>
	+ \<rho> = ((g \<star> w) \<star> \<theta>) \<cdot> \<a>[g \<star> w, m, e] \<cdot> (\<sigma> \<star> e) \<cdot> \<nu>'"
	+ using \<rho> \<sigma>.apex_unique_up_to_equivalence [of \<rho> "src w" "g \<star> w"] comp_assoc
	+ by metis
	+ obtain e e' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'
	+ where *: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg e e' \<phi> \<psi> \<and>
	+ \<guillemotleft>\<theta>' : src w \<star> e' \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<star> n \<Rightarrow> (g \<star> w) \<star> e'\<guillemotright> \<and> iso \<nu> \<and>
	+ \<sigma> = \<rho>.composite_cell e' \<theta>' \<cdot> \<nu> \<and>
	+ \<guillemotleft>\<theta> : m \<star> e \<Rightarrow> src w\<guillemotright> \<and> \<guillemotleft>\<nu>' : g \<star> w \<Rightarrow> (g \<star> n) \<star> e\<guillemotright> \<and> iso \<nu>' \<and>
	+ \<rho> = \<sigma>.composite_cell e \<theta> \<cdot> \<nu>'"
	+ using 2 comp_assoc by auto
	+ interpret ee': equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg e e' \<phi> \<psi>
	+ using * by simp
	+
	+ have equiv_e: "equivalence_map e"
	+ using ee'.equivalence_in_bicategory_axioms equivalence_map_def by auto
	+ obtain \<psi>' where \<psi>': "adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg e e' \<phi> \<psi>'"
	+ using equivalence_refines_to_adjoint_equivalence [of e e' \<phi>]
	+ ee'.unit_in_hom(2) ee'.unit_is_iso ee'.antipar equiv_e
	+ by auto
	+ interpret ee': adjoint_equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg e e' \<phi> \<psi>'
	+ using \<psi>' by simp
	+ interpret e'e: adjoint_equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg e' e \<open>inv \<psi>'\<close> \<open>inv \<phi>\<close>
	+ using * ee'.dual_adjoint_equivalence by simp
	+ have equiv_e': "equivalence_map e'"
	+ using e'e.equivalence_in_bicategory_axioms equivalence_map_def by auto
	+
	+ have "hseq m e"
	+ using * ide_dom [of \<theta>]
	+ apply (elim conjE in_homE) by simp
	+ have "hseq (src w) e'"
	+ using * ide_dom [of \<theta>']
	+ apply (elim conjE in_homE) by simp
	+
	+ have "e'e.trnr\<^sub>\<eta> m \<theta> \<in> hom m (src w \<star> e')"
	+ proof -
	+ have "src m = trg e"
	+ using `hseq m e` by auto
	+ moreover have "src (src w) = trg e'"
	+ using `hseq (src w) e'` by auto
	+ moreover have "ide m"
	+ using mn left_adjoint_is_ide by simp
	+ moreover have "ide (src w)"
	+ using assms by simp
	+ ultimately show ?thesis
	+ using * e'e.adjoint_transpose_right(1) by blast
	+ qed
	+ hence 3: "\<guillemotleft>e'e.trnr\<^sub>\<eta> m \<theta> : m \<Rightarrow> src w \<star> e'\<guillemotright>"
	+ by simp
	+ hence "\<guillemotleft>\<theta>' \<cdot> e'e.trnr\<^sub>\<eta> m \<theta> : m \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>e'e.trnr\<^sub>\<eta> m \<theta> \<cdot> \<theta>' : src w \<star> e' \<Rightarrow> src w \<star> e'\<guillemotright>"
	+ using * by auto
	+ moreover have "\<guillemotleft>m : m \<Rightarrow> m\<guillemotright> \<and> \<guillemotleft>src w \<star> e' : src w \<star> e' \<Rightarrow> src w \<star> e'\<guillemotright>"
	+ using mn 3 ide_cod [of "e'e.trnr\<^sub>\<eta> m \<theta>"] left_adjoint_is_ide by fastforce
	+ moreover have 4: "is_left_adjoint (src w \<star> e')"
	+ proof -
	+ have "is_left_adjoint (src w)"
	+ using assms obj_is_self_adjoint by simp
	+ moreover have "is_left_adjoint e'"
	+ using e'e.adjunction_in_bicategory_axioms adjoint_pair_def by auto
	+ ultimately show ?thesis
	+ using left_adjoints_compose `hseq (src w) e'` by auto
	+ qed
	+ ultimately have "\<theta>' \<cdot> e'e.trnr\<^sub>\<eta> m \<theta> = m \<and> e'e.trnr\<^sub>\<eta> m \<theta> \<cdot> \<theta>' = src w \<star> e'"
	+ using mn BS3 [of m m "\<theta>' \<cdot> e'e.trnr\<^sub>\<eta> m \<theta>" m]
	+ BS3 [of "src w \<star> e'" "src w \<star> e'" "e'e.trnr\<^sub>\<eta> m \<theta> \<cdot> \<theta>'" "src w \<star> e'"]
	+ by auto
	+ hence "inverse_arrows \<theta>' (e'e.trnr\<^sub>\<eta> m \<theta>)"
	+ using mn 4 left_adjoint_is_ide inverse_arrows_def by simp
	+ hence 5: "iso \<theta>'"
	+ by auto
	+ have "equivalence_map (src w \<star> e')"
	+ using assms obj_is_equivalence_map equiv_e' `hseq (src w) e'` equivalence_maps_compose
	+ by auto
	+ hence "equivalence_map m"
	+ using * 5 equivalence_map_preserved_by_iso isomorphic_def by auto
	+ hence "equivalence_map m\<^sup>*"
	+ using mn m\<^sub>a right_adjoint_to_equivalence_is_equivalence by simp
	+ hence "is_left_adjoint m\<^sup>*"
	+ using equivalence_is_left_adjoint by simp
	+ moreover have "hseq n m\<^sup>*"
	+ using mn isomorphic_implies_ide by auto
	+ ultimately have "is_left_adjoint (n \<star> m\<^sup>*)"
	+ using mn left_adjoints_compose by blast
	+ thus ?thesis
	+ using mn left_adjoint_preserved_by_iso isomorphic_def isomorphic_symmetric
	+ by metis
	+ qed
	+
	+ end
	+
	+ subsection "Choosing Tabulations"
	+
	+ context bicategory_of_spans
	+ begin
	+
	+ notation isomorphic (infix "\<cong>" 50)
	+ notation iso_class ("\<lbrakk>_\<rbrakk>")
	+
	+ text \<open>
	+ We will ultimately need to have chosen a specific tabulation for each 1-cell.
	+ This has to be done carefully, to avoid unnecessary choices.
	+ We start out by using \<open>BS1\<close> to choose a specific factorization of the form
	+ \<open>r \<cong> tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*\<close> for each 1-cell \<open>r\<close>. This has to be done in such a way
	+ that all elements of an isomorphism class are assigned the same factorization.
	+ \<close>
	+
	+ abbreviation isomorphic_rep
	+ where "isomorphic_rep r f g \<equiv> is_left_adjoint f \<and> is_left_adjoint g \<and> g \<star> f\<^sup>* \<cong> r"
	+
	+ definition tab\<^sub>0
	+ where "tab\<^sub>0 r \<equiv> SOME f. \<exists>g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) f g"
	+
	+ definition tab\<^sub>1
	+ where "tab\<^sub>1 r \<equiv> SOME g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) (tab\<^sub>0 r) g"
	+
	+ definition rep
	+ where "rep r \<equiv> SOME \<phi>. \<guillemotleft>\<phi> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"
	+
	+ lemma rep_props:
	+ assumes "ide r"
	+ shows "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>" and "iso (rep r)"
	+ and "r \<cong> iso_class_rep \<lbrakk>r\<rbrakk>"
	+ and "isomorphic_rep r (tab\<^sub>0 r) (tab\<^sub>1 r)"
	+ and "tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<cong> r"
	+ proof -
	+ have 1: "isomorphic_rep r (tab\<^sub>0 r) (tab\<^sub>1 r)"
	+ proof -
	+ have "\<exists>f g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) f g"
	+ using assms BS1 isomorphic_symmetric rep_iso_class isomorphic_transitive
	+ by blast
	+ hence "isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) (tab\<^sub>0 r) (tab\<^sub>1 r)"
	+ using assms tab\<^sub>0_def tab\<^sub>1_def
	+ someI_ex [of "\<lambda>f. \<exists>g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) f g"]
	+ someI_ex [of "\<lambda>g. isomorphic_rep (iso_class_rep \<lbrakk>r\<rbrakk>) (tab\<^sub>0 r) g"]
	+ by simp
	+ thus ?thesis
	+ using assms isomorphic_symmetric isomorphic_transitive rep_iso_class by blast
	+ qed
	+ hence "\<exists>\<phi>. \<guillemotleft>\<phi> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"
	+ using isomorphic_def by blast
	+ hence 2: "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso (rep r)"
	+ using someI_ex [of "\<lambda>\<phi>. \<guillemotleft>\<phi> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright> \<and> iso \<phi>"] rep_def by auto
	+ show "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>"
	+ using 2 by simp
	+ show "iso (rep r)"
	+ using 2 by simp
	+ show "r \<cong> iso_class_rep \<lbrakk>r\<rbrakk>"
	+ using assms rep_iso_class isomorphic_symmetric by simp
	+ thus "isomorphic_rep r (tab\<^sub>0 r) (tab\<^sub>1 r)"
	+ using 1 isomorphic_transitive by blast
	+ thus "tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<cong> r"
	+ by simp
	+ qed
	+
	+ lemma tab\<^sub>0_in_hom [intro]:
	+ assumes "ide r"
	+ shows "\<guillemotleft>tab\<^sub>0 r : src (tab\<^sub>0 r) \<rightarrow> src r\<guillemotright>"
	+ and "\<guillemotleft>tab\<^sub>0 r : tab\<^sub>0 r \<Rightarrow> tab\<^sub>0 r\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>tab\<^sub>0 r : tab\<^sub>0 r \<Rightarrow> tab\<^sub>0 r\<guillemotright>"
	+ using assms rep_props left_adjoint_is_ide by auto
	+ have "trg (tab\<^sub>0 r) = src r"
	+ using assms rep_props
	+ by (metis ideD(1) isomorphic_implies_hpar(1) isomorphic_implies_hpar(3)
	+ right_adjoint_simps(2) src_hcomp')
	+ thus "\<guillemotleft>tab\<^sub>0 r : src (tab\<^sub>0 r) \<rightarrow> src r\<guillemotright>"
	+ using assms rep_props left_adjoint_is_ide
	+ by (intro in_hhomI, auto)
	+ qed
	+
	+ lemma tab\<^sub>0_simps [simp]:
	+ assumes "ide r"
	+ shows "ide (tab\<^sub>0 r)"
	+ and "is_left_adjoint (tab\<^sub>0 r)"
	+ and "trg (tab\<^sub>0 r) = src r"
	+ and "dom (tab\<^sub>0 r) = tab\<^sub>0 r" and "cod (tab\<^sub>0 r) = tab\<^sub>0 r"
	+ using assms tab\<^sub>0_in_hom rep_props ide_dom left_adjoint_is_ide by auto
	+
	+ lemma tab\<^sub>1_in_hom [intro]:
	+ assumes "ide r"
	+ shows "\<guillemotleft>tab\<^sub>1 r : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
	+ and "\<guillemotleft>tab\<^sub>1 r : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 r\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>tab\<^sub>1 r : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 r\<guillemotright>"
	+ using assms rep_props left_adjoint_is_ide by auto
	+ have "trg (tab\<^sub>1 r) = trg r"
	+ using assms rep_props
	+ by (metis ideD(1) isomorphic_implies_hpar(1) isomorphic_implies_hpar(4) trg_hcomp')
	+ moreover have "src (tab\<^sub>0 r) = src (tab\<^sub>1 r)"
	+ using assms rep_props by fastforce
	+ ultimately show "\<guillemotleft>tab\<^sub>1 r : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
	+ using assms rep_props left_adjoint_is_ide
	+ by (intro in_hhomI, auto)
	+ qed
	+
	+ lemma tab\<^sub>1_simps [simp]:
	+ assumes "ide r"
	+ shows "ide (tab\<^sub>1 r)"
	+ and "is_left_adjoint (tab\<^sub>1 r)"
	+ and "src (tab\<^sub>1 r) = src (tab\<^sub>0 r)" and "trg (tab\<^sub>1 r) = trg r"
	+ and "dom (tab\<^sub>1 r) = tab\<^sub>1 r" and "cod (tab\<^sub>1 r) = tab\<^sub>1 r"
	+ using assms tab\<^sub>1_in_hom rep_props ide_dom left_adjoint_is_ide by auto
	+
	+ lemma rep_in_hom [intro]:
	+ assumes "ide r"
	+ shows "\<guillemotleft>rep r : src r \<rightarrow> trg r\<guillemotright>"
	+ and "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>"
	+ using assms rep_props by auto
	+ thus "\<guillemotleft>rep r : src r \<rightarrow> trg r\<guillemotright>"
	+ using src_cod trg_cod by fastforce
	+ qed
	+
	+ lemma rep_simps [simp]:
	+ assumes "ide r"
	+ shows "arr (rep r)"
	+ and "src (rep r) = src r" and "trg (rep r) = trg r"
	+ and "dom (rep r) = tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*" and "cod (rep r) = r"
	+ using assms rep_in_hom by auto
	+
	+ lemma iso_rep:
	+ assumes "ide r"
	+ shows "iso (rep r)"
	+ using assms rep_props by simp
	+
	+ end
	+
	+ text \<open>
	+ Next, we assign a specific tabulation to each 1-cell r.
	+ We can't just do this any old way if we ultimately expect to obtain a mapping that is
	+ functorial with respect to vertical composition. What we have to do is to assign the
	+ representative \<open>tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*\<close> its canonical tabulation, obtained as the adjoint
	+ transpose of the identity, and then translate this to a tabulation of \<open>r\<close> via the chosen
	+ isomorphism \<open>\<guillemotleft>rep r : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>\<close>.
	+ \<close>
	+
	+ locale identity_in_bicategory_of_spans =
	+ bicategory_of_spans +
	+ fixes r :: 'a
	+ assumes is_ide: "ide r"
	+ begin
	+
	+ interpretation tab\<^sub>0: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>0 r\<close>
	+ using is_ide rep_props by (unfold_locales, auto)
	+ interpretation tab\<^sub>1: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>1 r\<close>
	+ using is_ide rep_props by (unfold_locales, auto)
	+
	+ text \<open>
	+ A tabulation \<open>(tab\<^sub>0 r, tab, tab\<^sub>1 r)\<close> of \<open>r\<close> can be obtained as the adjoint transpose
	+ of the isomorphism \<open>\<guillemotleft>rep r : (tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>\<close>. It is essential to define
	+ it this way if we expect the mapping from 2-cells of the underlying bicategory
	+ to arrows of spans to preserve vertical composition.
	+ \<close>
	+
	+ definition tab
	+ where "tab \<equiv> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) (rep r)"
	+
	+ text \<open>
	+ In view of \<open>BS2'\<close>, the 1-cell \<open>(tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*\<close> has the canonical tabulation
	+ obtained via adjoint transpose of an identity. In fact, this tabulation generates the
	+ chosen tabulation of \<open>r\<close> in the same isomorphism class by translation along the
	+ isomorphism \<open>\<guillemotleft>rep r : (tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> r\<guillemotright>\<close>. This fact is used to show that the
	+ mapping from 2-cells to arrows of spans preserves identities.
	+ \<close>
	+
	+ lemma canonical_tabulation:
	+ shows "tabulation V H \<a> \<i> src trg
	+ ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>) (tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>)) (tab\<^sub>0 r) (tab\<^sub>1 r)"
	+ proof -
	+ have "\<exists>\<rho>. tabulation V H \<a> \<i> src trg ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) \<rho> (tab\<^sub>0 r) (tab\<^sub>1 r)"
	+ by (simp add: bicategory_of_spans.BS2' bicategory_of_spans_axioms is_ide
	+ isomorphic_reflexive)
	+ thus ?thesis
	+ using is_ide tab\<^sub>0.canonical_tabulation by simp
	+ qed
	+
	+ lemma tab_def_alt:
	+ shows "tab = (rep r \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ and "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> tab = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ proof -
	+ have "tab = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) (rep r \<cdot> ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*))"
	+ using tab_def is_ide rep_in_hom [of r] comp_arr_dom by auto
	+ also have "... = (rep r \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ using is_ide tab\<^sub>0.trnr\<^sub>\<eta>_comp by auto
	+ finally show 1: "tab = (rep r \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)" by simp
	+ have "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> tab =
	+ ((inv (rep r) \<star> tab\<^sub>0 r) \<cdot> (rep r \<star> tab\<^sub>0 r)) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ unfolding 1 using comp_assoc by simp
	+ also have "... = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ proof -
	+ have 1: "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> (rep r \<star> tab\<^sub>0 r) = ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) \<star> tab\<^sub>0 r"
	+ using whisker_right [of "tab\<^sub>0 r" "inv (rep r)" "rep r"] iso_rep rep_in_hom
	+ inv_is_inverse comp_inv_arr
	+ by (simp add: comp_inv_arr' is_ide)
	+ show ?thesis
	+ proof -
	+ have "\<guillemotleft>tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*) :
	+ tab\<^sub>1 r \<Rightarrow> (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*) \<star> tab\<^sub>0 r\<guillemotright>"
	+ by (meson canonical_tabulation tabulation_data.tab_in_hom(2) tabulation_def)
	+ hence "((tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>) \<star> tab\<^sub>0 r) \<cdot> tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>) =
	+ tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ using 1 comp_cod_arr by blast
	+ thus ?thesis
	+ using 1 by simp
	+ qed
	+ qed
	+ finally show "(inv (rep r) \<star> tab\<^sub>0 r) \<cdot> tab = tab\<^sub>0.trnr\<^sub>\<eta> (tab\<^sub>1 r) ((tab\<^sub>1 r) \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ by blast
	+ qed
	+
	+ lemma tab_is_tabulation:
	+ shows "tabulation V H \<a> \<i> src trg r tab (tab\<^sub>0 r) (tab\<^sub>1 r)"
	+ by (metis bicategory_of_spans.iso_rep bicategory_of_spans.rep_in_hom(2)
	+ bicategory_of_spans_axioms is_ide canonical_tabulation tab_def_alt(1)
	+ tabulation.is_preserved_by_base_iso)
	+
	+ (*
	+ * TODO: If I pull the interpretation "tab" out of the following, Isabelle warns that
	+ * the lemma is a redundant introduction rule and is being "ignored" for that purpose.
	+ * However, the redundancy is only in the present context: if the enclosing locale is
	+ * interpreted elsewhere, then the rule is not redundant. In order to make sure that
	+ * the rule is not "ignored", I have put the interpretation "tab" into the proof to
	+ * avoid the warning.
	+ *)
	+
	+ lemma tab_in_hom [intro]:
	+ shows "\<guillemotleft>tab : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
	+ and "\<guillemotleft>tab : tab\<^sub>1 r \<Rightarrow> r \<star> tab\<^sub>0 r\<guillemotright>"
	+ proof -
	+ interpret tab: tabulation V H \<a> \<i> src trg r tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
	+ using tab_is_tabulation by simp
	+ show "\<guillemotleft>tab : src (tab\<^sub>0 r) \<rightarrow> trg r\<guillemotright>"
	+ using tab.tab_in_hom by auto
	+ show "\<guillemotleft>tab : tab\<^sub>1 r \<Rightarrow> r \<star> tab\<^sub>0 r\<guillemotright>"
	+ using tab.tab_in_hom by auto
	+ qed
	+
	+ lemma tab_simps [simp]:
	+ shows "arr tab"
	+ and "src tab = src (tab\<^sub>0 r)" and "trg tab = trg r"
	+ and "dom tab = tab\<^sub>1 r" and "cod tab = r \<star> tab\<^sub>0 r"
	+ using tab_in_hom by auto
	+
	+ end
	+
	+ text \<open>
	+ The following makes the chosen tabulation conveniently available whenever we are
	+ considering a particular 1-cell.
	+ \<close>
	+
	+ sublocale identity_in_bicategory_of_spans \<subseteq> tabulation V H \<a> \<i> src trg r tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
	+ using is_ide tab_is_tabulation by simp
	+
	+ context identity_in_bicategory_of_spans
	+ begin
	+
	+ interpretation tab\<^sub>0: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>0 r\<close>
	+ using is_ide rep_props by (unfold_locales, auto)
	+ interpretation tab\<^sub>1: map_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>1 r\<close>
	+ using is_ide rep_props by (unfold_locales, auto)
	+
	+ text \<open>
	+ The fact that adjoint transpose is a bijection allows us to invert the definition
	+ of \<open>tab\<close> in terms of \<open>rep\<close> to express rep in terms of tab.
	+ \<close>
	+
	+ lemma rep_in_terms_of_tab:
	+ shows "rep r = T0.trnr\<^sub>\<epsilon> r tab"
	+ using is_ide T0.adjoint_transpose_right(3) [of r "tab\<^sub>1 r" "rep r"] tab_def
	+ by fastforce
	+
	+ lemma isomorphic_implies_same_tab:
	+ assumes "isomorphic r r'"
	+ shows "tab\<^sub>0 r = tab\<^sub>0 r'" and "tab\<^sub>1 r = tab\<^sub>1 r'"
	+ using assms tab\<^sub>0_def tab\<^sub>1_def iso_class_eqI by auto
	+
	+ text \<open>
	+ ``Every 1-cell has a tabulation as a span of maps.''
	+ Has a nice simple ring to it, but maybe not so useful for us, since we generally
	+ really need to know that the tabulation has a specific form.
	+ \<close>
	+
	+ lemma has_tabulation:
	+ shows "\<exists>\<rho> f g. is_left_adjoint f \<and> is_left_adjoint g \<and> tabulation V H \<a> \<i> src trg r \<rho> f g"
	+ using is_ide tab_is_tabulation rep_props by blast
	+
	+ end
	+
	+ subsection "Tabulations in a Bicategory of Spans"
	+
	+ context bicategory_of_spans
	+ begin
	+
	+ abbreviation tab_of_ide
	+ where "tab_of_ide r \<equiv> identity_in_bicategory_of_spans.tab V H \<a> \<i> src trg r"
	+
	+ abbreviation prj\<^sub>0
	+ where "prj\<^sub>0 h k \<equiv> tab\<^sub>0 (k\<^sup>* \<star> h)"
	+
	+ abbreviation prj\<^sub>1
	+ where "prj\<^sub>1 h k \<equiv> tab\<^sub>1 (k\<^sup>* \<star> h)"
	+
	+ lemma prj_in_hom [intro]:
	+ assumes "ide h" and "is_left_adjoint k" and "trg h = trg k"
	+ shows "\<guillemotleft>prj\<^sub>0 h k : src (prj\<^sub>0 h k) \<rightarrow> src h\<guillemotright>"
	+ and "\<guillemotleft>prj\<^sub>1 h k : src (prj\<^sub>0 h k) \<rightarrow> src k\<guillemotright>"
	+ and "\<guillemotleft>prj\<^sub>0 h k : prj\<^sub>0 h k \<Rightarrow> prj\<^sub>0 h k\<guillemotright>"
	+ and "\<guillemotleft>prj\<^sub>1 h k : prj\<^sub>1 h k \<Rightarrow> prj\<^sub>1 h k\<guillemotright>"
	+ by (intro in_hhomI, auto simp add: assms(1-3))
	+
	+ lemma prj_simps [simp]:
	+ assumes "ide h" and "is_left_adjoint k" and "trg h = trg k"
	+ shows "trg (prj\<^sub>0 h k) = src h"
	+ and "src (prj\<^sub>1 h k) = src (prj\<^sub>0 h k)" and "trg (prj\<^sub>1 h k) = src k"
	+ and "dom (prj\<^sub>0 h k) = prj\<^sub>0 h k" and "cod (prj\<^sub>0 h k) = prj\<^sub>0 h k"
	+ and "dom (prj\<^sub>1 h k) = prj\<^sub>1 h k" and "cod (prj\<^sub>1 h k) = prj\<^sub>1 h k"
	+ and "is_left_adjoint (prj\<^sub>0 h k)" and "is_left_adjoint (prj\<^sub>1 h k)"
	+ using assms prj_in_hom by auto
	+
	+ end
	+
	+ text \<open>
	+ Many of the commutativity conditions that we would otherwise have to worry about
	+ when working with tabulations in a bicategory of spans reduce to trivialities.
	+ The following locales try to exploit this to make our life more manageable.
	+ \<close>
	+
	+ locale span_of_maps =
	+ bicategory_of_spans +
	+ fixes leg\<^sub>0 :: 'a
	+ and leg\<^sub>1 :: 'a
	+ assumes leg0_is_map: "is_left_adjoint leg\<^sub>0"
	+ and leg1_is_map : "is_left_adjoint leg\<^sub>1"
	+
	+ text \<open>
	+ The purpose of the somewhat strange-looking assumptions in this locale is
	+ to cater to the form of data that we obtain from \<open>T1\<close>. Under the assumption
	+ that we are in a bicategory of spans and that the legs of \<open>r\<close> and \<open>s\<close> are maps,
	+ the hypothesized 2-cells will be uniquely determined isomorphisms, and an
	+ arrow of spans \<open>w\<close> from \<open>r\<close> to \<open>s\<close> will be a map. We want to prove this once and
	+ for all under the weakest assumptions we can manage.
	+ \<close>
	+
	+ locale arrow_of_spans_of_maps =
	+ bicategory_of_spans V H \<a> \<i> src trg +
	+ r: span_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 +
	+ s: span_of_maps V H \<a> \<i> src trg s\<^sub>0 s\<^sub>1
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and r\<^sub>0 :: 'a
	+ and r\<^sub>1 :: 'a
	+ and s\<^sub>0 :: 'a
	+ and s\<^sub>1 :: 'a
	+ and w :: 'a +
	+ assumes is_ide: "ide w"
	+ and leg0_lax: "\<exists>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
	+ and leg1_iso: "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>"
	+ begin
	+
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ lemma composite_leg1_is_map:
	+ shows "is_left_adjoint (s\<^sub>1 \<star> w)"
	+ using r.leg1_is_map leg1_iso left_adjoint_preserved_by_iso' isomorphic_def
	+ isomorphic_symmetric
	+ by auto
	+
	+ lemma is_map:
	+ shows "is_left_adjoint w"
	+ using is_ide composite_leg1_is_map s.leg1_is_map BS4 [of s\<^sub>1 w] by auto
	+
	+ lemma hseq_leg\<^sub>0:
	+ shows "hseq s\<^sub>0 w"
	+ by (metis ideD(1) ide_dom in_homE leg0_lax)
	+
	+ lemma composite_with_leg0_is_map:
	+ shows "is_left_adjoint (s\<^sub>0 \<star> w)"
	+ using left_adjoints_compose is_map s.leg0_is_map hseq_leg\<^sub>0 by blast
	+
	+ lemma leg0_uniquely_isomorphic:
	+ shows "s\<^sub>0 \<star> w \<cong> r\<^sub>0"
	+ and "\<exists>!\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
	+ proof -
	+ show 1: "s\<^sub>0 \<star> w \<cong> r\<^sub>0"
	+ using leg0_lax composite_with_leg0_is_map r.leg0_is_map BS3 [of "s\<^sub>0 \<star> w" r\<^sub>0]
	+ isomorphic_def
	+ by auto
	+ have "\<exists>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> iso \<theta>"
	+ using 1 isomorphic_def by simp
	+ moreover have "\<And>\<theta> \<theta>'. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<Longrightarrow> \<guillemotleft>\<theta>' : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<Longrightarrow> \<theta> = \<theta>'"
	+ using BS3 r.leg0_is_map composite_with_leg0_is_map by blast
	+ ultimately show "\<exists>!\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>" by blast
	+ qed
	+
	+ lemma leg1_uniquely_isomorphic:
	+ shows "r\<^sub>1 \<cong> s\<^sub>1 \<star> w"
	+ and "\<exists>!\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
	+ proof -
	+ show 1: "r\<^sub>1 \<cong> s\<^sub>1 \<star> w"
	+ using leg1_iso isomorphic_def by auto
	+ have "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>"
	+ using leg1_iso isomorphic_def isomorphic_symmetric by simp
	+ moreover have "\<And>\<nu> \<nu>'. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<Longrightarrow> \<guillemotleft>\<nu>' : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<Longrightarrow> \<nu> = \<nu>'"
	+ using BS3 r.leg1_is_map composite_leg1_is_map by blast
	+ ultimately show "\<exists>!\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>" by blast
	+ qed
	+
	+ definition the_\<theta>
	+ where "the_\<theta> \<equiv> THE \<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
	+
	+ definition the_\<nu>
	+ where "the_\<nu> \<equiv> THE \<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
	+
	+ lemma the_\<theta>_props:
	+ shows "\<guillemotleft>the_\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>" and "iso the_\<theta>"
	+ proof -
	+ show "\<guillemotleft>the_\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
	+ unfolding the_\<theta>_def
	+ using the1I2 [of "\<lambda>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>" "\<lambda>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"]
	+ leg0_uniquely_isomorphic
	+ by simp
	+ thus "iso the_\<theta>"
	+ using BS3 r.leg0_is_map composite_with_leg0_is_map by simp
	+ qed
	+
	+ lemma the_\<theta>_in_hom [intro]:
	+ shows "\<guillemotleft>the_\<theta> : src r\<^sub>0 \<rightarrow> trg r\<^sub>0\<guillemotright>"
	+ and "\<guillemotleft>the_\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright>"
	+ using the_\<theta>_props apply auto
	+ by (metis cod_trg in_hhom_def in_homE isomorphic_implies_hpar(3) leg0_uniquely_isomorphic(1)
	+ src_dom trg.preserves_cod)
	+
	+ lemma the_\<theta>_simps [simp]:
	+ shows "arr the_\<theta>"
	+ and "src the_\<theta> = src r\<^sub>0" and "trg the_\<theta> = trg r\<^sub>0"
	+ and "dom the_\<theta> = s\<^sub>0 \<star> w" and "cod the_\<theta> = r\<^sub>0"
	+ using the_\<theta>_in_hom by auto
	+
	+ lemma the_\<nu>_props:
	+ shows "\<guillemotleft>the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>" and "iso the_\<nu>"
	+ proof -
	+ show "\<guillemotleft>the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
	+ unfolding the_\<nu>_def
	+ using the1I2 [of "\<lambda>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>" "\<lambda>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"]
	+ leg1_uniquely_isomorphic
	+ by simp
	+ thus "iso the_\<nu>"
	+ using BS3 r.leg1_is_map composite_leg1_is_map by simp
	+ qed
	+
	+ lemma the_\<nu>_in_hom [intro]:
	+ shows "\<guillemotleft>the_\<nu> : src r\<^sub>1 \<rightarrow> trg r\<^sub>1\<guillemotright>"
	+ and "\<guillemotleft>the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright>"
	+ using the_\<nu>_props apply auto
	+ by (metis in_hhom_def in_homE isomorphic_implies_hpar(3) leg1_uniquely_isomorphic(1)
	+ src_cod trg_dom)
	+
	+ lemma the_\<nu>_simps [simp]:
	+ shows "arr the_\<nu>"
	+ and "src the_\<nu> = src r\<^sub>1" and "trg the_\<nu> = trg r\<^sub>1"
	+ and "dom the_\<nu> = r\<^sub>1" and "cod the_\<nu> = s\<^sub>1 \<star> w"
	+ using the_\<nu>_in_hom by auto
	+
	+ end
	+
	+ (*
	+ * TODO: I could probably avoid repeating the declarations of the locale parameters
	+ * if I was willing to accept them being given in their order of appearance.
	+ *)
	+
	+ locale arrow_of_spans_of_maps_to_tabulation_data =
	+ bicategory_of_spans V H \<a> \<i> src trg +
	+ arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 w +
	+ \<sigma>: tabulation_data V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and r\<^sub>0 :: 'a
	+ and r\<^sub>1 :: 'a
	+ and s :: 'a
	+ and \<sigma> :: 'a
	+ and s\<^sub>0 :: 'a
	+ and s\<^sub>1 :: 'a
	+ and w :: 'a
	+
	+ text \<open>
	+ The following declaration allows us to inherit the rules and other facts defined in
	+ locale @{locale uw\<theta>}. It is tedious to prove very much without these in place.
	+ \<close>
	+
	+ sublocale arrow_of_spans_of_maps_to_tabulation_data \<subseteq> uw\<theta> V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 r\<^sub>0 w the_\<theta>
	+ using \<sigma>.tab_in_hom is_ide the_\<theta>_props by (unfold_locales, auto)
	+
	+ locale arrow_of_spans_of_maps_to_tabulation =
	+ arrow_of_spans_of_maps_to_tabulation_data +
	+ tabulation V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
	+
	+ locale tabulation_in_maps =
	+ span_of_maps V H \<a> \<i> src trg s\<^sub>0 s\<^sub>1 +
	+ tabulation V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and s :: 'a
	+ and \<sigma> :: 'a
	+ and s\<^sub>0 :: 'a
	+ and s\<^sub>1 :: 'a
	+
	+ sublocale tabulation_in_maps \<subseteq> tabulation V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 ..
	+
	+ sublocale identity_in_bicategory_of_spans \<subseteq>
	+ tabulation_in_maps V H \<a> \<i> src trg r tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
	+ using is_ide rep_props by (unfold_locales, auto)
	+
	+ locale cospan_of_maps_in_bicategory_of_spans =
	+ bicategory_of_spans +
	+ fixes h :: 'a
	+ and k :: 'a
	+ assumes h_is_map: "is_left_adjoint h"
	+ and k_is_map: "is_left_adjoint k"
	+ and cospan: "trg h = trg k"
	+ begin
	+
	+ text \<open>
	+ The following sublocale declaration is perhaps pushing the limits of sensibility,
	+ but the purpose is, given a cospan of maps \<open>(h, k)\<close>, to obtain ready access to the
	+ composite \<open>k\<^sup>* \<star> h\<close> and its chosen tabulation.
	+ \<close>
	+
	+ sublocale identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close>
	+ using h_is_map k_is_map cospan left_adjoint_is_ide
	+ by (unfold_locales, auto)
	+
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ interpretation h: map_in_bicategory V H \<a> \<i> src trg h
	+ using h_is_map by (unfold_locales, auto)
	+ interpretation k: map_in_bicategory V H \<a> \<i> src trg k
	+ using k_is_map by (unfold_locales, auto)
	+
	+ text \<open>
	+ Our goal here is to reformulate the biuniversal properties of the chosen tabulation
	+ of \<open>k\<^sup>* \<star> h\<close> in terms of its transpose, which yields a 2-cell from \<open>k \<star> tab\<^sub>1 (k\<^sup>* \<star> h)\<close>
	+ to \<open>h \<star> tab\<^sub>0 (k\<^sup>* \<star> h)\<close>. These results do not depend on \<open>BS3\<close>.
	+ \<close>
	+
	+ abbreviation p\<^sub>0
	+ where "p\<^sub>0 \<equiv> prj\<^sub>0 h k"
	+
	+ abbreviation p\<^sub>1
	+ where "p\<^sub>1 \<equiv> prj\<^sub>1 h k"
	+
	+ lemma p\<^sub>0_in_hom [intro]:
	+ shows "\<guillemotleft>p\<^sub>0 : src p\<^sub>0 \<rightarrow> src h\<guillemotright>"
	+ by auto
	+
	+ lemma p\<^sub>1_in_hom [intro]:
	+ shows "\<guillemotleft>p\<^sub>1 : src p\<^sub>0 \<rightarrow> src k\<guillemotright>"
	+ using prj_in_hom cospan h.ide_left k_is_map by blast
	+
	+ lemma p\<^sub>0_simps [simp]:
	+ shows "trg p\<^sub>0 = src h"
	+ by simp
	+
	+ lemma p\<^sub>1_simps [simp]:
	+ shows "trg p\<^sub>1 = src k"
	+ using k.antipar(1) by auto
	+
	+ definition \<phi>
	+ where "\<phi> \<equiv> k.trnl\<^sub>\<epsilon> (h \<star> p\<^sub>0) (\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> tab)"
	+
	+ lemma \<phi>_in_hom [intro]:
	+ shows "\<guillemotleft>\<phi> : src p\<^sub>0 \<rightarrow> trg h\<guillemotright>"
	+ and "\<guillemotleft>\<phi> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright>"
	+ proof -
	+ show 1: "\<guillemotleft>\<phi> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright>"
	+ unfolding \<phi>_def
	+ using k.antipar cospan k.adjoint_transpose_left(2) [of "h \<star> p\<^sub>0" "p\<^sub>1"]
	+ by fastforce
	+ show "\<guillemotleft>\<phi> : src p\<^sub>0 \<rightarrow> trg h\<guillemotright>"
	+ using 1 k.antipar src_dom trg_cod by fastforce
	+ qed
	+
	+ lemma \<phi>_simps [simp]:
	+ shows "arr \<phi>"
	+ and "src \<phi> = src p\<^sub>0" and "trg \<phi> = trg h"
	+ and "dom \<phi> = k \<star> p\<^sub>1" and "cod \<phi> = h \<star> p\<^sub>0"
	+ using \<phi>_in_hom by auto
	+
	+ lemma transpose_\<phi>:
	+ shows "tab = \<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> k.trnl\<^sub>\<eta> p\<^sub>1 \<phi>"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, p\<^sub>0] \<cdot> k.trnl\<^sub>\<eta> p\<^sub>1 \<phi> =
	+ \<a>\<^sup>-\<^sup>1[k\<^sup>, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>, h, p\<^sub>0] \<cdot> tab"
	+ unfolding \<phi>_def
	+ using k.antipar cospan
	+ k.adjoint_transpose_left(4)
	+ [of "h \<star> p\<^sub>0" "p\<^sub>1" "\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> tab"]
	+ by fastforce
	+ also have "... = (\<a>\<^sup>-\<^sup>1[k\<^sup>, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>, h, p\<^sub>0]) \<cdot> tab"
	+ using comp_assoc by simp
	+ also have "... = tab"
	+ using k.antipar cospan comp_cod_arr comp_assoc_assoc' by simp
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma transpose_triangle:
	+ assumes "ide w"
	+ and "\<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>" and "\<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright>"
	+ shows "k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>, h, u] \<cdot> ((k\<^sup> \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>) =
	+ (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>)"
	+ proof -
	+ have u: "ide u"
	+ using assms(2) by auto
	+ have v: "ide v"
	+ using assms(3) by auto
	+ have 0: "src p\<^sub>0 = trg w"
	+ by (metis assms(2) hseqE ideD(1) src.preserves_reflects_arr u vconn_implies_hpar(3))
	+ have 1: "src h = trg u"
	+ using assms(1-2) 0 trg_dom trg_cod hseqI' vconn_implies_hpar(4) by auto
	+ have 2: "src k = trg v"
	+ using assms(1,3) 0 trg_dom trg_cod hseqI'
	+ by (metis ideD(1) leg1_simps(2) leg1_simps(3) p\<^sub>1_simps trg_hcomp' vconn_implies_hpar(4))
	+ have 3: "src u = src v \<and> src u = src w"
	+ using assms 0 k.antipar src_dom src_cod hseqI'
	+ by (metis ideD(1) leg0_simps(2) leg1_simps(2) leg1_simps(3) src_hcomp'
	+ vconn_implies_hpar(3))
	+ have 4: "src h = trg \<theta>"
	+ using assms 1 k.antipar by auto
	+ define \<chi> where "\<chi> = \<a>[k\<^sup>, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup> \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)"
	+ have \<chi>: "\<guillemotleft>\<chi> : p\<^sub>1 \<star> w \<Rightarrow> k\<^sup>* \<star> h \<star> p\<^sub>0 \<star> w\<guillemotright>"
	+ unfolding \<chi>_def
	+ using assms 0 k.antipar cospan by (intro comp_in_homI, auto)
	+ have "k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>, h, u] \<cdot> ((k\<^sup> \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>) =
	+ k.trnl\<^sub>\<epsilon> (h \<star> u) ((k\<^sup>* \<star> h \<star> \<theta>) \<cdot> \<chi> \<cdot> \<nu>)"
	+ unfolding \<chi>_def
	+ using assms 1 k.antipar cospan assoc_naturality [of "k\<^sup>*" h \<theta>] comp_assoc
	+ by (metis "4" h.ide_left ide_char in_homE k.ide_right)
	+ also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) (k\<^sup>* \<star> h \<star> \<theta>) \<cdot> (k \<star> \<chi> \<cdot> \<nu>)"
	+ proof -
	+ have "ide (h \<star> u)"
	+ using "1" u assms h.ide_left by blast
	+ moreover have "seq (k\<^sup>* \<star> h \<star> \<theta>) (\<chi> \<cdot> \<nu>)"
	+ using assms 1 k.antipar cospan \<chi> seqI' hseqI'
	+ apply (intro seqI)
	+ apply auto
	+ apply blast
	+ proof -
	+ have "dom (k\<^sup>* \<star> h \<star> \<theta>) = k\<^sup>* \<star> h \<star> p\<^sub>0 \<star> w"
	+ using assms
	+ by (metis "4" cospan hcomp_simps(2-3) h.ide_left hseqI' ide_char in_homE k.antipar(2)
	+ k.ide_right)
	+ also have "... = cod \<chi>"
	+ using \<chi> by auto
	+ finally show "dom (k\<^sup>* \<star> h \<star> \<theta>) = cod \<chi>" by simp
	+ qed
	+ moreover have "src k = trg (k\<^sup>* \<star> h \<star> \<theta>)"
	+ using assms k.antipar cospan calculation(2) by auto
	+ ultimately show ?thesis
	+ using k.trnl\<^sub>\<epsilon>_comp by simp
	+ qed
	+ also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) (k\<^sup>* \<star> h \<star> \<theta>) \<cdot> (k \<star> \<chi>) \<cdot> (k \<star> \<nu>)"
	+ using assms u \<chi> whisker_left
	+ by (metis k.ide_left seqI')
	+ also have
	+ "... = (\<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> u] \<cdot> (k \<star> k\<^sup> \<star> h \<star> \<theta>)) \<cdot> (k \<star> \<chi>) \<cdot> (k \<star> \<nu>)"
	+ unfolding k.trnl\<^sub>\<epsilon>_def by simp
	+ also have "... = (h \<star> \<theta>) \<cdot>
	+ (\<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot> (k \<star> \<chi>)) \<cdot>
	+ (k \<star> \<nu>)"
	+ proof -
	+ have "\<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> u] \<cdot> (k \<star> k\<^sup> \<star> h \<star> \<theta>) =
	+ \<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>) \<star> h \<star> \<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0 \<star> w]"
	+ using assms 4 k.antipar cospan assoc'_naturality [of k "k\<^sup>*" "h \<star> \<theta>"] hseqI' by auto
	+ also have "... = \<l>[h \<star> u] \<cdot> ((k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>) \<star> h \<star> \<theta>)) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0 \<star> w]"
	+ using comp_assoc by simp
	+ also have "... = (\<l>[h \<star> u] \<cdot> (trg k \<star> h \<star> \<theta>)) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
	+ proof -
	+ have "(k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>) \<star> h \<star> \<theta>) = k.\<epsilon> \<cdot> (k \<star> k\<^sup>) \<star> (h \<star> u) \<cdot> (h \<star> \<theta>)"
	+ using assms 1 k.antipar cospan hseqI' interchange comp_arr_dom comp_cod_arr
	+ k.counit_in_hom
	+ by fastforce
	+ also have "... = k.\<epsilon> \<star> h \<star> \<theta>"
	+ using assms k.antipar cospan comp_arr_dom comp_cod_arr k.counit_in_hom
	+ whisker_left
	+ by (metis h.ide_left in_homE)
	+ also have "... = (trg k \<star> h \<star> \<theta>) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w)"
	+ using assms 4 k.antipar cospan whisker_left comp_arr_dom comp_cod_arr hseqI'
	+ interchange [of "trg k" k.\<epsilon> "h \<star> \<theta>" "h \<star> p\<^sub>0 \<star> w"]
	+ by auto
	+ finally have "(k.\<epsilon> \<star> h \<star> u) \<cdot> ((k \<star> k\<^sup>*) \<star> h \<star> \<theta>) = (trg k \<star> h \<star> \<theta>) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (h \<star> \<theta>) \<cdot> \<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
	+ proof -
	+ have "\<l>[h \<star> u] \<cdot> (trg k \<star> h \<star> \<theta>) = (h \<star> \<theta>) \<cdot> \<l>[h \<star> p\<^sub>0 \<star> w]"
	+ using assms 1 4 k.antipar cospan lunit_naturality [of "h \<star> \<theta>"]
	+ by (metis hcomp_simps(3-4) h.ide_left hseqI' ide_char in_homE trg_hcomp')
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ finally have "\<l>[h \<star> u] \<cdot> (k.\<epsilon> \<star> h \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> u] \<cdot> (k \<star> k\<^sup> \<star> h \<star> \<theta>) =
	+ (h \<star> \<theta>) \<cdot> \<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w]"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>)"
	+ proof -
	+ have "\<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
	+ (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup> \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)) =
	+ \<a>[h, p\<^sub>0, w] \<cdot> \<l>[(h \<star> p\<^sub>0) \<star> w] \<cdot>
	+ (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
	+ (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup> \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
	+ proof -
	+ have "\<l>[h \<star> p\<^sub>0 \<star> w] =
	+ \<a>[h, p\<^sub>0, w] \<cdot> \<l>[(h \<star> p\<^sub>0) \<star> w] \<cdot> (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
	+ proof -
	+ have "\<a>[h, p\<^sub>0, w] \<cdot> \<l>[(h \<star> p\<^sub>0) \<star> w] \<cdot> (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) =
	+ \<a>[h, p\<^sub>0, w] \<cdot> \<ll> ((h \<star> p\<^sub>0) \<star> w) \<cdot> (trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
	+ using assms 0 k.antipar cospan comp_cod_arr \<ll>_ide_simp by simp
	+ also have "... = \<a>[h, p\<^sub>0, w] \<cdot> \<ll> (\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
	+ using assms 0 k.antipar cospan \<ll>.is_natural_2 [of "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]"] by simp
	+ also have "... = \<a>[h, p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w] \<cdot> \<ll> (h \<star> p\<^sub>0 \<star> w)"
	+ using assms 0 k.antipar cospan \<ll>.is_natural_1 [of "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]"] comp_assoc
	+ by simp
	+ also have "... = (\<a>[h, p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<ll> (h \<star> p\<^sub>0 \<star> w)"
	+ using comp_assoc by simp
	+ also have "... = \<ll> (h \<star> p\<^sub>0 \<star> w)"
	+ using assms 0 k.antipar cospan comp_cod_arr comp_assoc_assoc' by simp
	+ also have "... = \<l>[h \<star> p\<^sub>0 \<star> w]"
	+ using assms 0 k.antipar cospan \<ll>_ide_simp by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[trg h, h \<star> p\<^sub>0, w] \<cdot>
	+ ((trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
	+ (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup> \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
	+ using assms 0 k.antipar cospan lunit_hcomp comp_assoc by simp
	+ also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[trg h, h \<star> p\<^sub>0, w] \<cdot> (k.\<epsilon> \<star> (h \<star> p\<^sub>0) \<star> w)) \<cdot>
	+ ((k \<star> k\<^sup>) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0 \<star> w] \<cdot>
	+ (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup> \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
	+ proof -
	+ have "(trg h \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) =
	+ (k.\<epsilon> \<star> (h \<star> p\<^sub>0) \<star> w) \<cdot> ((k \<star> k\<^sup>*) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w])"
	+ using assms 0 k.antipar cospan comp_arr_dom comp_cod_arr
	+ interchange [of "trg h" k.\<epsilon> "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]" "h \<star> p\<^sub>0 \<star> w"]
	+ interchange [of k.\<epsilon> "k \<star> k\<^sup>*" "(h \<star> p\<^sub>0) \<star> w" "\<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]"]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
	+ ((k.\<epsilon> \<star> (h \<star> p\<^sub>0)) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot>
	+ ((k \<star> k\<^sup>) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0 \<star> w] \<cdot>
	+ (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup> \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
	+ using assms 0 k.antipar cospan assoc'_naturality [of k.\<epsilon> "h \<star> p\<^sub>0" w] comp_assoc
	+ by simp
	+ also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
	+ ((k.\<epsilon> \<star> (h \<star> p\<^sub>0)) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot>
	+ ((k \<star> k\<^sup>) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0 \<star> w] \<cdot>
	+ (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w]) \<cdot> (k \<star> \<a>[k\<^sup> \<star> h, p\<^sub>0, w]) \<cdot>
	+ (k \<star> tab \<star> w)"
	+ proof -
	+ have "k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup> \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) =
	+ (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w]) \<cdot> (k \<star> \<a>[k\<^sup> \<star> h, p\<^sub>0, w]) \<cdot>
	+ (k \<star> tab \<star> w)"
	+ proof -
	+ have "seq \<a>[k\<^sup>, h, p\<^sub>0 \<star> w] (\<a>[k\<^sup> \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w))"
	+ using \<chi>_def assms 0 k.antipar cospan \<chi> by blast
	+ thus ?thesis
	+ using assms 0 k.antipar cospan whisker_left by auto
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
	+ ((k.\<epsilon> \<star> (h \<star> p\<^sub>0)) \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>*, h \<star> p\<^sub>0, w] \<cdot>
	+ ((k \<star> k\<^sup>) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot> \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0 \<star> w] \<cdot>
	+ (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w]) \<cdot> (k \<star> \<a>[k\<^sup> \<star> h, p\<^sub>0, w]) \<cdot>
	+ \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w]) \<cdot> ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
	+ proof -
	+ have "k \<star> tab \<star> w = \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> (k \<star> tab \<star> w)"
	+ proof -
	+ have "\<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> (k \<star> tab \<star> w) =
	+ (\<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w]) \<cdot> (k \<star> tab \<star> w)"
	+ using comp_assoc by simp
	+ also have "... = (k \<star> ((k\<^sup>* \<star> h) \<star> p\<^sub>0) \<star> w) \<cdot> (k \<star> tab \<star> w)"
	+ using assms k.antipar 0 comp_assoc_assoc' by simp
	+ also have "... = k \<star> tab \<star> w"
	+ using assms k.antipar 0 comp_cod_arr
	+ by (simp add: hseqI')
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
	+ using assms 0 k.antipar cospan assoc'_naturality [of k tab w] by simp
	+ finally have "k \<star> tab \<star> w = \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] \<cdot> ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<l>[h \<star> p\<^sub>0] \<star> w) \<cdot>
	+ ((k.\<epsilon> \<star> h \<star> p\<^sub>0) \<star> w) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>, h, p\<^sub>0]) \<star> w) \<cdot>
	+ ((k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>, h \<star> p\<^sub>0, w] \<cdot> ((k \<star> k\<^sup>) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0 \<star> w] \<cdot> (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w]) \<cdot>
	+ (k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot> \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] =
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>, h, p\<^sub>0]) \<star> w"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[k \<star> k\<^sup>, h \<star> p\<^sub>0, w] \<cdot> ((k \<star> k\<^sup>) \<star> \<a>\<^sup>-\<^sup>1[h, p\<^sub>0, w]) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0 \<star> w] \<cdot> (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w]) \<cdot>
	+ (k \<star> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w]) \<cdot> \<a>[k, (k\<^sup>* \<star> h) \<star> p\<^sub>0, w] =
	+ \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^sup>\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> ((\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^sup>\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle>, \<^bold>\<langle>k\<^sup>\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^sup>\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^sup>\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle>, (\<^bold>\<langle>k\<^sup>\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using assms 0 k.antipar cospan \<alpha>_def \<a>'_def by simp
	+ also have "... = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>k\<^bold>\<rangle>, \<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<langle>k\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>k\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<rbrace>"
	+ using assms 0 k.antipar cospan
	+ by (intro E.eval_eqI, simp_all)
	+ also have "... = \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>, h, p\<^sub>0]) \<star> w"
	+ using assms 0 k.antipar cospan \<alpha>_def \<a>'_def by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>[h, p\<^sub>0, w] \<cdot>
	+ (\<l>[h \<star> p\<^sub>0] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>, h \<star> p\<^sub>0] \<cdot> (k \<star> \<a>[k\<^sup>, h, p\<^sub>0]) \<cdot>
	+ (k \<star> tab) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
	+ using assms 0 k.antipar cospan comp_assoc hseqI' whisker_right by auto
	+ also have "... = \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
	+ unfolding \<phi>_def k.trnl\<^sub>\<epsilon>_def
	+ using assms 0 k.antipar cospan comp_assoc whisker_left by simp
	+ finally have "\<l>[h \<star> p\<^sub>0 \<star> w] \<cdot> (k.\<epsilon> \<star> h \<star> p\<^sub>0 \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, k\<^sup>*, h \<star> p\<^sub>0 \<star> w] \<cdot>
	+ (k \<star> \<a>[k\<^sup>, h, p\<^sub>0 \<star> w] \<cdot> \<a>[k\<^sup> \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)) =
	+ \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
	+ by blast
	+ thus ?thesis
	+ using \<chi>_def comp_assoc by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ text \<open>
	+ \<open>BS3\<close> implies that \<open>\<phi>\<close> is the unique 2-cell from \<open>k \<star> p\<^sub>1\<close> to \<open>h \<star> p\<^sub>0\<close> and is an isomorphism.
	+ \<close>
	+
	+ lemma \<phi>_uniqueness:
	+ shows "\<And>\<mu>. \<guillemotleft>\<mu> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright> \<Longrightarrow> \<mu> = \<phi>" and "iso \<phi>"
	+ proof -
	+ have 2: "is_left_adjoint (k \<star> p\<^sub>1)"
	+ using k.antipar cospan left_adjoints_compose by (simp add: k_is_map)
	+ have 3: "is_left_adjoint (h \<star> p\<^sub>0)"
	+ using k.antipar cospan left_adjoints_compose by (simp add: h_is_map)
	+ show "\<And>\<mu>. \<guillemotleft>\<mu> : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright> \<Longrightarrow> \<mu> = \<phi>"
	+ using \<phi>_in_hom 2 3 BS3 by simp
	+ show "iso \<phi>"
	+ using \<phi>_in_hom 2 3 BS3 by simp
	+ qed
	+
	+ text \<open>
	+ As a consequence, the chosen tabulation of \<open>k\<^sup>* \<star> h\<close> is the unique 2-cell from
	+ \<open>p\<^sub>1\<close> to \<open>(k\<^sup>* \<star> h) \<star> p\<^sub>0\<close>, and therefore if we are given any such 2-cell we may
	+ conclude it yields a tabulation of \<open>k\<^sup>* \<star> h\<close>.
	+ \<close>
	+
	+ lemma tab_uniqueness:
	+ assumes "\<guillemotleft>\<tau> : p\<^sub>1 \<Rightarrow> (k\<^sup>* \<star> h) \<star> p\<^sub>0\<guillemotright>"
	+ shows "\<tau> = tab"
	+ proof -
	+ have "\<guillemotleft>k.trnl\<^sub>\<epsilon> (h \<star> p\<^sub>0) (\<a>[k\<^sup>*, h, p\<^sub>0] \<cdot> \<tau>) : k \<star> p\<^sub>1 \<Rightarrow> h \<star> p\<^sub>0\<guillemotright>"
	+ using assms k.antipar cospan k.adjoint_transpose_left(2) [of "h \<star> p\<^sub>0" "p\<^sub>1"]
	+ assoc_in_hom
	+ by auto
	+ hence "tab = \<a>\<^sup>-\<^sup>1[k\<^sup>, h, p\<^sub>0] \<cdot> k.trnl\<^sub>\<eta> p\<^sub>1 (k.trnl\<^sub>\<epsilon> (h \<star> p\<^sub>0) (\<a>[k\<^sup>, h, p\<^sub>0] \<cdot> \<tau>))"
	+ using transpose_\<phi> \<phi>_uniqueness(1) by auto
	+ also have "... = \<a>\<^sup>-\<^sup>1[k\<^sup>, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>, h, p\<^sub>0] \<cdot> \<tau>"
	+ using assms k.antipar cospan k.adjoint_transpose_left(4) assoc_in_hom by simp
	+ also have "... = (\<a>\<^sup>-\<^sup>1[k\<^sup>, h, p\<^sub>0] \<cdot> \<a>[k\<^sup>, h, p\<^sub>0]) \<cdot> \<tau>"
	+ using comp_assoc by simp
	+ also have "... = \<tau>"
	+ using assms k.antipar cospan comp_cod_arr comp_assoc_assoc' by auto
	+ finally show ?thesis by simp
	+ qed
	+
	+ text \<open>
	+ The following lemma reformulates the biuniversal property of the canonical tabulation
	+ of \<open>k\<^sup>* \<star> h\<close> as a biuniversal property of \<open>\<phi>\<close>, regarded as a square that commutes up to
	+ isomorphism.
	+ \<close>
	+
	+ lemma \<phi>_biuniversal_prop:
	+ assumes "ide u" and "ide v"
	+ shows "\<And>\<mu>. \<guillemotleft>\<mu> : k \<star> v \<Rightarrow> h \<star> u\<guillemotright> \<Longrightarrow>
	+ \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
	+ and "\<And>w w' \<theta> \<theta>' \<beta>.
	+ \<lbrakk> ide w; ide w';
	+ \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>;
	+ \<guillemotleft>\<beta> : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>;
	+ (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] =
	+ (h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> \<beta>) \<rbrakk>
	+ \<Longrightarrow> \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<theta> = \<theta>' \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<beta>"
	+ proof -
	+ fix \<mu>
	+ assume \<mu>: "\<guillemotleft>\<mu> : k \<star> v \<Rightarrow> h \<star> u\<guillemotright>"
	+ have 1: "src h = trg u"
	+ using assms \<mu> ide_cod
	+ by (metis ide_def in_homE seq_if_composable)
	+ have 2: "src k = trg v"
	+ using assms \<mu> ide_dom
	+ by (metis ideD(1) in_homE not_arr_null seq_if_composable)
	+ let ?\<omega> = "\<a>\<^sup>-\<^sup>1[k\<^sup>*, h, u] \<cdot> k.trnl\<^sub>\<eta> v \<mu>"
	+ have \<omega>: "\<guillemotleft>?\<omega> : v \<Rightarrow> (k\<^sup>* \<star> h) \<star> u\<guillemotright>"
	+ using assms \<mu> 1 2 k.antipar cospan k.adjoint_transpose_left(1) [of "h \<star> u" v]
	+ assoc_in_hom
	+ by auto
	+ obtain w \<theta> \<nu>
	+ where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ ((k\<^sup>* \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu> = ?\<omega>"
	+ using assms \<omega> T1 [of u ?\<omega>] comp_assoc by (metis in_homE)
	+ have 0: "src p\<^sub>0 = trg w"
	+ using w\<theta>\<nu> ide_dom
	+ by (metis hseqE ideD(1) in_homE)
	+ have "\<mu> = k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>, h, u] \<cdot> ((k\<^sup> \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>)"
	+ proof -
	+ have "\<mu> = k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ?\<omega>)"
	+ proof -
	+ have "k.trnl\<^sub>\<epsilon> (h \<star> u) (\<a>[k\<^sup>*, h, u] \<cdot> ?\<omega>) =
	+ k.trnl\<^sub>\<epsilon> (h \<star> u) ((\<a>[k\<^sup>, h, u] \<cdot> \<a>\<^sup>-\<^sup>1[k\<^sup>, h, u]) \<cdot> k.trnl\<^sub>\<eta> v \<mu>)"
	+ using comp_assoc by simp
	+ also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) (k.trnl\<^sub>\<eta> v \<mu>)"
	+ proof -
	+ have "(\<a>[k\<^sup>, h, u] \<cdot> \<a>\<^sup>-\<^sup>1[k\<^sup>, h, u]) \<cdot> k.trnl\<^sub>\<eta> v \<mu> = (k\<^sup>* \<star> h \<star> u) \<cdot> k.trnl\<^sub>\<eta> v \<mu>"
	+ using comp_assoc_assoc'
	+ by (simp add: "1" assms(1) cospan k.antipar(2))
	+ also have "... = k.trnl\<^sub>\<eta> v \<mu>"
	+ using "1" \<omega> assms(1) comp_ide_arr cospan k.antipar(2) by fastforce
	+ finally show ?thesis
	+ by simp
	+ qed
	+ also have "... = \<mu>"
	+ using assms \<mu> k.antipar cospan 1 2 k.adjoint_transpose_left(3) by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis using w\<theta>\<nu> by simp
	+ qed
	+ also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>)"
	+ using assms k.antipar cospan w\<theta>\<nu> transpose_triangle [of w \<theta> u \<nu>] by auto
	+ finally have "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
	+ by simp
	+ thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and>
	+ \<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
	+ using w\<theta>\<nu> by blast
	+ next
	+ fix w w' \<theta> \<theta>' \<beta>
	+ assume w: "ide w"
	+ assume w': "ide w'"
	+ assume \<theta>: "\<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>"
	+ assume \<theta>': "\<guillemotleft>\<theta>' : p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>"
	+ assume \<beta>: "\<guillemotleft>\<beta> : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>"
	+ assume eq: "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] =
	+ (h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> \<beta>)"
	+ have 0: "src p\<^sub>0 = trg w"
	+ using \<theta> ide_dom
	+ by (metis ideD(1) in_homE not_arr_null seq_if_composable)
	+ interpret uw\<theta>w'\<theta>': uw\<theta>w'\<theta>' V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close>
	+ u w \<theta> w' \<theta>'
	+ using w \<theta> w' \<theta>' apply (unfold_locales) by auto
	+ show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<theta> = \<theta>' \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<beta>"
	+ proof -
	+ let ?LHS = "\<a>[k\<^sup>, h, u] \<cdot> ((k\<^sup> \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w)"
	+ let ?RHS = "\<a>[k\<^sup>, h, u] \<cdot> ((k\<^sup> \<star> h) \<star> \<theta>') \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w'] \<cdot> (tab \<star> w') \<cdot> \<beta>"
	+ have eq': "?LHS = ?RHS"
	+ proof -
	+ have "k.trnl\<^sub>\<epsilon> (h \<star> u) ?LHS =
	+ k.trnl\<^sub>\<epsilon> (h \<star> u)
	+ (\<a>[k\<^sup>, h, u] \<cdot> ((k\<^sup> \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> (p\<^sub>1 \<star> w))"
	+ using assms 0 w \<theta> \<beta> k.antipar cospan comp_arr_dom
	+ by (metis tab_simps(1) tab_simps(4) whisker_right)
	+ also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> p\<^sub>1 \<star> w)"
	+ using assms w \<theta> \<beta> transpose_triangle
	+ by (metis arr_dom ide_hcomp ide_in_hom(2) in_homE ide_leg1 not_arr_null
	+ seq_if_composable)
	+ also have "... = (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
	+ using assms 0 w k.antipar cospan comp_arr_dom by simp
	+ also have "... = (h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> \<beta>)"
	+ using eq by blast
	+ also have "... = k.trnl\<^sub>\<epsilon> (h \<star> u) ?RHS"
	+ using assms w' \<theta>' \<beta> transpose_triangle by simp
	+ finally have 4: "k.trnl\<^sub>\<epsilon> (h \<star> u) ?LHS = k.trnl\<^sub>\<epsilon> (h \<star> u) ?RHS"
	+ by simp
	+ have "src k = trg (p\<^sub>1 \<star> w)"
	+ using assms 0 w k.antipar cospan by simp
	+ moreover have "src k\<^sup>* = trg (h \<star> u)"
	+ using assms 0 w k.antipar cospan by simp
	+ moreover have "ide (h \<star> u)"
	+ using assms 0 w k.antipar cospan by simp
	+ moreover have "ide (p\<^sub>1 \<star> w)"
	+ using assms 0 w k.antipar cospan by simp
	+ ultimately have "inj_on (k.trnl\<^sub>\<epsilon> (h \<star> u)) (hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u))"
	+ using assms 0 w w' k.antipar cospan k.adjoint_transpose_left(6) bij_betw_imp_inj_on
	+ by blast
	+ moreover have "?LHS \<in> hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u)"
	+ proof -
	+ have "\<guillemotleft>\<a>[k\<^sup>, h, u] \<cdot> ((k\<^sup> \<star> h) \<star> \<theta>) \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w] \<cdot> (tab \<star> w) :
	+ p\<^sub>1 \<star> w \<Rightarrow> k\<^sup>* \<star> h \<star> u\<guillemotright>"
	+ using k.antipar cospan
	+ apply (intro comp_in_homI)
	+ apply auto
	+ by auto
	+ thus ?thesis by simp
	+ qed
	+ moreover have "?RHS \<in> hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u)"
	+ proof -
	+ have "\<guillemotleft>\<a>[k\<^sup>, h, u] \<cdot> ((k\<^sup> \<star> h) \<star> \<theta>') \<cdot> \<a>[k\<^sup>* \<star> h, p\<^sub>0, w'] \<cdot>
	+ (tab \<star> w') \<cdot> \<beta> : p\<^sub>1 \<star> w \<Rightarrow> k\<^sup>* \<star> h \<star> u\<guillemotright>"
	+ using \<beta> k.antipar cospan
	+ apply (intro comp_in_homI)
	+ apply auto
	+ by auto
	+ thus ?thesis by blast
	+ qed
	+ ultimately show "?LHS = ?RHS"
	+ using assms 4 k.antipar cospan bij_betw_imp_inj_on
	+ inj_on_def [of "k.trnl\<^sub>\<epsilon> (h \<star> u)" "hom (p\<^sub>1 \<star> w) (k\<^sup>* \<star> h \<star> u)"]
	+ by simp
	+ qed
	+ moreover have "seq \<a>[k\<^sup>*, h, u] (composite_cell w \<theta>)"
	+ using assms k.antipar cospan tab_in_hom hseqI'
	+ apply (intro seqI hseqI) by auto
	+ moreover have "seq \<a>[k\<^sup>*, h, u] (composite_cell w' \<theta>' \<cdot> \<beta>)"
	+ using assms \<beta> k.antipar cospan tab_in_hom hseqI'
	+ apply (intro seqI hseqI) by auto
	+ ultimately have "composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta>"
	+ using assms 0 w w' \<beta> k.antipar cospan iso_assoc iso_is_section section_is_mono
	+ monoE [of "\<a>[k\<^sup>*, h, u]" "composite_cell w \<theta>" "composite_cell w' \<theta>' \<cdot> \<beta>"]
	+ comp_assoc
	+ by simp
	+ thus ?thesis
	+ using w w' \<theta> \<theta>' \<beta> eq' T2 [of w w' \<theta> u \<theta>' \<beta>] by metis
	+ qed
	+ qed
	+
	+ text \<open>
	+ Using the uniqueness properties established for \<open>\<phi>\<close>, we obtain yet another reformulation
	+ of the biuniversal property associated with the chosen tabulation of \<open>k\<^sup>* \<star> h\<close>,
	+ this time as a kind of pseudo-pullback. We will use this to show that the
	+ category of isomorphism classes of maps has pullbacks.
	+ \<close>
	+
	+ lemma has_pseudo_pullback:
	+ assumes "is_left_adjoint u" and "is_left_adjoint v" and "isomorphic (k \<star> v) (h \<star> u)"
	+ shows "\<exists>w. is_left_adjoint w \<and> isomorphic (p\<^sub>0 \<star> w) u \<and> isomorphic v (p\<^sub>1 \<star> w)"
	+ and "\<And>w w'. \<lbrakk> is_left_adjoint w; is_left_adjoint w';
	+ p\<^sub>0 \<star> w \<cong> u; v \<cong> p\<^sub>1 \<star> w; p\<^sub>0 \<star> w' \<cong> u; v \<cong> p\<^sub>1 \<star> w' \<rbrakk> \<Longrightarrow> w \<cong> w'"
	+ proof -
	+ interpret u: map_in_bicategory V H \<a> \<i> src trg u
	+ using assms(1) by (unfold_locales, auto)
	+ interpret v: map_in_bicategory V H \<a> \<i> src trg v
	+ using assms(2) by (unfold_locales, auto)
	+ obtain \<mu> where \<mu>: "\<guillemotleft>\<mu> : k \<star> v \<Rightarrow> h \<star> u\<guillemotright> \<and> iso \<mu>"
	+ using assms(3) by auto
	+ obtain w \<theta> \<nu> where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright> \<and>
	+ \<guillemotleft>\<nu> : v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ (h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] \<cdot> (k \<star> \<nu>) = \<mu>"
	+ using assms \<mu> \<phi>_biuniversal_prop(1) [of u v \<mu>] by auto
	+ have "is_left_adjoint w \<and> isomorphic (p\<^sub>0 \<star> w) u \<and> isomorphic v (p\<^sub>1 \<star> w)"
	+ proof (intro conjI)
	+ show 1: "is_left_adjoint w"
	+ using assms(2) w\<theta>\<nu> left_adjoint_preserved_by_iso' isomorphic_def BS4 leg1_is_map
	+ by blast
	+ show "v \<cong> p\<^sub>1 \<star> w"
	+ using w\<theta>\<nu> isomorphic_def by blast
	+ show "p\<^sub>0 \<star> w \<cong> u"
	+ proof -
	+ have "src p\<^sub>0 = trg w"
	+ using w\<theta>\<nu> ide_dom
	+ by (metis ideD(1) in_homE not_arr_null seq_if_composable)
	+ hence "is_left_adjoint (p\<^sub>0 \<star> w)"
	+ using 1 left_adjoints_compose by simp
	+ thus ?thesis
	+ using assms w\<theta>\<nu> 1 BS3 isomorphic_def by metis
	+ qed
	+ qed
	+ thus "\<exists>w. is_left_adjoint w \<and> p\<^sub>0 \<star> w \<cong> u \<and> v \<cong> p\<^sub>1 \<star> w"
	+ by blast
	+ show "\<And>w w'. \<lbrakk> is_left_adjoint w; is_left_adjoint w';
	+ p\<^sub>0 \<star> w \<cong> u; v \<cong> p\<^sub>1 \<star> w; p\<^sub>0 \<star> w' \<cong> u; v \<cong> p\<^sub>1 \<star> w' \<rbrakk> \<Longrightarrow> w \<cong> w'"
	+ proof -
	+ fix w w'
	+ assume w: "is_left_adjoint w" and w': "is_left_adjoint w'"
	+ assume 1: "p\<^sub>0 \<star> w \<cong> u"
	+ assume 2: "v \<cong> p\<^sub>1 \<star> w"
	+ assume 3: "p\<^sub>0 \<star> w' \<cong> u"
	+ assume 4: "v \<cong> p\<^sub>1 \<star> w'"
	+ obtain \<theta> where \<theta>: "\<guillemotleft>\<theta> : p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>"
	+ using 1 by auto
	+ obtain \<theta>' where \<theta>': "\<guillemotleft>\<theta>' : p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>"
	+ using 3 by auto
	+ obtain \<nu> where \<nu>: "\<guillemotleft>\<nu>: v \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>"
	+ using 2 by blast
	+ obtain \<nu>' where \<nu>': "\<guillemotleft>\<nu>': v \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>'"
	+ using 4 by blast
	+ let ?\<beta> = "\<nu>' \<cdot> inv \<nu>"
	+ have \<beta>: "\<guillemotleft>?\<beta> : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>"
	+ using \<nu> \<nu>' by (elim conjE in_homE, auto)
	+ interpret uw\<theta>: uw\<theta> V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close> u w \<theta>
	+ using w \<theta> left_adjoint_is_ide
	+ by (unfold_locales, auto)
	+ interpret uw'\<theta>': uw\<theta> V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close>
	+ u w' \<theta>'
	+ using w' \<theta>' left_adjoint_is_ide
	+ by (unfold_locales, auto)
	+ interpret uw\<theta>w'\<theta>': uw\<theta>w'\<theta>' V H \<a> \<i> src trg \<open>k\<^sup>* \<star> h\<close> tab \<open>p\<^sub>0\<close> \<open>p\<^sub>1\<close> u w \<theta> w' \<theta>'
	+ using w w' \<theta> \<theta>' left_adjoint_is_ide by unfold_locales
	+ have "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w] =
	+ (h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot>
	+ (k \<star> ?\<beta>)"
	+ proof -
	+ let ?LHS = "(h \<star> \<theta>) \<cdot> \<a>[h, p\<^sub>0, w] \<cdot> (\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w]"
	+ let ?RHS = "(h \<star> \<theta>') \<cdot> \<a>[h, p\<^sub>0, w'] \<cdot> (\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[k, p\<^sub>1, w'] \<cdot> (k \<star> ?\<beta>)"
	+ have "\<guillemotleft>?LHS : k \<star> p\<^sub>1 \<star> w \<Rightarrow> h \<star> u\<guillemotright>"
	+ using w k.antipar by fastforce
	+ moreover have "\<guillemotleft>?RHS : k \<star> p\<^sub>1 \<star> w \<Rightarrow> h \<star> u\<guillemotright>"
	+ using w k.antipar \<beta> by fastforce
	+ moreover have "is_left_adjoint (k \<star> p\<^sub>1 \<star> w)"
	+ using w k.is_map left_adjoints_compose by simp
	+ moreover have "is_left_adjoint (h \<star> u)"
	+ using assms h.is_map left_adjoints_compose by auto
	+ ultimately show "?LHS = ?RHS"
	+ using BS3 by blast
	+ qed
	+ hence "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<theta> = \<theta>' \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = ?\<beta>"
	+ using assms left_adjoint_is_ide w w' \<theta> \<theta>' \<nu> \<nu>' \<beta>
	+ \<phi>_biuniversal_prop(2) [of u v w w' \<theta> \<theta>' ?\<beta>]
	+ by presburger
	+ thus "w \<cong> w'"
	+ using w w' BS3 isomorphic_def by metis
	+ qed
	+ qed
	+
	+ end
	+
	+ subsubsection "Tabulations in Maps"
	+
	+ text \<open>
	+ Here we focus our attention on the properties of tabulations in a bicategory of spans,
	+ in the special case in which both legs are maps.
	+ \<close>
	+
	+ context tabulation_in_maps
	+ begin
	+
	+ text \<open>
	+ The following are the conditions under which \<open>w\<close> is a 1-cell induced via \<open>T1\<close> by
	+ a 2-cell \<open>\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> s \<star> r\<^sub>0\<guillemotright>\<close>: \<open>w\<close> is an arrow of spans and \<open>\<omega>\<close> is obtained by
	+ composing the tabulation \<open>\<sigma>\<close> with \<open>w\<close> and the isomorphisms that witness \<open>w\<close> being
	+ an arrow of spans.
	+ \<close>
	+
	+ abbreviation is_induced_by_cell
	+ where "is_induced_by_cell w r\<^sub>0 \<omega> \<equiv>
	+ arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<omega>) s\<^sub>0 s\<^sub>1 w \<and>
	+ composite_cell w (arrow_of_spans_of_maps.the_\<theta> V H r\<^sub>0 s\<^sub>0 w) \<cdot>
	+ (arrow_of_spans_of_maps.the_\<nu> V H (dom \<omega>) s\<^sub>1 w) = \<omega>"
	+
	+ lemma induced_map_unique:
	+ assumes "is_induced_by_cell w r\<^sub>0 \<omega>" and "is_induced_by_cell w' r\<^sub>0 \<omega>"
	+ shows "isomorphic w w'"
	+ proof -
	+ interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s\<^sub>0 s\<^sub>1 w
	+ using assms(1) by auto
	+ interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w
	+ ..
	+ interpret w': arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 "dom \<omega>" s\<^sub>0 s\<^sub>1 w'
	+ using assms(2) by auto
	+ interpret w': arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<omega>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w'
	+ ..
	+ let ?\<beta> = "w'.the_\<nu> \<cdot> inv w.the_\<nu>"
	+ have \<beta>: "\<guillemotleft>?\<beta> : s\<^sub>1 \<star> w \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright>"
	+ using w.the_\<nu>_props w'.the_\<nu>_props arr_iff_in_hom by auto
	+ have 1: "composite_cell w w.the_\<theta> = composite_cell w' w'.the_\<theta> \<cdot> (w'.the_\<nu> \<cdot> inv w.the_\<nu>)"
	+ proof -
	+ have "composite_cell w' w'.the_\<theta> \<cdot> (w'.the_\<nu> \<cdot> inv w.the_\<nu>) =
	+ ((composite_cell w' w'.the_\<theta>) \<cdot> w'.the_\<nu>) \<cdot> inv w.the_\<nu>"
	+ using comp_assoc by simp
	+ also have "... = \<omega> \<cdot> inv w.the_\<nu>"
	+ using assms(2) comp_assoc by simp
	+ also have "... = (composite_cell w w.the_\<theta> \<cdot> w.the_\<nu>) \<cdot> inv w.the_\<nu>"
	+ using assms(1) comp_assoc by simp
	+ also have "... = composite_cell w w.the_\<theta> \<cdot> w.the_\<nu> \<cdot> inv w.the_\<nu>"
	+ using comp_assoc by simp
	+ also have "... = composite_cell w w.the_\<theta>"
	+ proof -
	+ have "w.the_\<nu> \<cdot> inv w.the_\<nu> = s\<^sub>1 \<star> w"
	+ using w.the_\<nu>_props comp_arr_inv inv_is_inverse by auto
	+ thus ?thesis
	+ using composite_cell_in_hom w.ide_w w.the_\<theta>_props comp_arr_dom
	+ by (metis composite_cell_in_hom in_homE w.w_in_hom(1))
	+ qed
	+ finally show ?thesis by auto
	+ qed
	+ have "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
	+ using 1 \<beta> w.is_ide w'.is_ide w.the_\<theta>_props w'.the_\<theta>_props
	+ T2 [of w w' w.the_\<theta> r\<^sub>0 w'.the_\<theta> ?\<beta>]
	+ by blast
	+ thus ?thesis
	+ using BS3 w.is_map w'.is_map by blast
	+ qed
	+
	+ text \<open>
	+ The object src \<open>s\<^sub>0\<close> forming the apex of the tabulation satisfies the conditions for
	+ being a map induced via \<open>T1\<close> by the 2-cell \<open>\<sigma>\<close> itself. This is ultimately required
	+ for the map from 2-cells to arrows of spans to be functorial with respect to vertical
	+ composition.
	+ \<close>
	+
	+ lemma apex_is_induced_by_cell:
	+ shows "is_induced_by_cell (src s\<^sub>0) s\<^sub>0 \<sigma>"
	+ proof -
	+ have 1: "arrow_of_spans_of_maps V H \<a> \<i> src trg s\<^sub>0 s\<^sub>1 s\<^sub>0 s\<^sub>1 (src s\<^sub>0)"
	+ using iso_runit [of s\<^sub>0] iso_runit [of s\<^sub>1] tab_in_hom
	+ apply unfold_locales
	+ apply simp
	+ using ide_leg0 isomorphic_def
	+ apply blast
	+ using ide_leg1 isomorphic_def leg1_simps(3) runit'_in_vhom [of s\<^sub>1 "src s\<^sub>0"] iso_runit'
	+ by blast
	+ interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg s\<^sub>0 \<open>dom \<sigma>\<close> s\<^sub>0 s\<^sub>1 \<open>src s\<^sub>0\<close>
	+ using 1 tab_in_hom by simp
	+ interpret w: arrow_of_spans_of_maps_to_tabulation
	+ V H \<a> \<i> src trg s\<^sub>0 \<open>dom \<sigma>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 \<open>src s\<^sub>0\<close>
	+ ..
	+ show "is_induced_by_cell (src s\<^sub>0) s\<^sub>0 \<sigma>"
	+ proof (intro conjI)
	+ show "arrow_of_spans_of_maps V H \<a> \<i> src trg s\<^sub>0 (dom \<sigma>) s\<^sub>0 s\<^sub>1 (src s\<^sub>0)"
	+ using w.arrow_of_spans_of_maps_axioms by simp
	+ show "composite_cell (src s\<^sub>0) w.the_\<theta> \<cdot> w.the_\<nu> = \<sigma>"
	+ proof -
	+ have \<theta>: "w.the_\<theta> = \<r>[s\<^sub>0]"
	+ using iso_runit [of s\<^sub>0] w.leg0_uniquely_isomorphic w.the_\<theta>_props
	+ the1_equality [of "\<lambda>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> src s\<^sub>0 \<Rightarrow> s\<^sub>0\<guillemotright> \<and> iso \<theta>"]
	+ by auto
	+ have \<nu>: "w.the_\<nu> = \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
	+ using iso_runit' w.leg1_uniquely_isomorphic w.the_\<nu>_props leg1_simps(3)
	+ the1_equality [of "\<lambda>\<nu>. \<guillemotleft>\<nu> : s\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> src s\<^sub>0\<guillemotright> \<and> iso \<nu>"] tab_in_vhom'
	+ by auto
	+ have "composite_cell (src s\<^sub>0) \<r>[s\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1] = \<sigma>"
	+ proof -
	+ have "composite_cell (src s\<^sub>0) \<r>[s\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1] =
	+ ((s \<star> \<r>[s\<^sub>0]) \<cdot> \<a>[s, s\<^sub>0, src s\<^sub>0]) \<cdot> (\<sigma> \<star> src s\<^sub>0) \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
	+ using comp_assoc by simp
	+ also have "... = (\<r>[s \<star> s\<^sub>0] \<cdot> (\<sigma> \<star> src s\<^sub>0)) \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
	+ using runit_hcomp comp_assoc by simp
	+ also have "... = \<sigma> \<cdot> \<r>[s\<^sub>1] \<cdot> \<r>\<^sup>-\<^sup>1[s\<^sub>1]"
	+ using runit_naturality tab_in_hom
	+ by (metis tab_simps(1) tab_simps(2) tab_simps(4) tab_simps(5) comp_assoc)
	+ also have "... = \<sigma>"
	+ using iso_runit tab_in_hom comp_arr_dom comp_arr_inv inv_is_inverse by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using \<theta> \<nu> comp_assoc by simp
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ subsubsection "Composing Tabulations"
	+
	+ text \<open>
	+ Given tabulations \<open>(r\<^sub>0, \<rho>, r\<^sub>1)\<close> of \<open>r\<close> and \<open>(s\<^sub>0, \<sigma>, s\<^sub>1)\<close> of \<open>s\<close> in a bicategory of spans,
	+ where \<open>(r\<^sub>0, r\<^sub>1)\<close> and \<open>(s\<^sub>0, s\<^sub>1)\<close> are spans of maps and 1-cells \<open>r\<close> and \<open>s\<close> are composable,
	+ we can construct a 2-cell that yields a tabulation of \<open>r \<star> s\<close>.
	+ The proof uses the fact that the 2-cell \<open>\<phi>\<close> associated with the cospan \<open>(r\<^sub>0, s\<^sub>1)\<close>
	+ is an isomorphism, which we have proved above
	+ (\<open>cospan_of_maps_in_bicategory_of_spans.\<phi>_uniqueness\<close>) using \<open>BS3\<close>.
	+ However, this is the only use of \<open>BS3\<close> in the proof, and it seems plausible that it would be
	+ possible to establish that \<open>\<phi>\<close> is an isomorphism in more general situations in which the
	+ subbicategory of maps is not locally essentially discrete. Alternatively, more general
	+ situations could be treated by adding the assertion that \<open>\<phi>\<close> is an isomorphism as part of
	+ a weakening of \<open>BS3\<close>.
	+ \<close>
	+
	+ locale composite_tabulation_in_maps =
	+ bicategory_of_spans V H \<a> \<i> src trg +
	+ \<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
	+ \<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and r :: 'a
	+ and \<rho> :: 'a
	+ and r\<^sub>0 :: 'a
	+ and r\<^sub>1 :: 'a
	+ and s :: 'a
	+ and \<sigma> :: 'a
	+ and s\<^sub>0 :: 'a
	+ and s\<^sub>1 :: 'a +
	+ assumes composable: "src r = trg s"
	+ begin
	+
	+ text \<open>
	+ Interpret \<open>(r\<^sub>0, s\<^sub>1)\<close> as a @{locale cospan_of_maps_in_bicategory_of_spans},
	+ to obtain the isomorphism \<open>\<phi>\<close> in the central diamond, along with the assertion
	+ that it is unique.
	+ \<close>
	+ interpretation r\<^sub>0s\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg s\<^sub>1 r\<^sub>0
	+ using \<rho>.leg0_is_map \<sigma>.leg1_is_map composable by (unfold_locales, auto)
	+
	+ text \<open>
	+ We need access to simps, etc. in the preceding interpretation, yet trying to declare
	+ it as a sublocale introduces too many conflicts at the moment.
	+ As it confusing elsewhere to figure out exactly how, in other contexts, to express
	+ the particular interpretation that is needed, to make things easier we include the
	+ following lemma. Then we can just recall the lemma to find out how to express
	+ the interpretation required in a given context.
	+ \<close>
	+
	+ lemma r\<^sub>0s\<^sub>1_is_cospan:
	+ shows "cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg s\<^sub>1 r\<^sub>0"
	+ ..
	+
	+ text \<open>
	+ The following define the projections associated with the natural tabulation of \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close>.
	+ \<close>
	+
	+ abbreviation p\<^sub>0
	+ where "p\<^sub>0 \<equiv> r\<^sub>0s\<^sub>1.p\<^sub>0"
	+
	+ abbreviation p\<^sub>1
	+ where "p\<^sub>1 \<equiv> r\<^sub>0s\<^sub>1.p\<^sub>1"
	+
	+ text \<open>
	+$$
	+\xymatrix{
	+ && {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
	+ {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
	+}
	+$$
	+ \<close>
	+
	+ text \<open>
	+ Next, we define the 2-cell that is the composite of the tabulation \<open>\<sigma>\<close>, the tabulation \<open>\<rho>\<close>,
	+ and the central diamond that commutes up to unique isomorphism \<open>\<phi>\<close>.
	+ \<close>
	+
	+ definition tab
	+ where "tab \<equiv> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot>
	+ (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1)"
	+
	+ lemma tab_in_hom [intro]:
	+ shows "\<guillemotleft>tab : r\<^sub>1 \<star> p\<^sub>1 \<Rightarrow> (r \<star> s) \<star> s\<^sub>0 \<star> p\<^sub>0\<guillemotright>"
	+ using \<rho>.T0.antipar(1) r\<^sub>0s\<^sub>1.\<phi>_in_hom composable \<rho>.leg0_in_hom(1) \<sigma>.leg1_in_hom(1)
	+ hseqI' composable
	+ by (unfold tab_def, intro comp_in_homI, auto)
	+
	+ interpretation tabulation_data V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close>
	+ using composable tab_in_hom
	+ by (unfold_locales, auto)
	+
	+ text \<open>
	+ In the subsequent proof we will use coherence to shortcut a few of the calculations.
	+ \<close>
	+ interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ text \<open>
	+ The following is applied twice in the proof of property \<open>T2\<close> for the composite
	+ tabulation. It's too long to repeat.
	+ \<close>
	+
	+ lemma technical:
	+ assumes "ide w"
	+ and "\<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>"
	+ and "w\<^sub>r = p\<^sub>1 \<star> w"
	+ and "\<theta>\<^sub>r = (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
	+ (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ shows "\<rho>.composite_cell w\<^sub>r \<theta>\<^sub>r = \<a>[r, s, u] \<cdot> composite_cell w \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ text \<open>
	+$$
	+\xymatrix{
	+ && X \ar[d]^{w} \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta}} \\
	+ && {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
	+ {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
	+}
	+$$
	+ \<close>
	+ proof -
	+ interpret uw\<theta>: uw\<theta> V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close> u w \<theta>
	+ using assms(1-2) composable
	+ by (unfold_locales, auto)
	+ show ?thesis
	+ proof -
	+ have "\<a>[r, s, u] \<cdot> composite_cell w \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] =
	+ (\<a>[r, s, u] \<cdot> ((r \<star> s) \<star> \<theta>)) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using comp_assoc by simp
	+ also have "... = (r \<star> s \<star> \<theta>) \<cdot> \<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
	+ (tab \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using assoc_naturality [of r s \<theta>] composable comp_assoc by simp
	+ also have "... = (r \<star> s \<star> \<theta>) \<cdot> \<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot>
	+ \<rho>.composite_cell p\<^sub>1 r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ unfolding tab_def
	+ using comp_assoc by simp
	+ also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
	+ ((r \<star> \<sigma> \<star> p\<^sub>0) \<cdot> \<rho>.composite_cell p\<^sub>1 r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using composable \<rho>.T0.antipar(1) hseqI' comp_assoc whisker_right by auto
	+ also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
	+ ((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot>
	+ (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using composable \<rho>.T0.antipar(1) whisker_right tab_def tab_in_hom(2)
	+ composable hseqI' comp_assoc
	+ by force
	+ also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
	+ ((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot>
	+ ((\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]) \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
	+ using assoc'_naturality [of \<rho> p\<^sub>1 w] \<rho>.T0.antipar(1) r\<^sub>0s\<^sub>1.base_simps(2) comp_assoc
	+ by auto
	+ also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
	+ ((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w]) \<cdot> \<rho>.composite_cell (p\<^sub>1 \<star> w) \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ proof -
	+ have "(\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] =
	+ \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"
	+ proof -
	+ have "(\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) =
	+ \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1 \<star> w]"
	+ using pentagon' \<rho>.T0.antipar(1) comp_assoc by simp
	+ moreover have 1: "seq (\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w)(\<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]))"
	+ using \<rho>.T0.antipar(1)
	+ by (intro seqI hseqI, auto simp add: hseqI')
	+ ultimately
	+ have "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] =
	+ ((\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])) \<cdot>
	+ \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"
	+ using \<rho>.T0.antipar(1) iso_inv_iso iso_assoc inv_inv
	+ invert_side_of_triangle(2)
	+ [of "(\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])"
	+ "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]" "\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1 \<star> w]"]
	+ by fastforce
	+ hence "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] =
	+ (\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot>
	+ \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"
	+ using comp_assoc by simp
	+ moreover have "seq (inv (\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w)) \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]"
	+ using \<rho>.T0.antipar(1) iso_inv_iso 1 hseqI'
	+ by (intro seqI hseqI, auto)
	+ ultimately show ?thesis
	+ using \<rho>.T0.antipar(1) iso_inv_iso iso_assoc inv_inv inv_hcomp
	+ invert_side_of_triangle(1)
	+ [of "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]" "\<a>\<^sup>-\<^sup>1[r, r\<^sub>0, p\<^sub>1] \<star> w"
	+ "\<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]"]
	+ by fastforce
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (r \<star> s \<star> \<theta>) \<cdot> ((\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w))) \<cdot>
	+ (((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, s\<^sub>1 \<star> p\<^sub>0, w]) \<cdot>
	+ (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<rho>.composite_cell (p\<^sub>1 \<star> w) \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ proof -
	+ have "((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, r\<^sub>0 \<star> p\<^sub>1, w] = \<a>\<^sup>-\<^sup>1[r, s\<^sub>1 \<star> p\<^sub>0, w] \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
	+ using assoc'_naturality [of r r\<^sub>0s\<^sub>1.\<phi> w] r\<^sub>0s\<^sub>1.cospan by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (r \<star> s \<star> \<theta>) \<cdot>
	+ (\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w]) \<cdot>
	+ (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<rho>.composite_cell (p\<^sub>1 \<star> w) \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ proof -
	+ have "((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, s\<^sub>1 \<star> p\<^sub>0, w] =
	+ \<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w)"
	+ using assoc'_naturality [of r "\<sigma> \<star> p\<^sub>0" w]
	+ by (simp add: composable hseqI')
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (r \<star> s \<star> \<theta>) \<cdot>
	+ (r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
	+ ((r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])) \<cdot>
	+ \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
	+ proof -
	+ have "\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] =
	+ r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]"
	+ proof -
	+ have "\<a>[r, s, (s\<^sub>0 \<star> p\<^sub>0) \<star> w] \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] =
	+ \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, (\<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, (\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using \<alpha>_def \<a>'_def composable by simp
	+ also have "... = \<lbrace>\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using composable
	+ by (intro E.eval_eqI, simp_all)
	+ also have "... = r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]"
	+ using \<alpha>_def \<a>'_def composable by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (r \<star> s \<star> \<theta>) \<cdot>
	+ (r \<star> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
	+ \<rho>.composite_cell (p\<^sub>1 \<star> w)
	+ (((\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])"
	+ using assms(3) arrI \<rho>.T0.antipar(1) hseqI' whisker_left by auto
	+ also have "... = (r \<star> (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
	+ (\<a>[s \<star> s\<^sub>0, p\<^sub>0, w] \<cdot> ((\<sigma> \<star> p\<^sub>0) \<star> w)) \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot>
	+ \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
	+ using \<rho>.T0.antipar(1) hseqI' comp_assoc whisker_left by auto
	+ also have "... = (r \<star> (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
	+ (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot>
	+ \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w)"
	+ using assoc_naturality [of \<sigma> p\<^sub>0 w] comp_assoc by simp
	+ finally show ?thesis
	+ using assms(3-4) by simp
	+ qed
	+ qed
	+
	+ lemma composite_is_tabulation:
	+ shows "tabulation V H \<a> \<i> src trg (r \<star> s) tab (s\<^sub>0 \<star> p\<^sub>0) (r\<^sub>1 \<star> p\<^sub>1)"
	+ proof
	+ show "\<And>u \<omega>. \<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> (r \<star> s) \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
	+ \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright> \<and>
	+ \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
	+ proof -
	+ fix u \<omega>
	+ assume u: "ide u"
	+ assume \<omega>: "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> (r \<star> s) \<star> u\<guillemotright>"
	+ let ?v = "dom \<omega>"
	+ have 1: "\<guillemotleft>\<a>[r, s, u] \<cdot> \<omega> : ?v \<Rightarrow> r \<star> s \<star> u\<guillemotright>"
	+ proof -
	+ (*
	+ * TODO: I think this highlights the current issue with assoc_in_hom:
	+ * it can't be applied automatically here because there isn't any way to
	+ * obtain the equations src r = trg s and src s = trg u from assumption \<omega>.
	+ * Maybe this can be improved with a little bit of thought, but not while
	+ * a lot of other stuff is being changed, too.
	+ *)
	+ have "src r = trg s \<and> src s = trg u"
	+ by (metis \<omega> arr_cod hseq_char in_homE hcomp_simps(1))
	+ thus ?thesis
	+ using u \<omega> hseqI'
	+ by (intro comp_in_homI, auto)
	+ qed
	+
	+ obtain w\<^sub>r \<theta>\<^sub>r \<nu>\<^sub>r
	+ where w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r: "ide w\<^sub>r \<and> \<guillemotleft>\<theta>\<^sub>r : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s \<star> u\<guillemotright> \<and>
	+ \<guillemotleft>\<nu>\<^sub>r : ?v \<Rightarrow> r\<^sub>1 \<star> w\<^sub>r\<guillemotright> \<and> iso \<nu>\<^sub>r \<and>
	+ \<rho>.composite_cell w\<^sub>r \<theta>\<^sub>r \<cdot> \<nu>\<^sub>r = \<a>[r, s, u] \<cdot> \<omega>"
	+ using u \<omega> \<rho>.T1 [of "s \<star> u" "\<a>[r, s, u] \<cdot> \<omega>"]
	+ by (metis 1 \<rho>.ide_base \<sigma>.ide_base arr_cod composable ide_hcomp in_homE
	+ match_1 not_arr_null seq_if_composable)
	+ text \<open>
	+$$
	+\xymatrix{
	+ && X \ar@ {.>}[ddl]^{w_r} \ar@/ul20pt/[dddll]_{v} \xtwocell[dddll]{}\omit{^{<1.5>\nu_r}}
	+ \ar@/ur20pt/[dddrr]^{u} \xtwocell[dddr]{}\omit{^{\theta_r}} \\
	+ && \\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
	+ && \\
	+ {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
	+}
	+$$
	+ \<close>
	+ text \<open>We need some simps, etc., otherwise the subsequent diagram chase is very painful.\<close>
	+ have w\<^sub>r: "ide w\<^sub>r"
	+ using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
	+ have [simp]: "src w\<^sub>r = src u"
	+ using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r
	+ by (metis \<omega> 1 comp_arr_dom in_homE seqE hcomp_simps(1) vseq_implies_hpar(1))
	+ have [simp]: "trg w\<^sub>r = src \<rho>"
	+ using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r
	+ by (metis 1 arrI not_arr_null seqE seq_if_composable)
	+ have \<theta>\<^sub>r_in_hom [intro]: "\<guillemotleft>\<theta>\<^sub>r : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s \<star> u\<guillemotright>"
	+ using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
	+ have \<theta>\<^sub>r_in_hhom [intro]: "\<guillemotleft>\<theta>\<^sub>r : src u \<rightarrow> trg s\<guillemotright>"
	+ using \<theta>\<^sub>r_in_hom src_cod [of \<theta>\<^sub>r] trg_cod [of \<theta>\<^sub>r]
	+ by (metis arr_cod in_hhom_def in_homE hcomp_simps(1-2))
	+ have [simp]: "src \<theta>\<^sub>r = src u" using \<theta>\<^sub>r_in_hhom by auto
	+ have [simp]: "trg \<theta>\<^sub>r = trg s" using \<theta>\<^sub>r_in_hhom by auto
	+ have [simp]: "dom \<theta>\<^sub>r = r\<^sub>0 \<star> w\<^sub>r" using \<theta>\<^sub>r_in_hom by blast
	+ have [simp]: "cod \<theta>\<^sub>r = s \<star> u" using \<theta>\<^sub>r_in_hom by blast
	+ have \<nu>\<^sub>r_in_hom [intro]: "\<guillemotleft>\<nu>\<^sub>r : ?v \<Rightarrow> r\<^sub>1 \<star> w\<^sub>r\<guillemotright>" using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
	+ have \<nu>\<^sub>r_in_hhom [intro]: "\<guillemotleft>\<nu>\<^sub>r : src u \<rightarrow> trg r\<guillemotright>"
	+ using \<nu>\<^sub>r_in_hom src_dom [of \<nu>\<^sub>r] trg_dom [of \<nu>\<^sub>r]
	+ by (metis \<rho>.leg1_simps(4) arr_cod arr_dom_iff_arr cod_trg in_hhomI in_homE
	+ src_cod src_dom src_hcomp' trg.preserves_cod hcomp_simps(2) w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r)
	+ have [simp]: "src \<nu>\<^sub>r = src u" using \<nu>\<^sub>r_in_hhom by auto
	+ have [simp]: "trg \<nu>\<^sub>r = trg r" using \<nu>\<^sub>r_in_hhom by auto
	+ have [simp]: "dom \<nu>\<^sub>r = ?v" using \<nu>\<^sub>r_in_hom by auto
	+ have [simp]: "cod \<nu>\<^sub>r = r\<^sub>1 \<star> w\<^sub>r" using \<nu>\<^sub>r_in_hom by auto
	+ have iso_\<nu>\<^sub>r: "iso \<nu>\<^sub>r" using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by simp
	+
	+ obtain w\<^sub>s \<theta>\<^sub>s \<nu>\<^sub>s
	+ where w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s: "ide w\<^sub>s \<and> \<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> w\<^sub>s \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu>\<^sub>s : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s\<^sub>1 \<star> w\<^sub>s\<guillemotright> \<and> iso \<nu>\<^sub>s \<and>
	+ \<sigma>.composite_cell w\<^sub>s \<theta>\<^sub>s \<cdot> \<nu>\<^sub>s = \<theta>\<^sub>r"
	+ using u w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r \<sigma>.T1 [of u \<theta>\<^sub>r] by auto
	+ text \<open>
	+$$
	+\xymatrix{
	+ && X \ar[ddl]^{w_r} \ar@/ul20pt/[dddll]_{v} \xtwocell[dddll]{}\omit{^{<1.5>\nu_r}}
	+ \ar@/ur20pt/[dddrr]^{u} \ar@ {.>}[ddr]_{w_s} \xtwocell[dddrr]{}\omit{^{<-1.5>\theta_s}}
	+ \xtwocell[ddd]{}\omit{^{<1>\nu_s}} \\
	+ && \\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
	+ {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
	+}
	+$$
	+ \<close>
	+ have w\<^sub>s: "ide w\<^sub>s"
	+ using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
	+ have [simp]: "src w\<^sub>s = src u"
	+ using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s src_cod
	+ by (metis arr_dom in_homE src_dom hcomp_simps(1))
	+ have [simp]: "trg w\<^sub>s = src \<sigma>"
	+ using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s
	+ by (metis \<sigma>.tab_simps(2) arr_dom in_homE not_arr_null seq_if_composable)
	+ have \<theta>\<^sub>s_in_hom [intro]: "\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> w\<^sub>s \<Rightarrow> u\<guillemotright>"
	+ using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
	+ have \<theta>\<^sub>s_in_hhom [intro]: "\<guillemotleft>\<theta>\<^sub>s : src u \<rightarrow> src s\<guillemotright>"
	+ using \<theta>\<^sub>s_in_hom src_cod trg_cod
	+ by (metis \<sigma>.leg0_simps(3) arr_dom in_hhom_def in_homE trg_dom hcomp_simps(2))
	+ have [simp]: "src \<theta>\<^sub>s = src u" using \<theta>\<^sub>s_in_hhom by auto
	+ have [simp]: "trg \<theta>\<^sub>s = src s" using \<theta>\<^sub>s_in_hhom by auto
	+ have [simp]: "dom \<theta>\<^sub>s = s\<^sub>0 \<star> w\<^sub>s" using \<theta>\<^sub>s_in_hom by blast
	+ have [simp]: "cod \<theta>\<^sub>s = u" using \<theta>\<^sub>s_in_hom by blast
	+ have \<nu>\<^sub>s_in_hom [intro]: "\<guillemotleft>\<nu>\<^sub>s : r\<^sub>0 \<star> w\<^sub>r \<Rightarrow> s\<^sub>1 \<star> w\<^sub>s\<guillemotright>" using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
	+ have \<nu>\<^sub>s_in_hhom [intro]: "\<guillemotleft>\<nu>\<^sub>s : src u \<rightarrow> trg s\<guillemotright>"
	+ using \<nu>\<^sub>s_in_hom src_dom trg_cod
	+ by (metis \<open>src \<theta>\<^sub>r = src u\<close> \<open>trg \<theta>\<^sub>r = trg s\<close> \<theta>\<^sub>r_in_hom in_hhomI in_homE src_dom trg_dom)
	+ have [simp]: "src \<nu>\<^sub>s = src u" using \<nu>\<^sub>s_in_hhom by auto
	+ have [simp]: "trg \<nu>\<^sub>s = trg s" using \<nu>\<^sub>s_in_hhom by auto
	+ have [simp]: "dom \<nu>\<^sub>s = r\<^sub>0 \<star> w\<^sub>r" using \<nu>\<^sub>s_in_hom by auto
	+ have [simp]: "cod \<nu>\<^sub>s = s\<^sub>1 \<star> w\<^sub>s" using \<nu>\<^sub>s_in_hom by auto
	+ have iso_\<nu>\<^sub>s: "iso \<nu>\<^sub>s" using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
	+
	+ obtain w \<theta>\<^sub>t \<nu>\<^sub>t
	+ where w\<theta>\<^sub>t\<nu>\<^sub>t: "ide w \<and> \<guillemotleft>\<theta>\<^sub>t : p\<^sub>0 \<star> w \<Rightarrow> w\<^sub>s\<guillemotright> \<and> \<guillemotleft>\<nu>\<^sub>t : w\<^sub>r \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu>\<^sub>t \<and>
	+ (s\<^sub>1 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t) = \<nu>\<^sub>s"
	+ using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s iso_\<nu>\<^sub>s r\<^sub>0s\<^sub>1.\<phi>_biuniversal_prop(1) [of w\<^sub>s w\<^sub>r \<nu>\<^sub>s] by blast
	+ text \<open>
	+$$
	+\xymatrix{
	+ && X \ar[ddl]_{w_r} \ar@/ul20pt/[dddll]_{v} \xtwocell[dddll]{}\omit{^{<1.5>\nu_r}}
	+ \ar@/ur20pt/[dddrr]^{u} \ar[ddr]^{w_s} \xtwocell[dddrr]{}\omit{^{<-1.5>\theta_s}}
	+ \ar@ {.>}[d]^{w} \xtwocell[ddl]{}\omit{^<-2>{\nu_t}} \xtwocell[ddr]{}\omit{^<2>{\theta_t}} \\
	+ && {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
	+ {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
	+}
	+$$
	+ \<close>
	+ text \<open>{\bf Note:} \<open>w\<close> is not necessarily a map.\<close>
	+ have w: "ide w"
	+ using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
	+ have [simp]: "src w = src u"
	+ using w\<theta>\<^sub>t\<nu>\<^sub>t src_cod
	+ by (metis \<nu>\<^sub>s_in_hom \<open>src \<nu>\<^sub>s = src u\<close> in_homE seqE hcomp_simps(1) src_vcomp
	+ vseq_implies_hpar(1))
	+ have [simp]: "trg w = src p\<^sub>0"
	+ using w\<theta>\<^sub>t\<nu>\<^sub>t
	+ by (metis \<nu>\<^sub>s_in_hom arrI not_arr_null r\<^sub>0s\<^sub>1.\<phi>_simps(2) seqE seq_if_composable)
	+ have \<theta>\<^sub>t_in_hom [intro]: "\<guillemotleft>\<theta>\<^sub>t : p\<^sub>0 \<star> w \<Rightarrow> w\<^sub>s\<guillemotright>"
	+ using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
	+ have \<theta>\<^sub>t_in_hhom [intro]: "\<guillemotleft>\<theta>\<^sub>t : src u \<rightarrow> src \<sigma>\<guillemotright>"
	+ using \<theta>\<^sub>t_in_hom src_cod trg_cod \<open>src w\<^sub>s = src u\<close> \<open>trg w\<^sub>s = src \<sigma>\<close> by fastforce
	+ have [simp]: "src \<theta>\<^sub>t = src u" using \<theta>\<^sub>t_in_hhom by auto
	+ have [simp]: "trg \<theta>\<^sub>t = src \<sigma>" using \<theta>\<^sub>t_in_hhom by auto
	+ have [simp]: "dom \<theta>\<^sub>t = p\<^sub>0 \<star> w" using \<theta>\<^sub>t_in_hom by blast
	+ have (* [simp]: *) "cod \<theta>\<^sub>t = w\<^sub>s" using \<theta>\<^sub>t_in_hom by blast
	+ have \<nu>\<^sub>t_in_hom [intro]: "\<guillemotleft>\<nu>\<^sub>t : w\<^sub>r \<Rightarrow> p\<^sub>1 \<star> w\<guillemotright>" using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
	+ have \<nu>\<^sub>t_in_hhom [intro]: "\<guillemotleft>\<nu>\<^sub>t : src u \<rightarrow> src \<rho>\<guillemotright>"
	+ using \<nu>\<^sub>t_in_hom src_dom trg_dom \<open>src w\<^sub>r = src u\<close> \<open>trg w\<^sub>r = src \<rho>\<close> by fastforce
	+ have [simp]: "src \<nu>\<^sub>t = src u" using \<nu>\<^sub>t_in_hhom by auto
	+ have [simp]: "trg \<nu>\<^sub>t = src \<rho>" using \<nu>\<^sub>t_in_hhom by auto
	+ have (* [simp]: *) "dom \<nu>\<^sub>t = w\<^sub>r" using \<nu>\<^sub>t_in_hom by auto
	+ have [simp]: "cod \<nu>\<^sub>t = p\<^sub>1 \<star> w" using \<nu>\<^sub>t_in_hom by auto
	+ have iso_\<nu>\<^sub>t: "iso \<nu>\<^sub>t" using w\<theta>\<^sub>t\<nu>\<^sub>t by simp
	+
	+ define \<theta> where "\<theta> = \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w]"
	+ have \<theta>: "\<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>"
	+ proof (unfold \<theta>_def, intro comp_in_homI)
	+ show "\<guillemotleft>\<a>[s\<^sub>0, p\<^sub>0, w] : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> s\<^sub>0 \<star> p\<^sub>0 \<star> w\<guillemotright>"
	+ using w\<theta>\<^sub>t\<nu>\<^sub>t by auto
	+ show "\<guillemotleft>s\<^sub>0 \<star> \<theta>\<^sub>t : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> s\<^sub>0 \<star> w\<^sub>s\<guillemotright>"
	+ using w\<theta>\<^sub>t\<nu>\<^sub>t by auto
	+ show "\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> w\<^sub>s \<Rightarrow> u\<guillemotright>"
	+ using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
	+ qed
	+ define \<nu> where "\<nu> = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
	+ have \<nu>: "\<guillemotleft>\<nu> : ?v \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright>"
	+ proof (unfold \<nu>_def, intro comp_in_homI)
	+ show "\<guillemotleft>\<nu>\<^sub>r : ?v \<Rightarrow> r\<^sub>1 \<star> w\<^sub>r\<guillemotright>"
	+ using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r by blast
	+ show "\<guillemotleft>r\<^sub>1 \<star> \<nu>\<^sub>t : r\<^sub>1 \<star> w\<^sub>r \<Rightarrow> r\<^sub>1 \<star> p\<^sub>1 \<star> w\<guillemotright>"
	+ using w\<theta>\<^sub>t\<nu>\<^sub>t by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] : r\<^sub>1 \<star> p\<^sub>1 \<star> w \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright>"
	+ using w\<theta>\<^sub>t\<nu>\<^sub>t assoc_in_hom by (simp add: \<rho>.T0.antipar(1))
	+ qed
	+ have iso_\<nu>: "iso \<nu>"
	+ using \<nu> w\<theta>\<^sub>t\<nu>\<^sub>t w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r \<rho>.T0.antipar(1) iso_inv_iso
	+ apply (unfold \<nu>_def, intro isos_compose) by auto
	+ have *: "arr ((s \<star> \<theta>\<^sub>s) \<cdot> \<a>[s, s\<^sub>0, w\<^sub>s] \<cdot> (\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
	+ using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s w\<theta>\<^sub>t\<nu>\<^sub>t \<theta>\<^sub>r_in_hom comp_assoc by auto
	+
	+ have "((r \<star> s) \<star> \<theta>) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu> = \<omega>"
	+ proof -
	+ have "seq (r \<star> \<theta>\<^sub>r) (\<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r)"
	+ using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r hseqI' \<rho>.base_simps(2) composable by fastforce
	+ hence "\<omega> = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> \<rho>.composite_cell w\<^sub>r \<theta>\<^sub>r \<cdot> \<nu>\<^sub>r"
	+ using w\<^sub>r\<theta>\<^sub>r\<nu>\<^sub>r invert_side_of_triangle(1) iso_assoc
	+ by (metis 1 \<rho>.ide_base \<sigma>.ide_base arrI assoc'_eq_inv_assoc composable hseq_char'
	+ seqE seq_if_composable u vconn_implies_hpar(2) vconn_implies_hpar(4) w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s)
	+ also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> \<rho>.composite_cell w\<^sub>r (\<sigma>.composite_cell w\<^sub>s \<theta>\<^sub>s \<cdot> \<nu>\<^sub>s) \<cdot> \<nu>\<^sub>r"
	+ using w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> \<a>[s, s\<^sub>0, w\<^sub>s] \<cdot>
	+ (\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
	+ using w\<theta>\<^sub>t\<nu>\<^sub>t comp_assoc by simp
	+ text \<open>Rearrange to create \<open>\<theta>\<close> and \<open>\<nu>\<close>, leaving \<open>tab\<close> in the middle.\<close>
	+ also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> \<a>[s, s\<^sub>0, w\<^sub>s] \<cdot>
	+ ((\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t)) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
	+ using comp_assoc by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (\<a>[s, s\<^sub>0, w\<^sub>s] \<cdot>
	+ ((s \<star> s\<^sub>0) \<star> \<theta>\<^sub>t)) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "(\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) = \<sigma> \<star> \<theta>\<^sub>t"
	+ using comp_arr_dom comp_cod_arr interchange
	+ by (metis \<open>cod \<theta>\<^sub>t = w\<^sub>s\<close> \<sigma>.tab_simps(1) \<sigma>.tab_simps(4) arrI w\<theta>\<^sub>t\<nu>\<^sub>t)
	+ also have "... = ((s \<star> s\<^sub>0) \<star> \<theta>\<^sub>t) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
	+ using comp_arr_dom comp_cod_arr interchange w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s w\<theta>\<^sub>t\<nu>\<^sub>t \<sigma>.tab_in_hom
	+ by (metis \<open>dom \<theta>\<^sub>t = p\<^sub>0 \<star> w\<close> \<sigma>.tab_simps(5) arrI)
	+ finally have "(\<sigma> \<star> w\<^sub>s) \<cdot> (s\<^sub>1 \<star> \<theta>\<^sub>t) = ((s \<star> s\<^sub>0) \<star> \<theta>\<^sub>t) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
	+ (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot> (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
	+ using assoc_naturality [of s s\<^sub>0 \<theta>\<^sub>t] w\<theta>\<^sub>t\<nu>\<^sub>t comp_assoc \<open>cod \<theta>\<^sub>t = w\<^sub>s\<close> arrI by force
	+ also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
	+ (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] \<cdot>
	+ (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
	+ (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t) =
	+ (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
	+ (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
	+ proof -
	+ have "seq ((s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t))
	+ (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
	+ proof -
	+ have "seq (s \<star> \<theta>\<^sub>s)
	+ ((s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t))"
	+ using \<open>\<guillemotleft>\<a>[r, s, u] \<cdot> \<omega> : dom \<omega> \<Rightarrow> r \<star> s \<star> u\<guillemotright>\<close> calculation by blast
	+ thus ?thesis
	+ using comp_assoc by presburger
	+ qed
	+ thus ?thesis
	+ using whisker_left [of r "(s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
	+ "\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t)"]
	+ w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s w\<theta>\<^sub>t\<nu>\<^sub>t comp_assoc
	+ by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
	+ (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> ((r \<star> r\<^sub>0 \<star> \<nu>\<^sub>t) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r]) \<cdot>
	+ (\<rho> \<star> w\<^sub>r) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "seq (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) (r\<^sub>0 \<star> \<nu>\<^sub>t)"
	+ using 1 r\<^sub>0s\<^sub>1.p\<^sub>1_simps w\<theta>\<^sub>t\<nu>\<^sub>t
	+ apply (intro seqI' comp_in_homI)
	+ apply auto
	+ apply auto
	+ by (intro hcomp_in_vhom, auto)
	+ hence "r \<star> (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> (r\<^sub>0 \<star> \<nu>\<^sub>t) =
	+ (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> (r \<star> r\<^sub>0 \<star> \<nu>\<^sub>t)"
	+ using whisker_left by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
	+ (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot>
	+ (((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t) \<cdot> (\<rho> \<star> w\<^sub>r)) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "(r \<star> r\<^sub>0 \<star> \<nu>\<^sub>t) \<cdot> \<a>[r, r\<^sub>0, w\<^sub>r] = \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> ((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t)"
	+ using assoc_naturality [of r r\<^sub>0 \<nu>\<^sub>t] \<nu>\<^sub>t_in_hom by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t))) \<cdot>
	+ (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot>
	+ (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t) \<cdot> (\<rho> \<star> w\<^sub>r) = \<rho> \<star> \<nu>\<^sub>t"
	+ using comp_arr_dom comp_cod_arr interchange
	+ by (metis \<open>dom \<nu>\<^sub>t = w\<^sub>r\<close> \<rho>.tab_simps(1) \<rho>.tab_simps(5) arrI w\<theta>\<^sub>t\<nu>\<^sub>t)
	+ also have "... = (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t)"
	+ using comp_arr_dom comp_cod_arr interchange
	+ by (metis \<open>cod \<nu>\<^sub>t = p\<^sub>1 \<star> w\<close> \<open>trg \<nu>\<^sub>t = src \<rho>\<close> \<rho>.T0.antipar(1) \<rho>.tab_simps(1)
	+ \<rho>.tab_simps(2) \<rho>.tab_simps(4) r\<^sub>0s\<^sub>1.base_simps(2) trg.preserves_reflects_arr
	+ trg_hcomp')
	+ finally have "((r \<star> r\<^sub>0) \<star> \<nu>\<^sub>t) \<cdot> (\<rho> \<star> w\<^sub>r) = (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t)" by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot>
	+ (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> ((\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot>
	+ (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) =
	+ ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
	+ proof -
	+ have "seq (s \<star> \<theta>\<^sub>s) (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
	+ using \<theta>\<^sub>s_in_hom \<theta>\<^sub>s_in_hhom \<theta>\<^sub>t_in_hom \<theta>\<^sub>t_in_hhom 1 calculation by blast
	+ moreover have "src r = trg (s \<star> \<theta>\<^sub>s)"
	+ using composable hseqI by force
	+ ultimately
	+ have "\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> (s \<star> \<theta>\<^sub>s) \<cdot> (s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) =
	+ (\<a>\<^sup>-\<^sup>1[r, s, u] \<cdot> (r \<star> s \<star> \<theta>\<^sub>s)) \<cdot> (r \<star> s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
	+ using whisker_left comp_assoc by simp
	+ also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> w\<^sub>s] \<cdot> (r \<star> s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)"
	+ using assoc_naturality comp_assoc
	+ by (metis \<open>cod \<theta>\<^sub>s = u\<close> \<open>dom \<theta>\<^sub>s = s\<^sub>0 \<star> w\<^sub>s\<close> \<open>trg \<theta>\<^sub>s = src s\<close>
	+ \<rho>.base_simps(2-4) \<sigma>.base_simps(2-4) arrI assoc'_naturality composable w\<^sub>s\<theta>\<^sub>s\<nu>\<^sub>s)
	+ also have "... = (((r \<star> s) \<star> \<theta>\<^sub>s) \<cdot> ((r \<star> s) \<star> s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> w\<^sub>s] \<cdot> (r \<star> s \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) =
	+ ((r \<star> s) \<star> s\<^sub>0 \<star> \<theta>\<^sub>t) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
	+ using arrI hseq_char assoc'_naturality [of r s "s\<^sub>0 \<star> \<theta>\<^sub>t"] \<open>cod \<theta>\<^sub>t = w\<^sub>s\<close> composable
	+ by auto
	+ thus ?thesis
	+ using comp_assoc by auto
	+ qed
	+ also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w]"
	+ using \<theta>_def \<theta> whisker_left by force
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot>
	+ ((r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w] \<cdot>
	+ ((\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w])) \<cdot>
	+ \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] = \<a>[s \<star> s\<^sub>0, p\<^sub>0, w] \<cdot> ((\<sigma> \<star> p\<^sub>0) \<star> w)"
	+ using assoc_naturality [of \<sigma> p\<^sub>0 w] by (simp add: w\<theta>\<^sub>t\<nu>\<^sub>t)
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
	+ (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ ((r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]) \<cdot>
	+ (\<rho> \<star> p\<^sub>1 \<star> w) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
	+ using r\<^sub>0s\<^sub>1.p\<^sub>1_simps w\<theta>\<^sub>t\<nu>\<^sub>t hseqI' whisker_left comp_assoc by force
	+ also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
	+ (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ (\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]) \<cdot>
	+ (\<rho> \<star> p\<^sub>1 \<star> w)) \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "(r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] =
	+ \<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]"
	+ proof -
	+ have 1: "(r \<star> \<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) =
	+ \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"
	+ using pentagon
	+ by (simp add: \<rho>.T0.antipar(1) w)
	+ moreover have 2: "seq \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"
	+ using \<rho>.T0.antipar(1) w by simp
	+ moreover have "inv (r \<star> \<a>[r\<^sub>0, p\<^sub>1, w]) = r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ using \<rho>.T0.antipar(1) w by simp
	+ ultimately have "\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) =
	+ ((r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]) \<cdot> \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"
	+ using \<rho>.T0.antipar(1) w comp_assoc
	+ invert_side_of_triangle(1)
	+ [of "\<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] \<cdot> \<a>[r \<star> r\<^sub>0, p\<^sub>1, w]" "r \<star> \<a>[r\<^sub>0, p\<^sub>1, w]"
	+ "\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w)"]
	+ by simp
	+ hence "(r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w] =
	+ (\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w]"
	+ using \<rho>.T0.antipar(1) w
	+ invert_side_of_triangle(2)
	+ [of "\<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w)"
	+ "(r \<star> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w]" "\<a>[r \<star> r\<^sub>0, p\<^sub>1, w]"]
	+ using \<open>trg w = src p\<^sub>0\<close> hseqI' by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
	+ (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> (r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>[r, r\<^sub>0 \<star> p\<^sub>1, w]) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r \<star> r\<^sub>0, p\<^sub>1, w] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w) = ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using assoc'_naturality [of \<rho> p\<^sub>1 w] by (simp add: \<rho>.T0.antipar(1) w\<theta>\<^sub>t\<nu>\<^sub>t)
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
	+ (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> ((r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>[r, s\<^sub>1 \<star> p\<^sub>0, w]) \<cdot>
	+ ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "(r \<star> r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>[r, r\<^sub>0 \<star> p\<^sub>1, w] = \<a>[r, s\<^sub>1 \<star> p\<^sub>0, w] \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w)"
	+ using assoc_naturality [of r r\<^sub>0s\<^sub>1.\<phi> w] r\<^sub>0s\<^sub>1.cospan w\<theta>\<^sub>t\<nu>\<^sub>t by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
	+ (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot>
	+ (((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot>
	+ ((\<rho> \<star> p\<^sub>1) \<star> w)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "(r \<star> (\<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> \<a>[r, s\<^sub>1 \<star> p\<^sub>0, w] =
	+ \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> ((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w)"
	+ proof -
	+ have "arr w \<and> dom w = w \<and> cod w = w"
	+ using ide_char w by presburger
	+ then show ?thesis
	+ using hseqI' assoc_naturality [of r "\<sigma> \<star> p\<^sub>0" w] composable by auto
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot>
	+ (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot>
	+ ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w)) \<cdot>
	+ (tab \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> (r\<^sub>1 \<star> \<nu>\<^sub>t) \<cdot> \<nu>\<^sub>r"
	+ proof -
	+ have "((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot> ((\<rho> \<star> p\<^sub>1) \<star> w) =
	+ (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1) \<star> w"
	+ using w \<rho>.T0.antipar(1) composable hseqI' whisker_right by auto
	+ also have "... = (((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)) \<cdot>
	+ (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1) \<star> w"
	+ proof -
	+ have "((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot>
	+ (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) =
	+ r \<star> \<sigma> \<star> p\<^sub>0"
	+ proof -
	+ have "((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot>
	+ (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) =
	+ ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> ((r \<star> s \<star> s\<^sub>0 \<star> p\<^sub>0) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]))) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)"
	+ using comp_assoc_assoc' by (simp add: composable)
	+ also have "... = ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0])) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)"
	+ using comp_cod_arr by (simp add: composable hseqI')
	+ also have "... = ((r \<star> (s \<star> s\<^sub>0) \<star> p\<^sub>0)) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0)"
	+ using whisker_left comp_assoc_assoc' assoc_in_hom hseqI'
	+ by (metis \<rho>.ide_base \<sigma>.base_simps(2) \<sigma>.ide_base \<sigma>.ide_leg0
	+ \<sigma>.leg0_simps(2-3) \<sigma>.leg1_simps(3) r\<^sub>0s\<^sub>1.ide_leg0
	+ r\<^sub>0s\<^sub>1.leg0_simps(2) r\<^sub>0s\<^sub>1.p\<^sub>0_simps hcomp_simps(1))
	+ also have "... = r \<star> \<sigma> \<star> p\<^sub>0"
	+ using comp_cod_arr
	+ by (simp add: composable hseqI')
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> \<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0]) \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0]) \<cdot> (r \<star> \<sigma> \<star> p\<^sub>0) \<cdot>
	+ (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1] \<cdot> (\<rho> \<star> p\<^sub>1) \<star> w"
	+ using comp_assoc by simp
	+ also have "... = (r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<cdot> \<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<cdot> tab \<star> w"
	+ using tab_def by simp
	+ also have "... = ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) \<cdot> (tab \<star> w)"
	+ using w \<rho>.T0.antipar(1) composable tab_in_hom hseqI' comp_assoc whisker_right
	+ by auto
	+ finally have "((r \<star> \<sigma> \<star> p\<^sub>0) \<star> w) \<cdot> ((r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<star> w) \<cdot> (\<a>[r, r\<^sub>0, p\<^sub>1] \<star> w) \<cdot>
	+ ((\<rho> \<star> p\<^sub>1) \<star> w) =
	+ ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) \<cdot> (tab \<star> w)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w])) \<cdot>
	+ \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot> (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
	+ \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot> (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) =
	+ ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> p\<^sub>0 \<star> w] \<cdot> (r \<star> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot> (r \<star> \<a>[s \<star> s\<^sub>0, p\<^sub>0, w]) \<cdot>
	+ \<a>[r, (s \<star> s\<^sub>0) \<star> p\<^sub>0, w] \<cdot> ((r \<star> \<a>\<^sup>-\<^sup>1[s, s\<^sub>0, p\<^sub>0]) \<star> w) \<cdot>
	+ (\<a>[r, s, s\<^sub>0 \<star> p\<^sub>0] \<star> w) =
	+ \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, (\<^bold>\<langle>s\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ ((\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>) \<^bold>\<cdot> (\<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>)\<rbrace>"
	+ using w comp_assoc \<a>'_def \<alpha>_def composable by simp
	+ also have "... = \<lbrace>((\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>s\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>s\<^bold>\<rangle>, \<^bold>\<langle>s\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using w composable
	+ apply (intro E.eval_eqI) by simp_all
	+ also have "... = ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w]"
	+ using w comp_assoc \<a>'_def \<alpha>_def composable by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using \<nu>_def comp_assoc by simp
	+ qed
	+ also have "... = ((r \<star> s) \<star> \<theta>) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu>"
	+ proof -
	+ have "((r \<star> s) \<star> \<theta>\<^sub>s \<cdot> (s\<^sub>0 \<star> \<theta>\<^sub>t)) \<cdot> ((r \<star> s) \<star> \<a>[s\<^sub>0, p\<^sub>0, w]) = (r \<star> s) \<star> \<theta>"
	+ using \<theta>_def w whisker_left composable
	+ by (metis \<theta> arrI ide_base comp_assoc)
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ finally show "((r \<star> s) \<star> \<theta>) \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w] \<cdot> (tab \<star> w) \<cdot> \<nu> = \<omega>"
	+ by simp
	+ qed
	+ thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright> \<and>
	+ \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
	+ using w\<theta>\<^sub>t\<nu>\<^sub>t \<theta> \<nu> iso_\<nu> comp_assoc by metis
	+ qed
	+
	+ show "\<And>u w w' \<theta> \<theta>' \<beta>.
	+ \<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : (s\<^sub>0 \<star> p\<^sub>0) \<star> w' \<Rightarrow> u\<guillemotright>;
	+ \<guillemotleft>\<beta> : (r\<^sub>1 \<star> p\<^sub>1) \<star> w \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w'\<guillemotright>;
	+ composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
	+ \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
	+ proof -
	+ fix u w w' \<theta> \<theta>' \<beta>
	+ assume w: "ide w"
	+ assume w': "ide w'"
	+ assume \<theta>: "\<guillemotleft>\<theta> : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> u\<guillemotright>"
	+ assume \<theta>': "\<guillemotleft>\<theta>' : (s\<^sub>0 \<star> p\<^sub>0) \<star> w' \<Rightarrow> u\<guillemotright>"
	+ assume \<beta>: "\<guillemotleft>\<beta> : (r\<^sub>1 \<star> p\<^sub>1) \<star> w \<Rightarrow> (r\<^sub>1 \<star> p\<^sub>1) \<star> w'\<guillemotright>"
	+ assume eq: "composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta>"
	+ interpret uw\<theta>w'\<theta>'\<beta>: uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg
	+ \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close> u w \<theta> w' \<theta>' \<beta>
	+ using w w' \<theta> \<theta>' \<beta> eq composable tab_in_hom comp_assoc
	+ by (unfold_locales, auto)
	+ text \<open>
	+$$
	+\begin{array}{ll}
	+\xymatrix{
	+ && X \ar[d]_{w'} \xtwocell[ddl]{}\omit{^{\beta}}
	+ \ar@/ul20pt/[dddll]_<>(0.25){w}\|<>(0.33)@ {>}_<>(0.5){p_1}\|<>(0.67)@ {>}_<>(0.75){r_1}
	+ \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta'}}\\
	+ && {\rm src}~\phi \ar[dl]^{p_1} \ar[dr]_{p_0} \ddtwocell\omit{^\phi} \\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
	+ {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
	+}
	+\\
	+\hspace{5cm}
	+=
	+\qquad
	+\xy/50pt/
	+\xymatrix{
	+ && X \ar[d]_{w} \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta}}\\
	+ && {\rm src}~\phi \ar[dl]^{p_1} \ar[dr]_{p_0} \ddtwocell\omit{^\phi} \\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
	+ {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
	+}
	+\endxy
	+\end{array}
	+$$
	+ \<close>
	+ text \<open>
	+ First apply property \<open>\<rho>.T2\<close> using \<open>\<guillemotleft>\<beta>\<^sub>r : r\<^sub>1 \<star> p\<^sub>1 \<star> w \<Rightarrow> r\<^sub>1 \<star> p\<^sub>1 \<star> w'\<guillemotright>\<close>
	+ (obtained by composing \<open>\<beta>\<close> with associativities) and ``everything to the right''
	+ as \<open>\<theta>\<^sub>r\<close> and \<open>\<theta>\<^sub>r'\<close>. This yields \<open>\<guillemotleft>\<gamma>\<^sub>r : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>\<close>.
	+ Next, apply property \<open>\<rho>.T2\<close> to obtain \<open>\<guillemotleft>\<gamma>\<^sub>s : p\<^sub>0 \<star> w \<Rightarrow> p\<^sub>0 \<star> w'\<guillemotright>\<close>.
	+ For this use \<open>\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>\<close> and \<open>\<guillemotleft>\<theta>\<^sub>s' : s\<^sub>0 \<star> p\<^sub>0 \<star> w'\<guillemotright>\<close>
	+ obtained by composing \<open>\<theta>\<close> and \<open>\<theta>'\<close> with associativities.
	+ We also need \<open>\<guillemotleft>\<beta>\<^sub>s : s\<^sub>1 \<star> p\<^sub>0 \<star> w \<Rightarrow> s\<^sub>1 \<star> p\<^sub>0 \<star> w'\<guillemotright>\<close>.
	+ To get this, transport \<open>r\<^sub>0 \<star> \<gamma>\<^sub>r\<close> across \<open>\<phi>\<close>; we need \<open>\<phi>\<close> to be an isomorphism
	+ in order to do this.
	+ Finally, apply the biuniversal property of \<open>\<phi>\<close> to get \<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>\<close>
	+ and verify the required equation.
	+ \<close>
	+ let ?w\<^sub>r = "p\<^sub>1 \<star> w"
	+ have w\<^sub>r: "ide ?w\<^sub>r" by simp
	+ let ?w\<^sub>r' = "p\<^sub>1 \<star> w'"
	+ have w\<^sub>r': "ide ?w\<^sub>r'" by simp
	+ define \<theta>\<^sub>r where "\<theta>\<^sub>r = (s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot>
	+ (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ have \<theta>\<^sub>r: "\<guillemotleft>\<theta>\<^sub>r : r\<^sub>0 \<star> ?w\<^sub>r \<Rightarrow> s \<star> u\<guillemotright>"
	+ unfolding \<theta>\<^sub>r_def
	+ using \<rho>.T0.antipar(1) hseqI'
	+ by (intro comp_in_homI hcomp_in_vhom, auto)
	+ define \<theta>\<^sub>r' where "\<theta>\<^sub>r' = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
	+ (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']"
	+ have \<theta>\<^sub>r': "\<guillemotleft>\<theta>\<^sub>r' : r\<^sub>0 \<star> ?w\<^sub>r' \<Rightarrow> s \<star> u\<guillemotright>"
	+ unfolding \<theta>\<^sub>r'_def
	+ using \<rho>.T0.antipar(1) hseqI'
	+ by (intro comp_in_homI hcomp_in_vhom, auto)
	+ define \<beta>\<^sub>r where "\<beta>\<^sub>r = \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ have \<beta>\<^sub>r: "\<guillemotleft>\<beta>\<^sub>r : r\<^sub>1 \<star> ?w\<^sub>r \<Rightarrow> r\<^sub>1 \<star> ?w\<^sub>r'\<guillemotright>"
	+ unfolding \<beta>\<^sub>r_def
	+ using \<rho>.T0.antipar(1)
	+ by (intro comp_in_homI hcomp_in_vhom, auto)
	+ have eq\<^sub>r: "\<rho>.composite_cell ?w\<^sub>r \<theta>\<^sub>r = \<rho>.composite_cell ?w\<^sub>r' \<theta>\<^sub>r' \<cdot> \<beta>\<^sub>r"
	+ text \<open>
	+$$
	+\begin{array}{ll}
	+\xymatrix{
	+ && X \ar[ddl]^{w_r'} \xtwocell[dddll]{}\omit{^<2>{\beta_r}}
	+ \ar@/ul20pt/[dddll]_<>(0.33){w_r}\|<>(0.67)@ {>}_<>(0.75){r_1}
	+ \ar@/ur20pt/[dddrr]^{u} \xtwocell[dddr]{}\omit{^{\theta_r'}}\\
	+ && \\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
	+ && \\
	+ {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
	+}
	+\\
	+\hspace{5cm}
	+=\qquad
	+\xy/50pt/
	+\xymatrix{
	+ && X \ar[ddl]^{w_r} \ar@/ur20pt/[dddrr]^{u} \xtwocell[dddr]{}\omit{^{\theta_r}}\\
	+ && \\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \dtwocell\omit{^\rho}
	+ && \\
	+ {\rm trg}~r && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} && {\rm src}~s \ar[ll]^{s}
	+}
	+\endxy
	+\end{array}
	+$$
	+ \<close>
	+ proof -
	+ have "\<rho>.composite_cell ?w\<^sub>r \<theta>\<^sub>r = \<a>[r, s, u] \<cdot> composite_cell w \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using \<theta>\<^sub>r_def technical uw\<theta>w'\<theta>'\<beta>.uw\<theta>.uw\<theta> by blast
	+ also have "... = \<a>[r, s, u] \<cdot> (((r \<star> s) \<star> \<theta>') \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w'] \<cdot>
	+ (tab \<star> w') \<cdot> \<beta>) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using eq comp_assoc by simp
	+ also have "... = (r \<star> \<theta>\<^sub>r') \<cdot> \<a>[r, r\<^sub>0, ?w\<^sub>r'] \<cdot> (\<rho> \<star> ?w\<^sub>r') \<cdot> \<beta>\<^sub>r"
	+ proof -
	+ have "\<a>[r, s, u] \<cdot> (composite_cell w' \<theta>' \<cdot> \<beta>) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] =
	+ \<a>[r, s, u] \<cdot> composite_cell w' \<theta>' \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using comp_assoc by simp
	+ also have "... = (r \<star> (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
	+ (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot>
	+ \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w'] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w') \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ proof -
	+ have "\<a>[r, s, u] \<cdot> composite_cell w' \<theta>' \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] =
	+ \<a>[r, s, u] \<cdot> composite_cell w' \<theta>' \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<beta>) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using comp_cod_arr \<rho>.T0.antipar(1) \<beta> comp_assoc_assoc' by simp
	+ also have "... = (\<a>[r, s, u] \<cdot> ((r \<star> s) \<star> \<theta>') \<cdot> \<a>[r \<star> s, s\<^sub>0 \<star> p\<^sub>0, w'] \<cdot> (tab \<star> w') \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using comp_assoc by simp
	+ also have "... = ((r \<star> (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
	+ (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> \<a>[r, r\<^sub>0, p\<^sub>1 \<star> w'] \<cdot> (\<rho> \<star> p\<^sub>1 \<star> w')) \<cdot>
	+ \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using \<theta>\<^sub>r'_def technical [of w' \<theta>' u ?w\<^sub>r' \<theta>\<^sub>r'] comp_assoc by fastforce
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ finally show ?thesis
	+ using \<theta>\<^sub>r'_def \<beta>\<^sub>r_def comp_assoc by auto
	+ qed
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ have 1: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright> \<and> \<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>r = r\<^sub>1 \<star> \<gamma>"
	+ using eq\<^sub>r \<rho>.T2 [of ?w\<^sub>r ?w\<^sub>r' \<theta>\<^sub>r "s \<star> u" \<theta>\<^sub>r' \<beta>\<^sub>r] w\<^sub>r w\<^sub>r' \<theta>\<^sub>r \<theta>\<^sub>r' \<beta>\<^sub>r by blast
	+ obtain \<gamma>\<^sub>r where \<gamma>\<^sub>r: "\<guillemotleft>\<gamma>\<^sub>r : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright> \<and> \<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<and> \<beta>\<^sub>r = r\<^sub>1 \<star> \<gamma>\<^sub>r"
	+ using 1 by blast
	+
	+ let ?w\<^sub>s = "p\<^sub>0 \<star> w"
	+ have w\<^sub>s: "ide ?w\<^sub>s" by simp
	+ let ?w\<^sub>s' = "p\<^sub>0 \<star> w'"
	+ have w\<^sub>s': "ide ?w\<^sub>s'" by simp
	+ define \<theta>\<^sub>s where "\<theta>\<^sub>s = \<theta> \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
	+ have \<theta>\<^sub>s: "\<guillemotleft>\<theta>\<^sub>s : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> u\<guillemotright>"
	+ using \<theta>\<^sub>s_def by auto
	+ define \<theta>\<^sub>s' where "\<theta>\<^sub>s' = \<theta>' \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']"
	+ have \<theta>\<^sub>s': "\<guillemotleft>\<theta>\<^sub>s' : s\<^sub>0 \<star> p\<^sub>0 \<star> w' \<Rightarrow> u\<guillemotright>"
	+ using \<theta>\<^sub>s'_def by auto
	+ define \<beta>\<^sub>s where "\<beta>\<^sub>s = \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot>
	+ \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
	+ have \<beta>\<^sub>s: "\<guillemotleft>\<beta>\<^sub>s : s\<^sub>1 \<star> ?w\<^sub>s \<Rightarrow> s\<^sub>1 \<star> ?w\<^sub>s'\<guillemotright>"
	+ unfolding \<beta>\<^sub>s_def
	+ using \<gamma>\<^sub>r r\<^sub>0s\<^sub>1.\<phi>_in_hom(2) r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1)
	+ apply (intro comp_in_homI)
	+ apply auto
	+ by auto
	+ have eq\<^sub>s: "\<sigma>.composite_cell (p\<^sub>0 \<star> w) (\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) =
	+ \<sigma>.composite_cell (p\<^sub>0 \<star> w') (\<theta>' \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<beta>\<^sub>s"
	+ text \<open>
	+$$
	+\begin{array}{ll}
	+\xy/67pt/
	+\xymatrix{
	+ && X \ar[d]^{w'} \ar@/l10pt/[dl]_{w} \ddltwocell\omit{^{\gamma_r}}
	+ \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta_s'}}\\
	+ & {\rm src}~\phi \ar[dr]_{p_1} \ar[d]_{p_0}
	+ & {\rm src}~\phi \ar[d]^{p_1} \ar[dr]_{p_0} \ddrtwocell\omit{^\phi} \xtwocell[ddl]{}\omit{^\;\;\;\;\phi^{-1}} \\
	+ & {\rm src}~\sigma \ar[dr]_{s_1} & {\rm src}~\rho \ar[d]^{r_0}
	+ & {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
	+ && {\rm src}~r = {\rm trg}~s && {\rm src}~s \ar[ll]^{s}
	+}
	+\endxy
	+\\
	+\hspace{5cm}=
	+\xy/50pt/
	+\xymatrix{
	+ & X \ar@/dl15pt/[ddr]_<>(0.5){w_s}
	+ \ar@/ur20pt/[dddrr]^{u} \xtwocell[ddr]{}\omit{^{\theta_s}}\\
	+ & \\
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^\sigma}\\
	+ & {\rm src}~r = {\rm trg}~s && {\rm src}~s \ar[ll]^{s}
	+}
	+\endxy
	+\end{array}
	+$$
	+ \<close>
	+ proof -
	+ have "\<sigma>.composite_cell (p\<^sub>0 \<star> w') (\<theta>' \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<beta>\<^sub>s =
	+ (\<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
	+ using \<beta>\<^sub>s_def \<theta>\<^sub>r'_def whisker_left comp_assoc by simp
	+ also have "... = \<theta>\<^sub>r \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
	+ using \<gamma>\<^sub>r by simp
	+ also have "... = ((s \<star> \<theta>) \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])) \<cdot> \<a>[s, s\<^sub>0, ?w\<^sub>s] \<cdot> (\<sigma> \<star> ?w\<^sub>s) \<cdot>
	+ \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot>
	+ \<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
	+ using \<theta>\<^sub>r_def comp_assoc by simp
	+ also have "... = (s \<star> \<theta>) \<cdot> \<sigma>.composite_cell (p\<^sub>0 \<star> w) \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
	+ proof -
	+ have "(\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot>
	+ \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot>
	+ \<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] =
	+ \<sigma> \<star> p\<^sub>0 \<star> w"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] = cod (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
	+ using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1) hseqI' comp_assoc_assoc' by simp
	+ text \<open>Here the fact that \<open>\<phi>\<close> is a retraction is used.\<close>
	+ moreover have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) = cod \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
	+ using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_arr_inv' whisker_right [of w r\<^sub>0s\<^sub>1.\<phi> "inv r\<^sub>0s\<^sub>1.\<phi>"]
	+ by simp
	+ moreover have "\<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] = dom (\<sigma> \<star> p\<^sub>0 \<star> w)"
	+ using r\<^sub>0s\<^sub>1.base_simps(2) hseq_char comp_assoc_assoc' by auto
	+ moreover have "hseq (inv r\<^sub>0s\<^sub>1.\<phi>) w"
	+ using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2)
	+ by (intro hseqI, auto)
	+ moreover have "hseq \<sigma> (p\<^sub>0 \<star> w)"
	+ by (intro hseqI, auto)
	+ ultimately show ?thesis
	+ using comp_arr_dom comp_cod_arr by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<sigma>.composite_cell (p\<^sub>0 \<star> w) (\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])"
	+ using \<theta>\<^sub>s_def whisker_left
	+ by (metis \<sigma>.ide_base \<theta>\<^sub>s arrI comp_assoc)
	+ finally show ?thesis by simp
	+ qed
	+ hence 2: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright> \<and> \<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>s = s\<^sub>1 \<star> \<gamma>"
	+ using \<sigma>.T2 [of ?w\<^sub>s ?w\<^sub>s' \<theta>\<^sub>s u \<theta>\<^sub>s' \<beta>\<^sub>s] w\<^sub>s w\<^sub>s' \<theta>\<^sub>s \<theta>\<^sub>s' \<beta>\<^sub>s
	+ by (metis \<theta>\<^sub>s'_def \<theta>\<^sub>s_def)
	+ obtain \<gamma>\<^sub>s where \<gamma>\<^sub>s: "\<guillemotleft>\<gamma>\<^sub>s : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright> \<and> \<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> \<gamma>\<^sub>s) \<and> \<beta>\<^sub>s = s\<^sub>1 \<star> \<gamma>\<^sub>s"
	+ using 2 by blast
	+
	+ have eq\<^sub>t: "(s\<^sub>1 \<star> \<gamma>\<^sub>s) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
	+ (s\<^sub>1 \<star> ?w\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
	+ text \<open>
	+$$
	+\xy/78pt/
	+\xymatrix{
	+ & X \ar[d]^{w'} \ar@/ul15pt/[ddl]_{w_r} \xtwocell[ddl]{}\omit{^{\gamma_r}} \\
	+ & {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\
	+ {\rm src}~\rho \ar[dr]^{r_0}
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \\
	+ & {\rm src}~r = {\rm trg}~s &
	+}
	+\endxy
	+\qquad = \qquad
	+\xy/78pt/
	+\xymatrix{
	+ & X \ar[d]^{w} \ar@/ur15pt/[ddr]^{w_s'} \xtwocell[ddr]{}\omit{^{\gamma_s}} \\
	+ & {\rm src}~\phi \ar[dl]_{p_1} \ar[dr]^{p_0} \ddtwocell\omit{^\phi} \\
	+ {\rm src}~\rho \ar[dr]^{r_0}
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \\
	+ & {\rm src}~r = {\rm trg}~s &
	+}
	+\endxy
	+$$
	+ \<close>
	+ proof -
	+ have "(s\<^sub>1 \<star> ?w\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) =
	+ \<beta>\<^sub>s \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ proof -
	+ have "\<beta>\<^sub>s \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
	+ (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot>
	+ \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ \<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ using \<beta>\<^sub>s_def comp_assoc by metis
	+ also have "... = (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
	+ proof -
	+ have "(r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ \<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
	+ r\<^sub>0 \<star> \<gamma>\<^sub>r"
	+ proof -
	+ have "(r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ \<a>[s\<^sub>1, p\<^sub>0, w]) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] =
	+ (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> ((inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_assoc_assoc' comp_cod_arr
	+ by (simp add: hseqI')
	+ (* Used here that \<phi> is a section. *)
	+ also have "... = (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_inv_arr' \<rho>.T0.antipar(1)
	+ whisker_right [of w "inv r\<^sub>0s\<^sub>1.\<phi>" r\<^sub>0s\<^sub>1.\<phi>] comp_cod_arr
	+ by simp
	+ also have "... = r\<^sub>0 \<star> \<gamma>\<^sub>r"
	+ proof -
	+ have "hseq r\<^sub>0 \<gamma>\<^sub>r"
	+ using \<beta>\<^sub>s \<beta>\<^sub>s_def by blast
	+ thus ?thesis
	+ using comp_assoc_assoc' comp_arr_dom
	+ by (metis (no_types) \<gamma>\<^sub>r \<rho>.ide_leg0 comp_assoc_assoc'(1) hcomp_simps(3)
	+ hseq_char ide_char in_homE r\<^sub>0s\<^sub>1.ide_leg1 r\<^sub>0s\<^sub>1.p\<^sub>1_simps w w\<^sub>r)
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
	+ using comp_assoc by simp
	+ also have "... = (s\<^sub>1 \<star> ?w\<^sub>s') \<cdot>
	+ \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r)"
	+ proof -
	+ have "(s\<^sub>1 \<star> ?w\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] = \<a>[s\<^sub>1, p\<^sub>0, w']"
	+ using comp_cod_arr by simp
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = (s\<^sub>1 \<star> \<gamma>\<^sub>s) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ using \<gamma>\<^sub>s by simp
	+ finally show ?thesis by simp
	+ qed
	+ have 3: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<gamma>\<^sub>s = (p\<^sub>0 \<star> w') \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<gamma>\<^sub>r"
	+ using w w' w\<^sub>s' w\<^sub>r \<gamma>\<^sub>r \<gamma>\<^sub>s eq\<^sub>t
	+ r\<^sub>0s\<^sub>1.\<phi>_biuniversal_prop(2) [of ?w\<^sub>s' ?w\<^sub>r w w' \<gamma>\<^sub>s "p\<^sub>0 \<star> w'" \<gamma>\<^sub>r]
	+ by blast
	+ obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<gamma>\<^sub>s = (p\<^sub>0 \<star> w') \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<gamma>\<^sub>r"
	+ using 3 by blast
	+
	+ show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
	+ proof -
	+ have "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
	+ proof -
	+ have "\<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
	+ proof -
	+ have "\<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>) = (\<theta>\<^sub>s' \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w']) \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
	+ using \<theta>\<^sub>s'_def comp_arr_dom comp_assoc comp_assoc_assoc'(2) by auto
	+ also have "... = (\<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>)) \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w]"
	+ using assoc_naturality [of s\<^sub>0 p\<^sub>0 \<gamma>] comp_assoc
	+ by (metis \<gamma> \<gamma>\<^sub>r \<sigma>.leg0_simps(4-5) r\<^sub>0s\<^sub>1.leg0_simps(4-5)
	+ r\<^sub>0s\<^sub>1.leg1_simps(3) hseqE in_homE leg0_simps(2))
	+ also have "... = \<theta>\<^sub>s \<cdot> \<a>[s\<^sub>0, p\<^sub>0, w]"
	+ by (metis \<gamma> \<gamma>\<^sub>s arrI comp_ide_arr w\<^sub>s')
	+ also have "... = \<theta>"
	+ using \<theta>\<^sub>s_def comp_assoc comp_arr_dom comp_assoc_assoc' by simp
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "\<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>"
	+ proof -
	+ have "\<beta> = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta>\<^sub>r \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<beta>\<^sub>r \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w] =
	+ (\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> \<beta> \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w]"
	+ using \<beta>\<^sub>r_def comp_assoc by simp
	+ also have "... = \<beta>"
	+ using comp_arr_dom comp_cod_arr
	+ by (metis \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.ide_leg1 comp_assoc_assoc'(2) hseqE ideD(1)
	+ uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(4-5) leg1_simps(2) w w' w\<^sub>r w\<^sub>r')
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> (r\<^sub>1 \<star> \<gamma>\<^sub>r) \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w]"
	+ using \<gamma>\<^sub>r by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> ((r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>)"
	+ using assoc_naturality [of r\<^sub>1 p\<^sub>1 \<gamma>]
	+ by (metis \<gamma> \<gamma>\<^sub>r \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.leg1_simps(5-6) hseqE
	+ ide_char in_homE leg1_simps(2))
	+ also have "... = (\<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>[r\<^sub>1, p\<^sub>1, w']) \<cdot> ((r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>)"
	+ using comp_assoc by simp
	+ also have "... = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>"
	+ using comp_cod_arr
	+ by (metis \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.ide_leg1 calculation comp_assoc_assoc'(2) comp_ide_arr
	+ hseqE ideD(1) ide_cod local.uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) local.uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(5)
	+ w' w\<^sub>r')
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>)"
	+ using \<gamma> by blast
	+ qed
	+ moreover have "\<And>\<gamma>'. \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>')
	+ \<Longrightarrow> \<gamma>' = \<gamma>"
	+ proof -
	+ fix \<gamma>'
	+ assume \<gamma>': "\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = (r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>')"
	+ show "\<gamma>' = \<gamma>"
	+ proof -
	+ let ?P\<^sub>r = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright> \<and> \<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>r = r\<^sub>1 \<star> \<gamma>"
	+ let ?P\<^sub>s = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright> \<and> \<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> \<gamma>) \<and> \<beta>\<^sub>s = s\<^sub>1 \<star> \<gamma>"
	+ let ?\<gamma>\<^sub>r' = "p\<^sub>1 \<star> \<gamma>'"
	+ let ?\<gamma>\<^sub>s' = "p\<^sub>0 \<star> \<gamma>'"
	+ let ?P\<^sub>t = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<gamma>\<^sub>s = (p\<^sub>0 \<star> w') \<cdot> (p\<^sub>0 \<star> \<gamma>) \<and> p\<^sub>1 \<star> \<gamma> = \<gamma>\<^sub>r"
	+ have "hseq p\<^sub>0 \<gamma>'"
	+ proof (intro hseqI)
	+ show "\<guillemotleft>\<gamma>' : src \<theta> \<rightarrow> src p\<^sub>0\<guillemotright>"
	+ using \<gamma>'
	+ by (metis hseqE hseqI' in_hhom_def uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) src_hcomp'
	+ src_vcomp leg0_simps(2) leg1_simps(3)
	+ uw\<theta>w'\<theta>'\<beta>.uw\<theta>.\<theta>_simps(1) vseq_implies_hpar(1))
	+ show "\<guillemotleft>p\<^sub>0 : src p\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright>" by simp
	+ qed
	+ hence "hseq p\<^sub>1 \<gamma>'"
	+ using hseq_char by simp
	+ have "\<guillemotleft>?\<gamma>\<^sub>r' : ?w\<^sub>r \<Rightarrow> ?w\<^sub>r'\<guillemotright>"
	+ using \<gamma>' by auto
	+ moreover have "\<theta>\<^sub>r = \<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r')"
	+ proof -
	+ text \<open>
	+ Note that @{term \<theta>\<^sub>r} is the composite of ``everything to the right''
	+ of @{term "\<rho> \<star> ?w\<^sub>r"}, and similarly for @{term \<theta>\<^sub>r'}.
	+ We can factor @{term \<theta>\<^sub>r} as @{term "(s \<star> \<theta>) \<cdot> X w"}, where @{term "X w"}
	+ is a composite of @{term \<sigma>} and @{term \<phi>}. We can similarly factor @{term \<theta>\<^sub>r'}
	+ as @{term "(s \<star> \<theta>') \<cdot> X w'"}.
	+ Then @{term "\<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r') = (s \<star> \<theta>') \<cdot> X w' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r')"},
	+ which equals @{term "(s \<star> \<theta>') \<cdot> (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> ?\<gamma>\<^sub>r') \<cdot> X w = \<theta>\<^sub>r"}.
	+ \<close>
	+ let ?X = "\<lambda>w. (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot>
	+ \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ have "\<theta>\<^sub>r' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r') = (s \<star> \<theta>') \<cdot> ?X w' \<cdot> (r\<^sub>0 \<star> ?\<gamma>\<^sub>r')"
	+ using \<theta>\<^sub>r'_def comp_assoc by simp
	+ also have "... = (s \<star> \<theta>') \<cdot> (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> ?X w"
	+ proof -
	+ have "(s \<star> \<theta>') \<cdot> ((s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot>
	+ \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w']) \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>') =
	+ (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot>
	+ \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>')"
	+ using comp_assoc by simp
	+ also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
	+ (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot>
	+ ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>')) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ using assoc'_naturality [of r\<^sub>0 p\<^sub>1 \<gamma>'] comp_assoc
	+ by (metis \<gamma>' \<open>\<guillemotleft>p\<^sub>1 \<star> \<gamma>' : p\<^sub>1 \<star> w \<Rightarrow> p\<^sub>1 \<star> w'\<guillemotright>\<close> \<rho>.T0.antipar(1)
	+ \<rho>.leg0_in_hom(2) r\<^sub>0s\<^sub>1.leg1_simps(4-6)
	+ r\<^sub>0s\<^sub>1.base_simps(2) hcomp_in_vhomE in_homE trg_hcomp')
	+ also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
	+ (\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>')) \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ proof -
	+ have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') = r\<^sub>0s\<^sub>1.\<phi> \<star> \<gamma>'"
	+ using \<gamma>' interchange [of r\<^sub>0s\<^sub>1.\<phi> "r\<^sub>0 \<star> p\<^sub>1" w' \<gamma>'] comp_arr_dom comp_cod_arr
	+ by auto
	+ also have "... = ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
	+ using \<gamma>' interchange \<open>hseq p\<^sub>0 \<gamma>'\<close> comp_arr_dom comp_cod_arr
	+ by (metis comp_arr_ide r\<^sub>0s\<^sub>1.\<phi>_simps(1,5) seqI'
	+ uw\<theta>w'\<theta>'\<beta>.uw\<theta>.w_in_hom(2) w)
	+ finally have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') =
	+ ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
	+ ((\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (s\<^sub>1 \<star> p\<^sub>0 \<star> \<gamma>')) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ using \<gamma>' assoc_naturality [of s\<^sub>1 p\<^sub>0 \<gamma>'] comp_assoc
	+ by (metis \<sigma>.leg1_simps(2) \<sigma>.leg1_simps(3,5-6) r\<^sub>0s\<^sub>1.leg0_simps(4-5)
	+ hcomp_in_vhomE hseqE in_homE uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1)
	+ leg0_in_hom(2) leg1_simps(3))
	+ also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (\<a>[s, s\<^sub>0, p\<^sub>0 \<star> w'] \<cdot>
	+ ((s \<star> s\<^sub>0) \<star> p\<^sub>0 \<star> \<gamma>')) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ proof -
	+ have "(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (s\<^sub>1 \<star> p\<^sub>0 \<star> \<gamma>') = \<sigma> \<star> p\<^sub>0 \<star> \<gamma>'"
	+ using \<gamma>' interchange [of \<sigma> s\<^sub>1 "p\<^sub>0 \<star> w'" "p\<^sub>0 \<star> \<gamma>'"]
	+ whisker_left \<open>hseq p\<^sub>0 \<gamma>'\<close>comp_arr_dom comp_cod_arr
	+ by auto
	+ also have "... = ((s \<star> s\<^sub>0) \<star> p\<^sub>0 \<star> \<gamma>') \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
	+ using \<gamma>' interchange [of "s \<star> s\<^sub>0" \<sigma> "p\<^sub>0 \<star> \<gamma>'" "p\<^sub>0 \<star> w"]
	+ whisker_left comp_arr_dom comp_cod_arr \<open>hseq p\<^sub>0 \<gamma>'\<close>
	+ by auto
	+ finally have "(\<sigma> \<star> p\<^sub>0 \<star> w') \<cdot> (s\<^sub>1 \<star> p\<^sub>0 \<star> \<gamma>') =
	+ ((s \<star> s\<^sub>0) \<star> p\<^sub>0 \<star> \<gamma>') \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (s \<star> \<theta>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> ((s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>') \<cdot>
	+ \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w]) \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ using \<gamma>' assoc_naturality [of s s\<^sub>0 "p\<^sub>0 \<star> \<gamma>'"] \<open>hseq p\<^sub>0 \<gamma>'\<close> by auto
	+ also have "... = (s \<star> \<theta>') \<cdot> ((s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>')) \<cdot>
	+ \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ using comp_assoc by simp
	+ also have "... = (s \<star> \<theta>') \<cdot> ((s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])) \<cdot>
	+ \<a>[s, s\<^sub>0, p\<^sub>0 \<star> w] \<cdot> (\<sigma> \<star> p\<^sub>0 \<star> w) \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot>
	+ (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ proof -
	+ have "(s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>') =
	+ (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])"
	+ proof -
	+ have "(s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w']) \<cdot> (s \<star> s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>') =
	+ s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w'] \<cdot> (s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>')"
	+ proof -
	+ have "seq \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w'] (s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>')"
	+ proof
	+ (* It seems to be too time-consuming for auto to solve these. *)
	+ show "\<guillemotleft>s\<^sub>0 \<star> p\<^sub>0 \<star> \<gamma>' : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> s\<^sub>0 \<star> p\<^sub>0 \<star> w'\<guillemotright>"
	+ using \<gamma>'
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w'] : s\<^sub>0 \<star> p\<^sub>0 \<star> w' \<Rightarrow> (s\<^sub>0 \<star> p\<^sub>0) \<star> w'\<guillemotright>"
	+ by auto
	+ qed
	+ thus ?thesis
	+ using w w' \<gamma>' whisker_left by simp
	+ qed
	+ also have "... = s \<star> ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
	+ using \<gamma>' \<open>hseq p\<^sub>0 \<gamma>'\<close> assoc'_naturality [of s\<^sub>0 p\<^sub>0 \<gamma>'] by fastforce
	+ also have "... = (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (s \<star> \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w])"
	+ proof -
	+ have "seq ((s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w]"
	+ proof
	+ (* Same here. *)
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[s\<^sub>0, p\<^sub>0, w] : s\<^sub>0 \<star> p\<^sub>0 \<star> w \<Rightarrow> (s\<^sub>0 \<star> p\<^sub>0) \<star> w\<guillemotright>"
	+ by auto
	+ show "\<guillemotleft>(s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>' : (s\<^sub>0 \<star> p\<^sub>0) \<star> w \<Rightarrow> (s\<^sub>0 \<star> p\<^sub>0) \<star> w'\<guillemotright>"
	+ using \<gamma>' by (intro hcomp_in_vhom, auto)
	+ qed
	+ thus ?thesis
	+ using w w' \<gamma>' whisker_left by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (s \<star> \<theta>') \<cdot> (s \<star> (s\<^sub>0 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> ?X w"
	+ using comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = \<theta>\<^sub>r"
	+ using \<theta>\<^sub>r_def \<gamma>' uw\<theta>w'\<theta>'\<beta>.uw\<theta>.\<theta>_simps(1) whisker_left \<sigma>.ide_base comp_assoc
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "\<beta>\<^sub>r = r\<^sub>1 \<star> ?\<gamma>\<^sub>r'"
	+ proof -
	+ have "\<beta>\<^sub>r = \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> ((r\<^sub>1 \<star> p\<^sub>1) \<star> \<gamma>') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w]"
	+ using \<beta>\<^sub>r_def \<gamma>' by simp
	+ also have "... = \<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w'] \<cdot> (r\<^sub>1 \<star> p\<^sub>1 \<star> \<gamma>')"
	+ using \<gamma>' assoc'_naturality
	+ by (metis \<rho>.leg1_simps(5-6) r\<^sub>0s\<^sub>1.leg1_simps(5-6)
	+ hcomp_in_vhomE hseqE in_homE uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(1) leg1_in_hom(2))
	+ also have "... = (\<a>[r\<^sub>1, p\<^sub>1, w'] \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>1, p\<^sub>1, w']) \<cdot> (r\<^sub>1 \<star> p\<^sub>1 \<star> \<gamma>')"
	+ using comp_assoc by simp
	+ also have "... = r\<^sub>1 \<star> p\<^sub>1 \<star> \<gamma>'"
	+ using comp_cod_arr
	+ by (metis (no_types, lifting) \<beta>\<^sub>r \<rho>.ide_leg1 r\<^sub>0s\<^sub>1.ide_leg1 arrI calculation
	+ comp_assoc_assoc'(1) comp_ide_arr ide_hcomp hseq_char'
	+ ideD(1) seq_if_composable hcomp_simps(2) leg1_simps(2) w' w\<^sub>r')
	+ finally show ?thesis by simp
	+ qed
	+ ultimately have P\<^sub>r': "?P\<^sub>r ?\<gamma>\<^sub>r'"
	+ by simp
	+ have eq\<^sub>r: "\<gamma>\<^sub>r = ?\<gamma>\<^sub>r'"
	+ using 1 \<gamma>\<^sub>r P\<^sub>r' by blast
	+ have "\<guillemotleft>?\<gamma>\<^sub>s' : ?w\<^sub>s \<Rightarrow> ?w\<^sub>s'\<guillemotright>"
	+ using \<gamma>' by auto
	+ moreover have "\<theta>\<^sub>s = \<theta>\<^sub>s' \<cdot> (s\<^sub>0 \<star> ?\<gamma>\<^sub>s')"
	+ using \<gamma>' \<open>hseq p\<^sub>0 \<gamma>'\<close> \<sigma>.leg0_simps(2,4-5) \<sigma>.leg1_simps(3) \<theta>\<^sub>s'_def \<theta>\<^sub>s_def
	+ assoc'_naturality hseqE in_homE comp_assoc r\<^sub>0s\<^sub>1.leg0_simps(4-5)
	+ r\<^sub>0s\<^sub>1.p\<^sub>0_simps
	+ by metis
	+ moreover have "\<beta>\<^sub>s = s\<^sub>1 \<star> ?\<gamma>\<^sub>s'"
	+ proof -
	+ have "\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> \<gamma>\<^sub>r) \<cdot>
	+ \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w] =
	+ \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>')) \<cdot>
	+ \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
	+ using eq\<^sub>r comp_assoc by simp
	+ also have "... = \<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>')) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w'] \<cdot> (r\<^sub>0 \<star> p\<^sub>1 \<star> \<gamma>') = ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') \<cdot> \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w]"
	+ using \<gamma>' assoc'_naturality \<open>hseq p\<^sub>1 \<gamma>'\<close>
	+ by (metis \<rho>.leg0_simps(2,4-5) \<rho>.leg1_simps(3)
	+ r\<^sub>0s\<^sub>1.leg1_simps(5-6) hseqE in_homE leg1_simps(2))
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>')) \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
	+ proof -
	+ have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') = r\<^sub>0s\<^sub>1.\<phi> \<star> \<gamma>'"
	+ using \<gamma>' interchange [of r\<^sub>0s\<^sub>1.\<phi> "r\<^sub>0 \<star> p\<^sub>1" w' \<gamma>']
	+ comp_arr_dom comp_cod_arr
	+ by auto
	+ also have "... = ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
	+ using \<gamma>' interchange \<open>hseq p\<^sub>0 \<gamma>'\<close> comp_arr_dom comp_cod_arr
	+ by (metis in_homE r\<^sub>0s\<^sub>1.\<phi>_simps(1,5))
	+ finally have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w') \<cdot> ((r\<^sub>0 \<star> p\<^sub>1) \<star> \<gamma>') =
	+ ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') \<cdot> (r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (s\<^sub>1 \<star> ?\<gamma>\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w] \<cdot> ((r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot>
	+ \<a>[r\<^sub>0, p\<^sub>1, w]) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)) \<cdot> \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
	+ proof -
	+ have "\<a>[s\<^sub>1, p\<^sub>0, w'] \<cdot> ((s\<^sub>1 \<star> p\<^sub>0) \<star> \<gamma>') = (s\<^sub>1 \<star> ?\<gamma>\<^sub>s') \<cdot> \<a>[s\<^sub>1, p\<^sub>0, w]"
	+ using \<gamma>' assoc_naturality [of s\<^sub>1 p\<^sub>0 \<gamma>'] \<open>hseq p\<^sub>0 \<gamma>'\<close> by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = s\<^sub>1 \<star> ?\<gamma>\<^sub>s'"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r\<^sub>0, p\<^sub>1, w] \<cdot> \<a>[r\<^sub>0, p\<^sub>1, w] = cod (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w)"
	+ using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) \<rho>.T0.antipar(1) hseqI' comp_assoc_assoc'
	+ by simp
	+ text \<open>Here the fact that \<open>\<phi>\<close> is a retraction is used.\<close>
	+ moreover have "(r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) = cod \<a>\<^sup>-\<^sup>1[s\<^sub>1, p\<^sub>0, w]"
	+ using r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) comp_arr_inv'
	+ whisker_right [of w r\<^sub>0s\<^sub>1.\<phi> "inv r\<^sub>0s\<^sub>1.\<phi>"]
	+ by simp
	+ moreover have "cod (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) \<cdot> (inv r\<^sub>0s\<^sub>1.\<phi> \<star> w) = inv r\<^sub>0s\<^sub>1.\<phi> \<star> w"
	+ using \<beta>\<^sub>s_def \<beta>\<^sub>s
	+ by (meson arrI comp_cod_arr seqE)
	+ ultimately show ?thesis
	+ using \<gamma>' \<open>hseq p\<^sub>0 \<gamma>'\<close> comp_arr_dom comp_cod_arr comp_assoc_assoc'
	+ whisker_left [of s\<^sub>1 "p\<^sub>0 \<star> \<gamma>'" "p\<^sub>0 \<star> w"] whisker_left [of p\<^sub>0]
	+ by auto
	+ qed
	+ finally show ?thesis
	+ using \<beta>\<^sub>s_def by simp
	+ qed
	+ ultimately have P\<^sub>s': "?P\<^sub>s ?\<gamma>\<^sub>s'"
	+ by simp
	+ have eq\<^sub>s: "\<gamma>\<^sub>s = ?\<gamma>\<^sub>s'"
	+ using 2 \<gamma>\<^sub>s P\<^sub>s' by blast
	+ have "?P\<^sub>t \<gamma>'"
	+ using \<gamma>' comp_cod_arr \<open>\<guillemotleft>p\<^sub>0 \<star> \<gamma>' : p\<^sub>0 \<star> w \<Rightarrow> p\<^sub>0 \<star> w'\<guillemotright>\<close> eq\<^sub>r eq\<^sub>s by auto
	+ thus "\<gamma>' = \<gamma>"
	+ using 3 \<gamma> by blast
	+ qed
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ sublocale composite_tabulation_in_maps \<subseteq>
	+ tabulation V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close>
	+ using composite_is_tabulation by simp
	+
	+ sublocale composite_tabulation_in_maps \<subseteq>
	+ tabulation_in_maps V H \<a> \<i> src trg \<open>r \<star> s\<close> tab \<open>s\<^sub>0 \<star> p\<^sub>0\<close> \<open>r\<^sub>1 \<star> p\<^sub>1\<close>
	+ using T0.is_map \<rho>.leg1_is_map \<rho>.T0.antipar(2) composable \<rho>.leg1_is_map \<rho>.T0.antipar
	+ apply unfold_locales
	+ apply simp
	+ apply (intro left_adjoints_compose)
	+ by auto
	+
	+ subsection "The Classifying Category of Maps"
	+
	+ text \<open>
	+ \sloppypar
	+ We intend to show that if \<open>B\<close> is a bicategory of spans, then \<open>B\<close> is biequivalent to
	+ \<open>Span(Maps(B))\<close>, for a specific category \<open>Maps(B)\<close> derived from \<open>B\<close>.
	+ The category \<open>Maps(B)\<close> is constructed in this section as the ``classifying category'' of
	+ maps of \<open>B\<close>, which has the same objects as \<open>B\<close> and which has as 1-cells the isomorphism classes
	+ of maps of \<open>B\<close>. We show that, if \<open>B\<close> is a bicategory of spans, then \<open>Maps(B)\<close> has pullbacks.
	+ \<close>
	+
	+ locale maps_category =
	+ B: bicategory_of_spans
	+ begin
	+
	+ no_notation B.in_hhom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+ no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
	+ notation B.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
	+ notation B.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>B _\<guillemotright>")
	+ notation B.isomorphic (infix "\<cong>\<^sub>B" 50)
	+ notation B.iso_class ("\<lbrakk>_\<rbrakk>\<^sub>B")
	+
	+ text \<open>
	+ I attempted to modularize the construction here, by refactoring ``classifying category''
	+ out as a separate locale, but it ended up causing extra work because to apply it we
	+ first need to obtain the full sub-bicategory of 2-cells between maps, then construct its
	+ classifying category, and then we have to re-prove everything about it, to get rid of
	+ any mention of the sub-bicategory construction. So the construction is being done
	+ here as a ``one-off'' special case construction, with the necessary properties proved
	+ just once.
	+ \<close>
	+
	+ text \<open>
	+ The ``hom-categories'' of \<open>Maps(C)\<close> have as arrows the isomorphism classes of maps of \<open>B\<close>.
	+ \<close>
	+
	+ abbreviation Hom
	+ where "Hom a b \<equiv> {F. \<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B}"
	+
	+ lemma in_HomD:
	+ assumes "F \<in> Hom a b"
	+ shows "F \<noteq> {}"
	+ and "B.is_iso_class F"
	+ and "f \<in> F \<Longrightarrow> B.ide f"
	+ and "f \<in> F \<Longrightarrow> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright>"
	+ and "f \<in> F \<Longrightarrow> B.is_left_adjoint f"
	+ and "f \<in> F \<Longrightarrow> F = \<lbrakk>f\<rbrakk>\<^sub>B"
	+ proof -
	+ show "F \<noteq> {}"
	+ using assms B.ide_in_iso_class B.left_adjoint_is_ide B.iso_class_is_nonempty by auto
	+ show 1: "B.is_iso_class F"
	+ using assms B.is_iso_classI B.left_adjoint_is_ide by fastforce
	+ show "f \<in> F \<Longrightarrow> B.ide f"
	+ using assms 1 B.iso_class_memb_is_ide by blast
	+ obtain f' where f': "\<guillemotleft>f' : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f' \<and> F = \<lbrakk>f'\<rbrakk>\<^sub>B"
	+ using assms by auto
	+ show "f \<in> F \<Longrightarrow> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright>"
	+ using assms f' B.iso_class_def B.isomorphic_implies_hpar by auto
	+ show "f \<in> F \<Longrightarrow> B.is_left_adjoint f"
	+ using assms f' B.iso_class_def B.left_adjoint_preserved_by_iso [of f'] by auto
	+ show "f \<in> F \<Longrightarrow> F = \<lbrakk>f\<rbrakk>\<^sub>B"
	+ by (metis B.adjoint_pair_antipar(1) f' B.ide_in_iso_class B.is_iso_classI
	+ B.iso_class_elems_isomorphic B.iso_class_eqI)
	+ qed
	+
	+ definition Comp
	+ where "Comp G F \<equiv> {h. B.is_iso_class F \<and> B.is_iso_class G \<and>
	+ (\<exists>f g. f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h)}"
	+
	+ lemma in_CompI [intro]:
	+ assumes "B.is_iso_class F" and "B.is_iso_class G"
	+ and "f \<in> F" and "g \<in> G" and "g \<star> f \<cong>\<^sub>B h"
	+ shows "h \<in> Comp G F"
	+ unfolding Comp_def
	+ using assms by auto
	+
	+ lemma in_CompE [elim]:
	+ assumes "h \<in> Comp G F"
	+ and "\<And>f g. \<lbrakk> B.is_iso_class F; B.is_iso_class G; f \<in> F; g \<in> G; g \<star> f \<cong>\<^sub>B h \<rbrakk> \<Longrightarrow> T"
	+ shows T
	+ using assms Comp_def by auto
	+
	+ lemma is_iso_class_Comp:
	+ assumes "Comp G F \<noteq> {}"
	+ shows "B.is_iso_class (Comp G F)"
	+ proof -
	+ obtain h where h: "h \<in> Comp G F"
	+ using assms by auto
	+ have ide_h: "B.ide h"
	+ using h Comp_def B.isomorphic_implies_hpar(2) by auto
	+ obtain f g where fg: "B.is_iso_class F \<and> B.is_iso_class G \<and> f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
	+ using h Comp_def by auto
	+ have "Comp G F = \<lbrakk>g \<star> f\<rbrakk>\<^sub>B \<and> B.ide (g \<star> f)"
	+ proof (intro conjI)
	+ show "B.ide (g \<star> f)"
	+ using fg B.iso_class_memb_is_ide B.isomorphic_implies_ide(1) by auto
	+ show "Comp G F = \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
	+ proof
	+ show "\<lbrakk>g \<star> f\<rbrakk>\<^sub>B \<subseteq> Comp G F"
	+ unfolding Comp_def B.iso_class_def
	+ using fg by auto
	+ show "Comp G F \<subseteq> \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
	+ proof
	+ fix h'
	+ assume h': "h' \<in> Comp G F"
	+ obtain f' g' where f'g': "f' \<in> F \<and> g' \<in> G \<and> g' \<star> f' \<cong>\<^sub>B h'"
	+ using h' Comp_def by auto
	+ have 1: "f' \<cong>\<^sub>B f \<and> g' \<cong>\<^sub>B g"
	+ using f'g' fg B.iso_class_elems_isomorphic by auto
	+ moreover have "B.ide f \<and> B.ide f' \<and> B.ide g \<and> B.ide g'"
	+ using 1 B.isomorphic_implies_hpar by auto
	+ ultimately have "g' \<star> f' \<cong>\<^sub>B g \<star> f"
	+ using f'g' fg B.hcomp_isomorphic_ide B.hcomp_ide_isomorphic
	+ B.isomorphic_transitive B.isomorphic_implies_hpar
	+ by (meson B.hseqE B.ideD(1))
	+ hence "h' \<cong>\<^sub>B g \<star> f"
	+ using f'g' B.isomorphic_symmetric B.isomorphic_transitive by blast
	+ thus "h' \<in> B.iso_class (g \<star> f)"
	+ using B.iso_class_def B.isomorphic_symmetric by simp
	+ qed
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms B.is_iso_class_def B.ide_in_iso_class by auto
	+ qed
	+
	+ lemma Comp_is_extensional:
	+ assumes "Comp G F \<noteq> {}"
	+ shows "B.is_iso_class F" and "B.is_iso_class G"
	+ and "F \<noteq> {}" and "G \<noteq> {}"
	+ using assms Comp_def by auto
	+
	+ lemma Comp_eqI [intro]:
	+ assumes "h \<in> Comp G F" and "h' \<in> Comp G' F'" and "h \<cong>\<^sub>B h'"
	+ shows "Comp G F = Comp G' F'"
	+ proof -
	+ obtain f g where fg: "f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
	+ using assms comp_def by auto
	+ obtain f' g' where f'g': "f' \<in> F' \<and> g' \<in> G' \<and> g' \<star> f' \<cong>\<^sub>B h'"
	+ using assms by auto
	+ have "h \<in> Comp G F \<inter> Comp G' F'"
	+ by (meson IntI assms in_CompE in_CompI B.isomorphic_symmetric B.isomorphic_transitive)
	+ hence "Comp G F \<inter> Comp G' F' \<noteq> {}"
	+ by auto
	+ thus ?thesis
	+ using assms is_iso_class_Comp
	+ by (metis empty_iff B.iso_class_eq)
	+ qed
	+
	+ lemma Comp_eq_iso_class_memb:
	+ assumes "h \<in> Comp G F"
	+ shows "Comp G F = \<lbrakk>h\<rbrakk>\<^sub>B"
	+ proof
	+ show "Comp G F \<subseteq> \<lbrakk>h\<rbrakk>\<^sub>B"
	+ proof
	+ fix h'
	+ assume h': "h' \<in> Comp G F"
	+ obtain f g where fg: "f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
	+ using assms by auto
	+ obtain f' g' where f'g': "f' \<in> F \<and> g' \<in> G \<and> g' \<star> f' \<cong>\<^sub>B h'"
	+ using h' by auto
	+ have "f \<cong>\<^sub>B f' \<and> g \<cong>\<^sub>B g'"
	+ using assms fg f'g' in_HomD(6) B.iso_class_elems_isomorphic by auto
	+ moreover have "B.ide f \<and> B.ide f' \<and> B.ide g \<and> B.ide g'"
	+ using assms fg f'g' in_HomD [of F] in_HomD [of G]
	+ by (meson calculation B.isomorphic_implies_ide(1) B.isomorphic_implies_ide(2))
	+ moreover have "src g = trg f \<and> src g = trg f' \<and> src g' = trg f \<and> src g' = trg f'"
	+ using fg f'g'
	+ by (metis B.seq_if_composable calculation(1) B.ideD(1)
	+ B.isomorphic_implies_hpar(1) B.isomorphic_implies_hpar(3) B.not_arr_null)
	+ ultimately have "g \<star> f \<cong>\<^sub>B g' \<star> f'"
	+ using fg f'g' B.hcomp_ide_isomorphic B.hcomp_isomorphic_ide B.isomorphic_transitive
	+ by metis
	+ thus "h' \<in> \<lbrakk>h\<rbrakk>\<^sub>B"
	+ using fg f'g' B.isomorphic_symmetric B.isomorphic_transitive B.iso_class_def [of h]
	+ by blast
	+ qed
	+ show "\<lbrakk>h\<rbrakk>\<^sub>B \<subseteq> Comp G F"
	+ proof (unfold B.iso_class_def Comp_def)
	+ obtain f g where 1: "f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h"
	+ using assms in_HomD Comp_def
	+ by (meson in_CompE)
	+ show "{h'. B.isomorphic h h'} \<subseteq>
	+ {h. B.is_iso_class F \<and> B.is_iso_class G \<and> (\<exists>f g. f \<in> F \<and> g \<in> G \<and> g \<star> f \<cong>\<^sub>B h)}"
	+ using assms 1 B.isomorphic_transitive by blast
	+ qed
	+ qed
	+
	+ interpretation concrete_category \<open>Collect B.obj\<close> Hom B.iso_class \<open>\<lambda>_ _ _. Comp\<close>
	+ proof
	+ show "\<And>a. a \<in> Collect B.obj \<Longrightarrow> \<lbrakk>a\<rbrakk>\<^sub>B \<in> Hom a a"
	+ by (metis (mono_tags, lifting) B.ide_in_hom(1) mem_Collect_eq B.objE
	+ B.obj_is_self_adjoint(1))
	+ show "\<And>a b c F G. \<lbrakk> a \<in> Collect B.obj; b \<in> Collect B.obj; c \<in> Collect B.obj;
	+ F \<in> Hom a b; G \<in> Hom b c \<rbrakk> \<Longrightarrow> Comp G F \<in> Hom a c"
	+ proof -
	+ fix a b c F G
	+ assume a: "a \<in> Collect B.obj" and b: "b \<in> Collect B.obj" and c: "c \<in> Collect B.obj"
	+ and F: "F \<in> Hom a b" and G: "G \<in> Hom b c"
	+ obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B"
	+ using F by blast
	+ obtain g where g: "\<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> B.is_left_adjoint g \<and> G = \<lbrakk>g\<rbrakk>\<^sub>B"
	+ using G by blast
	+ have "{h. B.is_iso_class F \<and> B.is_iso_class G \<and>
	+ (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)} =
	+ \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
	+ proof
	+ show "{h. B.is_iso_class F \<and> B.is_iso_class G \<and>
	+ (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)}
	+ \<subseteq> \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
	+ proof
	+ fix h
	+ assume "h \<in> {h. B.is_iso_class F \<and> B.is_iso_class G \<and>
	+ (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)}"
	+ hence h: "B.is_iso_class F \<and> B.is_iso_class G \<and>
	+ (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)"
	+ by simp
	+ show "h \<in> \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
	+ proof -
	+ obtain f' g' where f'g': "g' \<in> G \<and> f' \<in> F \<and> g' \<star> f' \<cong>\<^sub>B h"
	+ using h by auto
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : f \<Rightarrow>\<^sub>B f'\<guillemotright> \<and> B.iso \<phi>"
	+ using f f'g' F B.iso_class_def by auto
	+ obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : g \<Rightarrow>\<^sub>B g'\<guillemotright> \<and> B.iso \<psi>"
	+ using g f'g' G B.iso_class_def by auto
	+ have 1: "\<guillemotleft>\<psi> \<star> \<phi> : g \<star> f \<Rightarrow>\<^sub>B g' \<star> f'\<guillemotright>"
	+ using f g \<phi> \<psi> by auto
	+ moreover have "B.iso (\<psi> \<star> \<phi>)"
	+ using f g \<phi> \<psi> 1 B.iso_hcomp by auto
	+ ultimately show ?thesis
	+ using f'g' B.iso_class_def B.isomorphic_def by auto
	+ qed
	+ qed
	+ show "\<lbrakk>g \<star> f\<rbrakk>\<^sub>B \<subseteq> {h. B.is_iso_class F \<and> B.is_iso_class G \<and>
	+ (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B h)}"
	+ using f g B.iso_class_def B.isomorphic_reflexive B.left_adjoint_is_ide B.is_iso_classI
	+ by blast
	+ qed
	+ hence 1: "\<And>gf. gf \<in> B.iso_class (g \<star> f) \<Longrightarrow>
	+ B.is_iso_class F \<and> B.is_iso_class G \<and>
	+ (\<exists>f g. f \<in> F \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> g \<in> G \<and> \<guillemotleft>g : b \<rightarrow>\<^sub>B c\<guillemotright> \<and> g \<star> f \<cong>\<^sub>B gf)"
	+ by blast
	+ show "Comp G F \<in> Hom a c"
	+ proof -
	+ have gf: "B.is_left_adjoint (g \<star> f)"
	+ by (meson f g B.hseqE B.hseqI B.left_adjoints_compose)
	+ obtain gf' where gf': "B.adjoint_pair (g \<star> f) gf'"
	+ using gf by blast
	+ hence "\<lbrakk>g \<star> f\<rbrakk>\<^sub>B = Comp G F"
	+ using 1 Comp_eq_iso_class_memb B.ide_in_iso_class B.left_adjoint_is_ide by blast
	+ thus ?thesis
	+ using f g gf' by blast
	+ qed
	+ qed
	+ show "\<And>a b F. \<lbrakk> a \<in> Collect B.obj; F \<in> Hom a b \<rbrakk> \<Longrightarrow> Comp F \<lbrakk>a\<rbrakk>\<^sub>B = F"
	+ proof -
	+ fix a b F
	+ assume a: "a \<in> Collect B.obj"
	+ assume F: "F \<in> Hom a b"
	+ obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B"
	+ using F by auto
	+ have *: "\<And>f'. f' \<in> F \<Longrightarrow> \<guillemotleft>f' : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f' \<and> f \<cong>\<^sub>B f'"
	+ using f B.iso_class_def by force
	+ show "Comp F \<lbrakk>a\<rbrakk>\<^sub>B = F"
	+ proof
	+ show "Comp F \<lbrakk>a\<rbrakk>\<^sub>B \<subseteq> F"
	+ proof
	+ fix h
	+ assume "h \<in> Comp F \<lbrakk>a\<rbrakk>\<^sub>B"
	+ hence h: "\<exists>f' a'. f' \<in> F \<and> a' \<in> \<lbrakk>a\<rbrakk>\<^sub>B \<and> f' \<star> a' \<cong>\<^sub>B h"
	+ unfolding Comp_def by auto
	+ obtain f' a' where f'a': "f' \<in> F \<and> a' \<in> \<lbrakk>a\<rbrakk>\<^sub>B \<and> f' \<star> a' \<cong>\<^sub>B h"
	+ using h by auto
	+ have "B.isomorphic f h"
	+ proof -
	+ have "B.isomorphic f (f \<star> a)"
	+ using f B.iso_runit' [of f] B.isomorphic_def B.left_adjoint_is_ide
	+ by blast
	+ also have "f \<star> a \<cong>\<^sub>B f' \<star> a"
	+ using f f'a' B.iso_class_def B.hcomp_isomorphic_ide
	+ apply (elim conjE B.in_hhomE) by auto
	+ also have "f' \<star> a \<cong>\<^sub>B f' \<star> a'"
	+ using f'a' * [of f'] B.iso_class_def B.hcomp_ide_isomorphic by auto
	+ also have "f' \<star> a' \<cong>\<^sub>B h"
	+ using f'a' by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus "h \<in> F"
	+ using f B.iso_class_def by simp
	+ qed
	+ show "F \<subseteq> Comp F \<lbrakk>a\<rbrakk>\<^sub>B"
	+ proof
	+ fix h
	+ assume h: "h \<in> F"
	+ have "f \<in> F"
	+ using f B.iso_class_def B.right_adjoint_determines_left_up_to_iso by auto
	+ moreover have "a \<in> B.iso_class a"
	+ using a B.iso_class_def B.isomorphic_reflexive by auto
	+ moreover have "f \<star> a \<cong>\<^sub>B h"
	+ proof -
	+ have "f \<star> a \<cong>\<^sub>B f"
	+ using f B.iso_runit [of f] B.isomorphic_def B.left_adjoint_is_ide by blast
	+ also have "f \<cong>\<^sub>B h"
	+ using h * by simp
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show "h \<in> Comp F \<lbrakk>a\<rbrakk>\<^sub>B"
	+ unfolding Comp_def
	+ using a f F B.is_iso_classI B.left_adjoint_is_ide by auto
	+ qed
	+ qed
	+ qed
	+ show "\<And>a b F. \<lbrakk> b \<in> Collect B.obj; F \<in> Hom a b \<rbrakk> \<Longrightarrow> Comp \<lbrakk>b\<rbrakk>\<^sub>B F = F"
	+ proof -
	+ fix a b F
	+ assume b: "b \<in> Collect B.obj"
	+ assume F: "F \<in> Hom a b"
	+ obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.is_left_adjoint f \<and> F = \<lbrakk>f\<rbrakk>\<^sub>B"
	+ using F by auto
	+ have *: "\<And>f'. f' \<in> F \<Longrightarrow> \<guillemotleft>f' : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f' \<and> f \<cong>\<^sub>B f'"
	+ using f B.iso_class_def by force
	+ show "Comp \<lbrakk>b\<rbrakk>\<^sub>B F = F"
	+ proof
	+ show "Comp \<lbrakk>b\<rbrakk>\<^sub>B F \<subseteq> F"
	+ proof
	+ fix h
	+ assume "h \<in> Comp \<lbrakk>b\<rbrakk>\<^sub>B F"
	+ hence h: "\<exists>b' f'. b' \<in> \<lbrakk>b\<rbrakk>\<^sub>B \<and> f' \<in> F \<and> b' \<star> f' \<cong>\<^sub>B h"
	+ unfolding Comp_def by auto
	+ obtain b' f' where b'f': "b' \<in> \<lbrakk>b\<rbrakk>\<^sub>B \<and> f' \<in> F \<and> b' \<star> f' \<cong>\<^sub>B h"
	+ using h by auto
	+ have "f \<cong>\<^sub>B h"
	+ proof -
	+ have "f \<cong>\<^sub>B b \<star> f"
	+ using f B.iso_lunit' [of f] B.isomorphic_def B.left_adjoint_is_ide
	+ by blast
	+ also have "... \<cong>\<^sub>B b \<star> f'"
	+ using f b'f' B.iso_class_def B.hcomp_ide_isomorphic
	+ by (elim conjE B.in_hhomE, auto)
	+ also have "... \<cong>\<^sub>B b' \<star> f'"
	+ using b'f' * [of f'] B.iso_class_def B.hcomp_isomorphic_ide by auto
	+ also have "... \<cong>\<^sub>B h"
	+ using b'f' by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus "h \<in> F"
	+ using f B.iso_class_def by simp
	+ qed
	+ show "F \<subseteq> Comp \<lbrakk>b\<rbrakk>\<^sub>B F"
	+ proof
	+ fix h
	+ assume h: "h \<in> F"
	+ have "f \<in> F"
	+ using f B.iso_class_def B.right_adjoint_determines_left_up_to_iso by auto
	+ moreover have "b \<in> B.iso_class b"
	+ using b B.iso_class_def B.isomorphic_reflexive by auto
	+ moreover have "b \<star> f \<cong>\<^sub>B h"
	+ proof -
	+ have "b \<star> f \<cong>\<^sub>B f"
	+ using f B.iso_lunit [of f] B.isomorphic_def B.left_adjoint_is_ide
	+ by blast
	+ also have "f \<cong>\<^sub>B h"
	+ using h * by simp
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show "h \<in> Comp \<lbrakk>b\<rbrakk>\<^sub>B F"
	+ unfolding Comp_def
	+ using b f F B.is_iso_classI B.left_adjoint_is_ide by auto
	+ qed
	+ qed
	+ qed
	+ show "\<And>a b c d F G H.
	+ \<lbrakk> a \<in> Collect B.obj; b \<in> Collect B.obj; c \<in> Collect B.obj; d \<in> Collect B.obj;
	+ F \<in> Hom a b; G \<in> Hom b c; H \<in> Hom c d \<rbrakk> \<Longrightarrow>
	+ Comp H (Comp G F) = Comp (Comp H G) F"
	+ proof -
	+ fix a b c d F G H
	+ assume F: "F \<in> Hom a b" and G: "G \<in> Hom b c" and H: "H \<in> Hom c d"
	+ show "Comp H (Comp G F) = Comp (Comp H G) F"
	+ proof
	+ show "Comp H (Comp G F) \<subseteq> Comp (Comp H G) F"
	+ proof
	+ fix x
	+ assume x: "x \<in> Comp H (Comp G F)"
	+ obtain f g h gf
	+ where 1: "B.is_iso_class F \<and> B.is_iso_class G \<and> B.is_iso_class H \<and>
	+ h \<in> H \<and> g \<in> G \<and> f \<in> F \<and> gf \<in> Comp G F \<and> g \<star> f \<cong>\<^sub>B gf \<and> h \<star> gf \<cong>\<^sub>B x"
	+ using x unfolding Comp_def by blast
	+ have hgf: "B.ide f \<and> B.ide g \<and> B.ide h"
	+ using 1 F G H B.isomorphic_implies_hpar in_HomD B.left_adjoint_is_ide
	+ by (metis (mono_tags, lifting))
	+ have "h \<star> g \<star> f \<cong>\<^sub>B x"
	+ proof -
	+ have "h \<star> g \<star> f \<cong>\<^sub>B h \<star> gf"
	+ using 1 hgf B.hcomp_ide_isomorphic
	+ by (metis (full_types) B.isomorphic_implies_hpar(1) B.isomorphic_reflexive
	+ B.isomorphic_symmetric B.seq_if_composable)
	+ also have "h \<star> gf \<cong>\<^sub>B x"
	+ using 1 by simp
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "(h \<star> g) \<star> f \<cong>\<^sub>B h \<star> g \<star> f"
	+ using 1 hgf B.iso_assoc B.assoc_in_hom B.isomorphic_def
	+ by (metis B.hseq_char B.ideD(1-3) B.isomorphic_implies_hpar(1)
	+ B.trg_hcomp' calculation)
	+ moreover have hg: "\<guillemotleft>h \<star> g : b \<rightarrow>\<^sub>B d\<guillemotright>"
	+ using G H 1 in_HomD(4) by blast
	+ moreover have "h \<star> g \<in> Comp H G"
	+ unfolding Comp_def
	+ using 1 hgf F G H in_HomD [of F a b] in_HomD [of G b c] in_HomD [of H c d]
	+ B.isomorphic_reflexive B.hcomp_ide_isomorphic B.hseqI'
	+ by (metis (no_types, lifting) B.hseqE B.hseqI mem_Collect_eq)
	+ ultimately show "x \<in> Comp (Comp H G) F"
	+ using 1 F G H hgf B.is_iso_class_def is_iso_class_Comp [of H G]
	+ B.isomorphic_reflexive [of "h \<star> g"]
	+ apply (intro in_CompI)
	+ apply auto[7]
	+ apply blast
	+ apply simp
	+ by (meson B.isomorphic_symmetric B.isomorphic_transitive)
	+ qed
	+ show "Comp (Comp H G) F \<subseteq> Comp H (Comp G F)"
	+ proof
	+ fix x
	+ assume x: "x \<in> Comp (Comp H G) F"
	+ obtain f g h hg
	+ where 1: "B.is_iso_class F \<and> B.is_iso_class G \<and> B.is_iso_class H \<and>
	+ h \<in> H \<and> g \<in> G \<and> f \<in> F \<and> hg \<in> Comp H G \<and> h \<star> g \<cong>\<^sub>B hg \<and> hg \<star> f \<cong>\<^sub>B x"
	+ using x unfolding Comp_def by blast
	+ have hgf: "B.ide f \<and> B.ide g \<and> B.ide h \<and> src h = trg g \<and> src g = trg f"
	+ using 1 F G H in_HomD B.left_adjoint_is_ide
	+ by (metis (no_types, lifting) B.hseq_char' B.ideD(1) B.ide_dom
	+ B.in_homE B.isomorphic_def B.isomorphic_symmetric B.seqI'
	+ B.seq_if_composable B.src_dom B.src_hcomp' B.vseq_implies_hpar(1))
	+ have 2: "(h \<star> g) \<star> f \<cong>\<^sub>B x"
	+ proof -
	+ have "(h \<star> g) \<star> f \<cong>\<^sub>B hg \<star> f"
	+ using 1 F G H hgf
	+ by (simp add: B.hcomp_isomorphic_ide)
	+ also have "hg \<star> f \<cong>\<^sub>B x"
	+ using 1 by simp
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "(h \<star> g) \<star> f \<cong>\<^sub>B h \<star> g \<star> f"
	+ using hgf B.iso_assoc B.assoc_in_hom B.isomorphic_def by auto
	+ moreover have "g \<star> f \<in> Comp G F"
	+ using 1 F G hgf B.isomorphic_reflexive by blast
	+ ultimately show "x \<in> Comp H (Comp G F)"
	+ using 1 hgf is_iso_class_Comp [of G F] B.isomorphic_reflexive [of "g \<star> f"]
	+ apply (intro in_CompI)
	+ apply auto[6]
	+ apply simp
	+ apply auto[1]
	+ by (meson B.isomorphic_symmetric B.isomorphic_transitive)
	+ qed
	+ qed
	+ qed
	+ qed
	+
	+ lemma is_concrete_category:
	+ shows "concrete_category (Collect B.obj) Hom B.iso_class (\<lambda>_ _ _. Comp)"
	+ ..
	+
	+ sublocale concrete_category \<open>Collect B.obj\<close> Hom B.iso_class \<open>\<lambda>_ _ _. Comp\<close>
	+ using is_concrete_category by simp
	+
	+ notation comp (infixr "\<odot>" 55)
	+ notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+ no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
	+
	+ lemma Map_memb_in_hhom:
	+ assumes "\<guillemotleft>F : A \<rightarrow> B\<guillemotright>" and "f \<in> Map F"
	+ shows "\<guillemotleft>f : Dom A \<rightarrow>\<^sub>B Dom B\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>f : Dom F \<rightarrow>\<^sub>B Cod F\<guillemotright>"
	+ using assms arr_char [of F] in_HomD [of "Map F" "Dom F" "Cod F"] by blast
	+ moreover have "Dom F = Dom A"
	+ using assms by auto
	+ moreover have "Cod F = Dom B"
	+ using assms by auto
	+ ultimately show ?thesis by simp
	+ qed
	+
	+ lemma MkArr_in_hom':
	+ assumes "B.is_left_adjoint f" and "\<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright>"
	+ shows "\<guillemotleft>MkArr a b \<lbrakk>f\<rbrakk>\<^sub>B : MkIde a \<rightarrow> MkIde b\<guillemotright>"
	+ using assms MkArr_in_hom by blast
	+
	+ text \<open>
	+ The isomorphisms in \<open>Maps(B)\<close> are the isomorphism classes of equivalence maps in \<open>B\<close>.
	+ \<close>
	+
	+ lemma iso_char:
	+ shows "iso F \<longleftrightarrow> arr F \<and> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
	+ proof
	+ assume F: "iso F"
	+ have "\<And>f. f \<in> Map F \<Longrightarrow> B.equivalence_map f"
	+ proof -
	+ fix f
	+ assume f: "f \<in> Map F"
	+ obtain G where G: "inverse_arrows F G"
	+ using F by auto
	+ obtain g where g: "g \<in> Map G"
	+ using G arr_char [of G] in_HomD(1) by blast
	+ have f: "f \<in> Map F \<and> \<guillemotleft>f : Dom F \<rightarrow>\<^sub>B Cod F\<guillemotright> \<and> B.ide f \<and> B.is_left_adjoint f"
	+ by (metis (mono_tags, lifting) F iso_is_arr is_concrete_category
	+ concrete_category.arr_char f in_HomD(2,4-5) B.iso_class_memb_is_ide)
	+ have g: "g \<in> Map G \<and> \<guillemotleft>g : Cod F \<rightarrow>\<^sub>B Dom F\<guillemotright> \<and> B.ide g \<and> B.is_left_adjoint g"
	+ by (metis (no_types, lifting) F G Cod_cod Cod_dom arr_inv cod_inv dom_inv
	+ inverse_unique iso_is_arr is_concrete_category concrete_category.Map_in_Hom
	+ g in_HomD(2,4-5) B.iso_class_memb_is_ide)
	+ have "src (g \<star> f) \<cong>\<^sub>B g \<star> f"
	+ proof -
	+ have "g \<star> f \<in> Map (G \<odot> F)"
	+ proof -
	+ have 1: "f \<in> Map F \<and> g \<in> Map G \<and> g \<star> f \<cong>\<^sub>B g \<star> f"
	+ using F G f g B.isomorphic_reflexive by force
	+ have 2: "Dom G = Cod F \<and> Cod G = Dom F"
	+ using F G arr_char
	+ by (metis (no_types, lifting) Cod.simps(1) Cod_dom arr_inv
	+ cod_char comp_inv_arr dom_inv inverse_unique
	+ iso_is_arr is_concrete_category concrete_category.Cod_comp)
	+ have "g \<star> f \<in> Comp (Map G) (Map F)"
	+ using 1 F iso_is_arr Map_in_Hom [of F] in_HomD(2)
	+ apply (intro in_CompI, auto)
	+ proof -
	+ show "B.is_iso_class (Map G)"
	+ using G iso_is_arr iso_inv_iso Map_in_Hom [of G] in_HomD(2) [of "Map G"] by blast
	+ qed
	+ thus ?thesis
	+ using F G f g comp_char [of G F] by auto
	+ qed
	+ moreover have "Dom F \<in> Map (G \<odot> F)"
	+ by (metis (no_types, lifting) F G Map_dom comp_inv_arr iso_is_arr
	+ g B.ide_in_iso_class B.in_hhomE B.objE)
	+ moreover have "Map (G \<odot> F) = \<lbrakk>Dom F\<rbrakk>\<^sub>B"
	+ by (simp add: F G comp_inv_arr iso_is_arr)
	+ moreover have "Dom F = src (g \<star> f)"
	+ using f g by fastforce
	+ ultimately show ?thesis
	+ using f g B.iso_class_elems_isomorphic B.is_iso_classI
	+ by (metis B.hseqI B.ide_src)
	+ qed
	+ moreover have "f \<star> g \<cong>\<^sub>B trg f"
	+ proof -
	+ have "f \<star> g \<in> Map (F \<odot> G)"
	+ proof -
	+ have 1: "f \<in> Map F \<and> g \<in> Map G \<and> f \<star> g \<cong>\<^sub>B f \<star> g"
	+ using F G f g B.isomorphic_reflexive by force
	+ have 2: "Dom G = Cod F \<and> Cod G = Dom F"
	+ using F G arr_char
	+ by (metis (no_types, lifting) Cod.simps(1) Cod_dom arr_inv
	+ cod_char comp_inv_arr dom_inv inverse_unique
	+ iso_is_arr is_concrete_category concrete_category.Cod_comp)
	+ hence "f \<star> g \<in> Comp (Map F) (Map G)"
	+ using 1 F iso_is_arr Map_in_Hom [of F] in_HomD(2)
	+ apply (intro in_CompI, auto)
	+ proof -
	+ show "B.is_iso_class (Map G)"
	+ using G iso_is_arr iso_inv_iso Map_in_Hom [of G] in_HomD(2) [of "Map G"] by blast
	+ qed
	+ thus ?thesis
	+ using F G f g comp_char [of F G] by auto
	+ qed
	+ moreover have "Cod F \<in> Map (F \<odot> G)"
	+ by (metis (no_types, lifting) F G Map_cod comp_arr_inv dom_inv
	+ inverse_unique iso_is_arr g B.ide_in_iso_class B.in_hhomE B.src.preserves_ide)
	+ moreover have "Map (F \<odot> G) = \<lbrakk>Cod F\<rbrakk>\<^sub>B"
	+ by (metis (no_types, lifting) F G Map_cod comp_arr_inv dom_inv
	+ inverse_unique iso_is_arr)
	+ moreover have "Cod F = trg (f \<star> g)"
	+ using f g by fastforce
	+ ultimately show ?thesis
	+ using B.iso_class_elems_isomorphic
	+ by (metis f g B.is_iso_classI B.in_hhomE B.src.preserves_ide)
	+ qed
	+ ultimately show "B.equivalence_map f"
	+ using f g B.equivalence_mapI by fastforce
	+ qed
	+ thus "arr F \<and> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
	+ using F by blast
	+ next
	+ assume F: "arr F \<and> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
	+ show "iso F"
	+ proof -
	+ obtain f where f: "f \<in> Map F"
	+ using F arr_char in_HomD(1) by blast
	+ have f_in_hhom: "\<guillemotleft>f : Dom F \<rightarrow>\<^sub>B Cod F\<guillemotright>"
	+ using f F arr_char in_HomD(4) [of "Map F" "Dom F" "Cod F" f] by simp
	+ have "Map F = B.iso_class f"
	+ using f F arr_char in_HomD(6) [of "Map F" "Dom F" "Cod F" f] by simp
	+ obtain g \<eta> \<epsilon>' where \<epsilon>': "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'"
	+ using f F B.equivalence_map_def by auto
	+ interpret \<epsilon>': equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'
	+ using \<epsilon>' by auto
	+ obtain \<epsilon> where \<epsilon>: "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using f F \<epsilon>'.ide_right \<epsilon>'.antipar \<epsilon>'.unit_in_hom \<epsilon>'.unit_is_iso B.equivalence_map_def
	+ B.equivalence_refines_to_adjoint_equivalence [of f g \<eta>]
	+ by auto
	+ interpret \<epsilon>: adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using \<epsilon> by simp
	+ have g_in_hhom: "\<guillemotleft>g : Cod F \<rightarrow>\<^sub>B Dom F\<guillemotright>"
	+ using \<epsilon>.ide_right \<epsilon>.antipar f_in_hhom by auto
	+ have fg: "B.equivalence_pair f g"
	+ using B.equivalence_pair_def \<epsilon>.equivalence_in_bicategory_axioms by auto
	+ have g: "\<guillemotleft>g : Cod F \<rightarrow>\<^sub>B Dom F\<guillemotright> \<and> B.is_left_adjoint g \<and> \<lbrakk>g\<rbrakk>\<^sub>B = \<lbrakk>g\<rbrakk>\<^sub>B"
	+ using \<epsilon>'.dual_equivalence B.equivalence_is_left_adjoint B.equivalence_map_def
	+ g_in_hhom
	+ by blast
	+ have F_as_MkArr: "F = MkArr (Dom F) (Cod F) \<lbrakk>f\<rbrakk>\<^sub>B"
	+ using F MkArr_Map \<open>Map F = B.iso_class f\<close> by fastforce
	+ have F_in_hom: "in_hom F (MkIde (Dom F)) (MkIde (Cod F))"
	+ using F arr_char dom_char cod_char
	+ by (intro in_homI, auto)
	+ let ?G = "MkArr (Cod F) (Dom F) \<lbrakk>g\<rbrakk>\<^sub>B"
	+ have "arr ?G"
	+ using MkArr_in_hom' g by blast
	+ hence G_in_hom: "\<guillemotleft>?G : MkIde (Cod F) \<rightarrow> MkIde (Dom F)\<guillemotright>"
	+ using arr_char MkArr_in_hom by simp
	+ have "inverse_arrows F ?G"
	+ proof
	+ show "ide (?G \<odot> F)"
	+ proof -
	+ have "?G \<odot> F = dom F"
	+ proof (intro arr_eqI)
	+ show 1: "seq ?G F"
	+ using F_in_hom G_in_hom by blast
	+ show "arr (dom F)"
	+ using F_in_hom ide_dom by fastforce
	+ show "Dom (?G \<odot> F) = Dom (dom F)"
	+ using F_in_hom G_in_hom 1 comp_char by auto
	+ show "Cod (?G \<odot> F) = Cod (dom F)"
	+ using F_in_hom G_in_hom 1 comp_char by auto
	+ show "Map (?G \<odot> F) = Map (dom F)"
	+ proof -
	+ have "Map (?G \<odot> F) = Comp \<lbrakk>g\<rbrakk>\<^sub>B \<lbrakk>f\<rbrakk>\<^sub>B"
	+ using 1 comp_char [of ?G F] `Map F = B.iso_class f` by simp
	+ also have "... = \<lbrakk>g \<star> f\<rbrakk>\<^sub>B"
	+ proof -
	+ have "g \<star> f \<in> Comp \<lbrakk>g\<rbrakk>\<^sub>B \<lbrakk>f\<rbrakk>\<^sub>B"
	+ by (metis \<epsilon>.ide_left \<epsilon>.ide_right \<epsilon>.unit_in_vhom \<epsilon>.unit_simps(3) B.arrI
	+ B.ide_cod B.ide_in_iso_class in_CompI B.is_iso_classI
	+ B.isomorphic_reflexive)
	+ thus ?thesis
	+ using Comp_eq_iso_class_memb F_in_hom G_in_hom arr_char arr_char
	+ `Map F = B.iso_class f`
	+ by auto
	+ qed
	+ also have "... = \<lbrakk>src f\<rbrakk>\<^sub>B"
	+ using \<epsilon>.unit_in_hom \<epsilon>.unit_is_iso B.isomorphic_def B.iso_class_def
	+ B.isomorphic_symmetric
	+ by (intro B.iso_class_eqI, blast)
	+ also have "... = \<lbrakk>Dom F\<rbrakk>\<^sub>B"
	+ using \<epsilon>.ide_left f_in_hhom B.ide_in_iso_class B.in_hhomE B.src.preserves_ide
	+ B.isomorphic_reflexive
	+ by (intro B.iso_class_eqI, fastforce)
	+ also have "... = Map (dom F)"
	+ using F_in_hom dom_char by auto
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ thus ?thesis
	+ using F by simp
	+ qed
	+ show "ide (F \<odot> ?G)"
	+ proof -
	+ have "F \<odot> ?G = cod F"
	+ proof (intro arr_eqI)
	+ show 1: "seq F ?G"
	+ using F_in_hom G_in_hom by blast
	+ show "arr (cod F)"
	+ using F_in_hom ide_cod by fastforce
	+ show "Dom (F \<odot> ?G) = Dom (cod F)"
	+ using F_in_hom G_in_hom 1 comp_char by auto
	+ show "Cod (F \<odot> ?G) = Cod (cod F)"
	+ using F_in_hom G_in_hom 1 comp_char by auto
	+ show "Map (F \<odot> ?G) = Map (cod F)"
	+ proof -
	+ have "Map (F \<odot> ?G) = Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
	+ using 1 comp_char [of F ?G] `Map F = \<lbrakk>f\<rbrakk>\<^sub>B` by simp
	+ also have "... = \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
	+ proof -
	+ have "f \<star> g \<in> Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
	+ by (metis \<epsilon>.antipar(1) \<epsilon>.ide_left \<epsilon>.ide_right B.ide_hcomp
	+ B.ide_in_iso_class in_CompI B.is_iso_classI B.isomorphic_reflexive)
	+ thus ?thesis
	+ using Comp_eq_iso_class_memb F_in_hom G_in_hom arr_char arr_char
	+ `Map F = \<lbrakk>f\<rbrakk>\<^sub>B`
	+ by auto
	+ qed
	+ also have "... = \<lbrakk>trg f\<rbrakk>\<^sub>B"
	+ proof -
	+ have "trg f \<in> \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
	+ using \<epsilon>.counit_in_hom \<epsilon>.counit_is_iso B.isomorphic_def B.iso_class_def
	+ B.isomorphic_symmetric
	+ by blast
	+ thus ?thesis
	+ using B.iso_class_eqI
	+ by (metis \<epsilon>.antipar(1) \<epsilon>.ide_left \<epsilon>.ide_right B.ide_hcomp
	+ B.ide_in_iso_class B.is_iso_classI B.iso_class_elems_isomorphic)
	+ qed
	+ also have "... = \<lbrakk>Cod F\<rbrakk>\<^sub>B"
	+ using f_in_hhom by auto
	+ also have "... = Map (cod F)"
	+ using F_in_hom dom_char by auto
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ thus ?thesis
	+ using F by simp
	+ qed
	+ qed
	+ thus ?thesis by auto
	+ qed
	+ qed
	+
	+ lemma iso_char':
	+ shows "iso F \<longleftrightarrow> arr F \<and> (\<exists>f. f \<in> Map F \<and> B.equivalence_map f)"
	+ proof -
	+ have "arr F \<Longrightarrow> (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f) \<longleftrightarrow>
	+ (\<exists>f. f \<in> Map F \<and> B.equivalence_map f)"
	+ proof
	+ assume F: "arr F"
	+ show "(\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f) \<Longrightarrow>
	+ (\<exists>f. f \<in> Map F \<and> B.equivalence_map f)"
	+ using F arr_char in_HomD(1) by blast
	+ show "(\<exists>f. f \<in> Map F \<and> B.equivalence_map f) \<Longrightarrow>
	+ (\<forall>f. f \<in> Map F \<longrightarrow> B.equivalence_map f)"
	+ by (metis (no_types, lifting) F is_concrete_category concrete_category.arr_char
	+ B.equivalence_map_preserved_by_iso in_HomD(2) B.iso_class_elems_isomorphic)
	+ qed
	+ thus ?thesis
	+ using iso_char by blast
	+ qed
	+
	+ text \<open>
	+ The following mapping takes a map in \<open>B\<close> to the corresponding arrow of \<open>Maps(B)\<close>.
	+ \<close>
	+
	+ abbreviation CLS ("\<lbrakk>\<lbrakk>_\<rbrakk>\<rbrakk>")
	+ where "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<equiv> MkArr (src f) (trg f) \<lbrakk>f\<rbrakk>\<^sub>B"
	+
	+ lemma ide_CLS_obj:
	+ assumes "B.obj a"
	+ shows "ide \<lbrakk>\<lbrakk>a\<rbrakk>\<rbrakk>"
	+ by (simp add: assms)
	+
	+ lemma CLS_in_hom:
	+ assumes "B.is_left_adjoint f"
	+ shows "\<guillemotleft>\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> : \<lbrakk>\<lbrakk>src f\<rbrakk>\<rbrakk> \<rightarrow> \<lbrakk>\<lbrakk>trg f\<rbrakk>\<rbrakk>\<guillemotright>"
	+ using assms B.left_adjoint_is_ide MkArr_in_hom MkArr_in_hom' by simp
	+
	+ lemma CLS_eqI:
	+ assumes "B.ide f"
	+ shows "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk> \<longleftrightarrow> f \<cong>\<^sub>B g"
	+ by (metis arr.inject assms B.ide_in_iso_class B.iso_class_def B.iso_class_eqI
	+ B.isomorphic_implies_hpar(3) B.isomorphic_implies_hpar(4) B.isomorphic_symmetric
	+ mem_Collect_eq)
	+
	+ lemma CLS_hcomp:
	+ assumes "B.ide f" and "B.ide g" and "src f = trg g"
	+ shows "\<lbrakk>\<lbrakk>f \<star> g\<rbrakk>\<rbrakk> = MkArr (src g) (trg f) (Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B)"
	+ proof -
	+ have "\<lbrakk>\<lbrakk>f \<star> g\<rbrakk>\<rbrakk> = MkArr (src g) (trg f) \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
	+ using assms B.left_adjoint_is_ide by simp
	+ moreover have "\<lbrakk>f \<star> g\<rbrakk>\<^sub>B = Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
	+ proof
	+ show "\<lbrakk>f \<star> g\<rbrakk>\<^sub>B \<subseteq> Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B"
	+ by (metis assms(1-2) B.ide_in_iso_class in_CompI B.is_iso_classI
	+ B.iso_class_def mem_Collect_eq subsetI)
	+ show "Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B \<subseteq> \<lbrakk>f \<star> g\<rbrakk>\<^sub>B"
	+ by (metis Comp_eq_iso_class_memb \<open>\<lbrakk>f \<star> g\<rbrakk>\<^sub>B \<subseteq> Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B\<close>
	+ assms(1-3) B.ide_hcomp B.ide_in_iso_class subset_iff)
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+
	+ lemma comp_CLS:
	+ assumes "B.is_left_adjoint f" and "B.is_left_adjoint g" and "f \<star> g \<cong>\<^sub>B h"
	+ shows "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>h\<rbrakk>\<rbrakk>"
	+ proof -
	+ have hseq_fg: "B.hseq f g"
	+ using assms B.isomorphic_implies_hpar(1) by simp
	+ have "seq \<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk>"
	+ using assms hseq_fg CLS_in_hom [of f] CLS_in_hom [of g]
	+ apply (elim B.hseqE) by auto
	+ hence "\<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>g\<rbrakk>\<rbrakk> = MkArr (src g) (trg f) (Comp \<lbrakk>f\<rbrakk>\<^sub>B \<lbrakk>g\<rbrakk>\<^sub>B)"
	+ using comp_char [of "CLS f" "CLS g"] by simp
	+ also have "... = \<lbrakk>\<lbrakk>f \<star> g\<rbrakk>\<rbrakk>"
	+ using assms hseq_fg CLS_hcomp
	+ apply (elim B.hseqE)
	+ using B.adjoint_pair_antipar(1) by auto
	+ also have "... = \<lbrakk>\<lbrakk>h\<rbrakk>\<rbrakk>"
	+ using assms B.isomorphic_symmetric
	+ by (simp add: assms(3) B.iso_class_eqI B.isomorphic_implies_hpar(3)
	+ B.isomorphic_implies_hpar(4))
	+ finally show ?thesis by simp
	+ qed
	+
	+ text \<open>
	+ The following mapping that takes an arrow of \<open>Maps(B)\<close> and chooses some
	+ representative map in \<open>B\<close>.
	+ \<close>
	+
	+ definition REP
	+ where "REP F \<equiv> if arr F then SOME f. f \<in> Map F else B.null"
	+
	+ lemma REP_in_Map:
	+ assumes "arr A"
	+ shows "REP A \<in> Map A"
	+ proof -
	+ have "Map A \<noteq> {}"
	+ using assms arr_char in_HomD(1) by blast
	+ thus ?thesis
	+ using assms REP_def someI_ex [of "\<lambda>f. f \<in> Map A"] by auto
	+ qed
	+
	+ lemma REP_in_hhom [intro]:
	+ assumes "in_hom F A B"
	+ shows "\<guillemotleft>REP F : src (REP A) \<rightarrow>\<^sub>B src (REP B)\<guillemotright>"
	+ and "B.is_left_adjoint (REP F)"
	+ proof -
	+ have "Map F \<noteq> {}"
	+ using assms in_hom_char arr_char null_char in_HomD(1) [of "Map F" "Dom F" "Cod F"]
	+ by blast
	+ hence 1: "REP F \<in> Map F"
	+ using assms REP_def someI_ex [of "\<lambda>f. f \<in> Map F"] by auto
	+ hence 2: "B.arr (REP F)"
	+ using assms 1 in_hom_char [of F A B] B.iso_class_def Map_memb_in_hhom B.in_hhom_def
	+ by blast
	+ hence "\<guillemotleft>REP F : Dom A \<rightarrow>\<^sub>B Dom B\<guillemotright>"
	+ using assms 1 in_hom_char [of F A B] Map_memb_in_hhom by auto
	+ thus "\<guillemotleft>REP F : src (REP A) \<rightarrow>\<^sub>B src (REP B)\<guillemotright>"
	+ using assms
	+ by (metis (no_types, lifting) Map_memb_in_hhom ideD(1)
	+ in_homI in_hom_char REP_in_Map B.in_hhom_def)
	+ have "REP F \<in> \<lbrakk>REP F\<rbrakk>\<^sub>B"
	+ using assms 1 2 arr_char [of F] in_HomD(6) B.ide_in_iso_class B.iso_class_memb_is_ide
	+ in_hom_char
	+ by blast
	+ thus "B.is_left_adjoint (REP F)"
	+ using assms 1 2 arr_char in_HomD(5) [of "Map F" "Dom F" "Cod F" "REP F"]
	+ by auto
	+ qed
	+
	+ lemma ide_REP:
	+ assumes "arr A"
	+ shows "B.ide (REP A)"
	+ using assms REP_in_hhom(2) B.adjoint_pair_antipar(1) by blast
	+
	+ lemma REP_simps [simp]:
	+ assumes "arr A"
	+ shows "B.ide (REP A)"
	+ and "src (REP A) = Dom A" and "trg (REP A) = Cod A"
	+ and "B.dom (REP A) = REP A" and "B.cod (REP A) = REP A"
	+ proof -
	+ show "B.ide (REP A)"
	+ using assms ide_REP by blast
	+ show "src (REP A) = Dom A"
	+ using assms REP_in_hhom
	+ by (metis (no_types, lifting) Map_memb_in_hhom Dom_dom in_homI
	+ REP_in_Map B.in_hhom_def)
	+ show "trg (REP A) = Cod A"
	+ using assms REP_in_hhom
	+ by (metis (no_types, lifting) Map_memb_in_hhom Dom_cod in_homI
	+ REP_in_Map B.in_hhom_def)
	+ show "B.dom (REP A) = REP A"
	+ using assms in_homI REP_in_hhom(2) B.adjoint_pair_antipar(1) B.ideD(2)
	+ by blast
	+ show "B.cod (REP A) = REP A"
	+ using assms in_homI REP_in_hhom(2) B.adjoint_pair_antipar(1) B.ideD(3)
	+ by blast
	+ qed
	+
	+ lemma isomorphic_REP_src:
	+ assumes "ide A"
	+ shows "REP A \<cong>\<^sub>B src (REP A)"
	+ using assms
	+ by (metis (no_types, lifting) ideD(1) ide_char REP_in_Map ide_REP
	+ REP_simps(2) B.is_iso_classI B.ide_in_iso_class B.iso_class_elems_isomorphic
	+ B.src.preserves_ide)
	+
	+ lemma isomorphic_REP_trg:
	+ assumes "ide A"
	+ shows "REP A \<cong>\<^sub>B trg (REP A)"
	+ using assms ide_char isomorphic_REP_src by auto
	+
	+ lemma CLS_REP:
	+ assumes "arr F"
	+ shows "\<lbrakk>\<lbrakk>REP F\<rbrakk>\<rbrakk> = F"
	+ by (metis (mono_tags, lifting) MkArr_Map
	+ is_concrete_category REP_in_Map REP_simps(2) REP_simps(3) assms
	+ concrete_category.Map_in_Hom in_HomD(6))
	+
	+ lemma REP_CLS:
	+ assumes "B.is_left_adjoint f"
	+ shows "REP \<lbrakk>\<lbrakk>f\<rbrakk>\<rbrakk> \<cong>\<^sub>B f"
	+ by (metis (mono_tags, lifting) CLS_in_hom Map.simps(1) in_homE REP_in_Map
	+ assms B.iso_class_def B.isomorphic_symmetric mem_Collect_eq)
	+
	+ lemma isomorphic_hcomp_REP:
	+ assumes "seq F G"
	+ shows "REP F \<star> REP G \<cong>\<^sub>B REP (F \<odot> G)"
	+ proof -
	+ have 1: "Dom F = Cod G"
	+ using assms seq_char by simp
	+ have 2: "Map F = B.iso_class (REP F)"
	+ using assms seq_char arr_char REP_in_Map in_HomD(6) by meson
	+ have 3: "Map G = B.iso_class (REP G)"
	+ using assms seq_char arr_char REP_in_Map
	+ in_HomD(6) [of "Map G" "Dom G" "Cod G" "REP G"]
	+ by auto
	+ have "Map (F \<odot> G) = Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
	+ using assms comp_def seq_char null_char Comp_def
	+ by (metis (no_types, lifting) CLS_REP Map.simps(1) Map_comp)
	+ have "Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B = \<lbrakk>REP F \<star> REP G\<rbrakk>\<^sub>B"
	+ proof -
	+ have "REP F \<star> REP G \<in> Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
	+ proof -
	+ have "REP F \<in> Map F \<and> REP G \<in> Map G"
	+ using assms seq_char REP_in_Map by auto
	+ moreover have "REP F \<star> REP G \<cong>\<^sub>B REP F \<star> REP G"
	+ using assms seq_char 2 B.isomorphic_reflexive by auto
	+ ultimately show ?thesis
	+ using assms 1 2 3 B.iso_class_def B.is_iso_class_def
	+ by (intro in_CompI, auto)
	+ qed
	+ moreover have "\<lbrakk>REP F\<rbrakk>\<^sub>B \<in> Hom (Cod G) (Cod F)"
	+ using assms 1 2 arr_char [of F] by auto
	+ moreover have "\<lbrakk>REP G\<rbrakk>\<^sub>B \<in> Hom (Dom G) (Cod G)"
	+ using assms 1 3 arr_char [of G] by auto
	+ ultimately show ?thesis
	+ using Comp_eq_iso_class_memb assms arr_char arr_char REP_in_Map
	+ by (simp add: Comp_def)
	+ qed
	+ moreover have "REP (F \<odot> G) \<in> Comp \<lbrakk>REP F\<rbrakk>\<^sub>B \<lbrakk>REP G\<rbrakk>\<^sub>B"
	+ proof -
	+ have "Map (F \<odot> G) = Comp (Map F) (Map G)"
	+ using assms 1 comp_char [of F G] by simp
	+ thus ?thesis
	+ using assms 1 2 3 REP_in_Map [of "F \<odot> G"] by simp
	+ qed
	+ ultimately show ?thesis
	+ using B.iso_class_def by simp
	+ qed
	+
	+ text \<open>
	+ We now show that \<open>Maps(B)\<close> has pullbacks. For this we need to exhibit
	+ functions \<open>PRJ\<^sub>0\<close> and \<open>PRJ\<^sub>1\<close> that produce the legs of the pullback of a cospan \<open>(H, K)\<close>
	+ and verify that they have the required universal property. These are obtained by
	+ choosing representatives \<open>h\<close> and \<open>k\<close> of \<open>H\<close> and \<open>K\<close>, respectively, and then taking
	+ \<open>PRJ\<^sub>0 = CLS (tab\<^sub>0 (k\<^sup>* \<star> h))\<close> and \<open>PRJ\<^sub>1 = CLS (tab\<^sub>1 (k\<^sup>* \<star> h))\<close>. That these constitute a
	+ pullback in \<open>Maps(B)\<close> follows from the fact that \<open>tab\<^sub>0 (k\<^sup>* \<star> h)\<close> and \<open>tab\<^sub>1 (k\<^sup>* \<star> h)\<close>
	+ form a pseudo-pullback of \<open>(h, k)\<close> in the underlying bicategory.
	+
	+ For our purposes here, it is not sufficient simply to show that \<open>Maps(B)\<close> has pullbacks
	+ and then to treat it as an abstract ``category with pullbacks'' where the pullbacks
	+ are chosen arbitrarily. Instead, we have to retain the connection between a pullback
	+ in Maps and the tabulation of \<open>k\<^sup>* \<star> h\<close> that is ultimately used to obtain it. If we don't
	+ do this, then it becomes problematic to define the compositor of a pseudofunctor from
	+ the underlying bicategory \<open>B\<close> to \<open>Span(Maps(B))\<close>, because the components will go from the
	+ apex of a composite span (obtained by pullback) to the apex of a tabulation (chosen
	+ arbitrarily using \<open>BS2\<close>) and these need not be in agreement with each other.
	+ \<close>
	+
	+ definition PRJ\<^sub>0
	+ where "PRJ\<^sub>0 \<equiv> \<lambda>K H. if cospan K H then \<lbrakk>\<lbrakk>B.tab\<^sub>0 ((REP K)\<^sup>* \<star> (REP H))\<rbrakk>\<rbrakk> else null"
	+ definition PRJ\<^sub>1
	+ where "PRJ\<^sub>1 \<equiv> \<lambda>K H. if cospan K H then \<lbrakk>\<lbrakk>B.tab\<^sub>1 ((REP K)\<^sup>* \<star> (REP H))\<rbrakk>\<rbrakk> else null"
	+
	+ interpretation elementary_category_with_pullbacks comp PRJ\<^sub>0 PRJ\<^sub>1
	+ proof
	+ show "\<And>H K. \<not> cospan K H \<Longrightarrow> PRJ\<^sub>0 K H = null"
	+ unfolding PRJ\<^sub>0_def by auto
	+ show "\<And>H K. \<not> cospan K H \<Longrightarrow> PRJ\<^sub>1 K H = null"
	+ unfolding PRJ\<^sub>1_def by auto
	+ show "\<And>H K. cospan K H \<Longrightarrow> commutative_square K H (PRJ\<^sub>1 K H) (PRJ\<^sub>0 K H)"
	+ proof -
	+ fix H K
	+ assume HK: "cospan K H"
	+ define h where "h = REP H"
	+ define k where "k = REP K"
	+ have h: "h \<in> Map H"
	+ using h_def HK REP_in_Map by blast
	+ have k: "k \<in> Map K"
	+ using k_def HK REP_in_Map by blast
	+ have 1: "B.is_left_adjoint h \<and> B.is_left_adjoint k \<and> B.ide h \<and> B.ide k \<and> trg h = trg k"
	+ using h k h_def k_def HK arr_char cod_char B.in_hhom_def B.left_adjoint_is_ide
	+ in_HomD(5) [of "Map H" "Dom H" "Cod H" h]
	+ in_HomD(5) [of "Map K" "Dom K" "Cod K" k]
	+ apply auto
	+ by (metis (no_types, lifting) HK Dom_cod)
	+ interpret h: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h
	+ using 1 by (unfold_locales, auto)
	+ interpret k: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg k
	+ using 1 by (unfold_locales, auto)
	+ interpret hk: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h k
	+ using 1 by (unfold_locales, auto)
	+ let ?f = "B.tab\<^sub>0 (k\<^sup>* \<star> h)"
	+ let ?g = "B.tab\<^sub>1 (k\<^sup>* \<star> h)"
	+ have span: "span \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
	+ using dom_char CLS_in_hom [of ?f] CLS_in_hom [of ?g] by auto
	+ have seq: "seq H \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"
	+ using HK seq_char hk.leg0_is_map CLS_in_hom h_def hk.p\<^sub>0_simps hk.satisfies_T0
	+ by fastforce
	+ have seq': "seq K \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
	+ using HK k arr_char dom_char cod_char in_HomD(5) hk.leg1_is_map CLS_in_hom
	+ by (metis (no_types, lifting) Cod.simps(1) seq_char REP_simps(2)
	+ hk.p\<^sub>1_simps k_def span)
	+ show "commutative_square K H (PRJ\<^sub>1 K H) (PRJ\<^sub>0 K H)"
	+ proof
	+ show "cospan K H"
	+ using HK by simp
	+ show "dom K = cod (PRJ\<^sub>1 K H)"
	+ using seq' PRJ\<^sub>1_def HK h_def k_def by auto
	+ show "span (PRJ\<^sub>1 K H) (PRJ\<^sub>0 K H)"
	+ unfolding PRJ\<^sub>0_def PRJ\<^sub>1_def using HK span h_def k_def by simp
	+ show "K \<odot> PRJ\<^sub>1 K H = H \<odot> PRJ\<^sub>0 K H"
	+ proof -
	+ have iso: "h \<star> ?f \<cong>\<^sub>B k \<star> ?g"
	+ using hk.\<phi>_uniqueness B.isomorphic_symmetric B.isomorphic_def by blast
	+ have *: "Comp (Map H) \<lbrakk>?f\<rbrakk>\<^sub>B = Comp (Map K) \<lbrakk>?g\<rbrakk>\<^sub>B"
	+ proof (intro Comp_eqI)
	+ show "h \<star> ?f \<in> Comp (Map H) \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
	+ proof (unfold Comp_def)
	+ have "B.is_iso_class \<lbrakk>?f\<rbrakk>\<^sub>B"
	+ by (simp add: B.is_iso_classI)
	+ moreover have "B.is_iso_class (Map H)"
	+ using CLS_REP HK Map.simps(1) B.is_iso_classI h.ide_left h_def
	+ by (metis (no_types, lifting))
	+ moreover have "?f \<in> \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
	+ by (simp add: B.ide_in_iso_class(1))
	+ moreover have "\<guillemotleft>?f : src (B.tab\<^sub>0 (k\<^sup>* \<star> h)) \<rightarrow>\<^sub>B Dom H\<guillemotright>"
	+ using seq seq_char by simp
	+ moreover have "h \<in> Map H"
	+ by fact
	+ moreover have "\<guillemotleft>h : Dom H \<rightarrow>\<^sub>B Cod H\<guillemotright>"
	+ by (simp add: HK h_def)
	+ moreover have "h \<star> ?f \<cong>\<^sub>B h \<star> ?f"
	+ using B.isomorphic_reflexive by auto
	+ ultimately show "h \<star> B.tab\<^sub>0 (k\<^sup>* \<star> h)
	+ \<in> {h'. B.is_iso_class \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
	+ B.is_iso_class (Map H) \<and>
	+ (\<exists>f g. f \<in> \<lbrakk>B.tab\<^sub>0 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
	+ g \<in> Map H \<and> g \<star> f \<cong>\<^sub>B h')}"
	+ by auto
	+ qed
	+ show "k \<star> ?g \<in> Comp (Map K) \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
	+ proof (unfold Comp_def)
	+ have "B.is_iso_class \<lbrakk>?g\<rbrakk>\<^sub>B"
	+ by (simp add: B.is_iso_classI)
	+ moreover have "B.is_iso_class (Map K)"
	+ by (metis (no_types, lifting) CLS_REP HK Map.simps(1)
	+ B.is_iso_classI k.ide_left k_def)
	+ moreover have "?g \<in> \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B"
	+ by (simp add: B.ide_in_iso_class(1))
	+ moreover have "\<guillemotleft>?g : src (B.tab\<^sub>1 (k\<^sup>* \<star> h)) \<rightarrow>\<^sub>B Dom K\<guillemotright>"
	+ using seq seq_char B.in_hhom_def seq' by auto
	+ moreover have "k \<in> Map K"
	+ by fact
	+ moreover have "\<guillemotleft>k : Dom K \<rightarrow>\<^sub>B Cod K\<guillemotright>"
	+ by (simp add: HK k_def)
	+ moreover have "k \<star> ?g \<cong>\<^sub>B k \<star> ?g"
	+ using B.isomorphic_reflexive iso B.isomorphic_implies_hpar(2) by auto
	+ ultimately show "k \<star> B.tab\<^sub>1 (k\<^sup>* \<star> h)
	+ \<in> {h'. B.is_iso_class \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
	+ B.is_iso_class (Map K) \<and>
	+ (\<exists>f g. f \<in> \<lbrakk>B.tab\<^sub>1 (k\<^sup>* \<star> h)\<rbrakk>\<^sub>B \<and>
	+ g \<in> Map K \<and> g \<star> f \<cong>\<^sub>B h')}"
	+ by auto
	+ qed
	+ show "h \<star> ?f \<cong>\<^sub>B k \<star> ?g"
	+ using iso by simp
	+ qed
	+ have "K \<odot> PRJ\<^sub>1 K H = K \<odot> \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
	+ unfolding PRJ\<^sub>1_def using HK h_def k_def by simp
	+ also have "... = MkArr (src ?g) (Cod K) (Comp (Map K) \<lbrakk>?g\<rbrakk>\<^sub>B)"
	+ using seq' comp_char [of K "\<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"] by simp
	+ also have "... = MkArr (src ?f) (Cod H) (Comp (Map H) \<lbrakk>?f\<rbrakk>\<^sub>B)"
	+ using * HK cod_char by auto
	+ also have "... = comp H \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"
	+ using seq comp_char [of H "\<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"] by simp
	+ also have "... = comp H (PRJ\<^sub>0 K H)"
	+ unfolding PRJ\<^sub>0_def using HK h_def k_def by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+ show "\<And>H K U V. commutative_square K H V U \<Longrightarrow>
	+ \<exists>!E. comp (PRJ\<^sub>1 K H) E = V \<and> comp (PRJ\<^sub>0 K H) E = U"
	+ proof -
	+ fix H K U V
	+ assume cs: "commutative_square K H V U"
	+ have HK: "cospan K H"
	+ using cs by auto
	+ (* TODO: Is there any way to avoid this repetition? *)
	+ define h where "h = REP H"
	+ define k where "k = REP K"
	+ have h: "h \<in> Map H"
	+ using h_def HK REP_in_Map by blast
	+ have k: "k \<in> Map K"
	+ using k_def HK REP_in_Map by blast
	+ have 1: "B.is_left_adjoint h \<and> B.is_left_adjoint k \<and> B.ide h \<and> B.ide k \<and> trg h = trg k"
	+ using h k h_def k_def HK arr_char cod_char B.in_hhom_def B.left_adjoint_is_ide
	+ in_HomD(5) [of "Map H" "Dom H" "Cod H" h]
	+ in_HomD(5) [of "Map K" "Dom K" "Cod K" k]
	+ apply auto
	+ by (metis (no_types, lifting) HK Dom_cod)
	+ interpret h: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h
	+ using 1 by (unfold_locales, auto)
	+ interpret k: map_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg k
	+ using 1 by (unfold_locales, auto)
	+ interpret hk: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg h k
	+ using 1 by (unfold_locales, auto)
	+ let ?f = "B.tab\<^sub>0 (k\<^sup>* \<star> h)"
	+ let ?g = "B.tab\<^sub>1 (k\<^sup>* \<star> h)"
	+ have seq_HU: "seq H U"
	+ using cs by auto
	+ have seq_KV: "seq K V"
	+ using cs by auto
	+ let ?u = "REP U"
	+ let ?v = "REP V"
	+ have u: "B.ide ?u"
	+ using ide_REP seq_HU by auto
	+ have v: "B.ide ?v"
	+ using ide_REP seq_KV by auto
	+ have u_is_map: "B.is_left_adjoint ?u"
	+ using u seq_HU REP_in_Map arr_char [of U]
	+ in_HomD(5) [of "Map U" "Dom U" "Cod U" ?u]
	+ by auto
	+ have v_is_map: "B.is_left_adjoint ?v"
	+ using v seq_KV REP_in_Map arr_char [of V]
	+ in_HomD(5) [of "Map V" "Dom V" "Cod V" ?v]
	+ by auto
	+ have *: "h \<star> ?u \<cong>\<^sub>B k \<star> ?v"
	+ proof -
	+ have "h \<star> ?u \<cong>\<^sub>B REP (H \<odot> U)"
	+ proof -
	+ have "h \<star> ?u \<cong>\<^sub>B REP H \<star> ?u"
	+ proof -
	+ have "h \<cong>\<^sub>B REP H"
	+ using h h_def HK arr_char REP_in_Map B.iso_class_elems_isomorphic
	+ in_HomD(5) [of "Map H" "Dom H" "Cod H" h] B.isomorphic_reflexive
	+ by auto
	+ thus ?thesis
	+ using h_def seq_HU B.isomorphic_implies_hpar(1) B.isomorphic_reflexive
	+ by (simp add: seq_char)
	+ qed
	+ also have "... \<cong>\<^sub>B REP (H \<odot> U)"
	+ using seq_HU isomorphic_hcomp_REP isomorphic_def by blast
	+ finally show ?thesis by blast
	+ qed
	+ also have "... \<cong>\<^sub>B REP (K \<odot> V)"
	+ using seq_HU cs B.isomorphic_reflexive by auto
	+ also have "... \<cong>\<^sub>B (k \<star> ?v)"
	+ proof -
	+ have "... \<cong>\<^sub>B REP K \<star> ?v"
	+ using seq_KV isomorphic_hcomp_REP B.isomorphic_def B.isomorphic_symmetric
	+ by blast
	+ also have "... \<cong>\<^sub>B k \<star> ?v"
	+ proof -
	+ have "k \<cong>\<^sub>B REP K"
	+ using k k_def HK arr_char REP_in_Map B.iso_class_elems_isomorphic
	+ in_HomD(5) [of "Map K" "Dom K" "Cod K" k] B.isomorphic_reflexive
	+ by auto
	+ thus ?thesis
	+ using k_def seq_KV B.isomorphic_implies_hpar(1) B.isomorphic_reflexive
	+ by (simp add: seq_char)
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ have hseq_hu: "src h = trg ?u"
	+ using * B.isomorphic_implies_hpar
	+ by (meson B.hseqE B.ideD(1))
	+ have hseq_kv: "src k = trg ?v"
	+ using * B.isomorphic_implies_hpar
	+ by (meson B.hseqE B.ideD(1))
	+
	+ obtain w where w: "B.is_left_adjoint w \<and> ?f \<star> w \<cong>\<^sub>B ?u \<and> ?v \<cong>\<^sub>B (?g \<star> w)"
	+ using * u_is_map v_is_map hk.has_pseudo_pullback [of ?u ?v] B.isomorphic_symmetric
	+ by blast
	+ have w_in_hom: "\<guillemotleft>w : src ?u \<rightarrow>\<^sub>B src ?f\<guillemotright> \<and> B.ide w"
	+ using w B.left_adjoint_is_ide B.src_cod B.trg_cod B.isomorphic_def
	+ apply (intro conjI B.in_hhomI)
	+ apply auto
	+ apply (metis B.ideD(1) B.isomorphic_implies_hpar(3) B.isomorphic_implies_ide(1)
	+ B.hcomp_simps(1))
	+ by (metis B.hseqE B.ideD(1) B.isomorphic_implies_hpar(1))
	+ let ?W = "CLS w"
	+ have W: "\<guillemotleft>?W : dom U \<rightarrow> dom \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>\<guillemotright>"
	+ proof
	+ show "arr ?W"
	+ using w CLS_in_hom by blast
	+ thus "dom ?W = dom U"
	+ using w_in_hom dom_char REP_in_hhom(1) CLS_in_hom
	+ by (metis (no_types, lifting) Dom.simps(1) commutative_squareE
	+ dom_char REP_simps(2) cs B.in_hhomE)
	+ show "cod ?W = dom \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "src ?f = trg w"
	+ by (metis (lifting) B.in_hhomE w_in_hom)
	+ thus ?thesis
	+ using CLS_in_hom [of ?f] CLS_in_hom [of w] hk.satisfies_T0 w by fastforce
	+ qed
	+ qed
	+ show "\<exists>!E. PRJ\<^sub>1 K H \<odot> E = V \<and> PRJ\<^sub>0 K H \<odot> E = U"
	+ proof -
	+ have "PRJ\<^sub>1 K H \<odot> ?W = V \<and> PRJ\<^sub>0 K H \<odot> ?W = U"
	+ proof -
	+ have "\<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<odot> ?W = U"
	+ using w w_in_hom u CLS_in_hom comp_CLS
	+ B.isomorphic_symmetric CLS_REP hk.leg0_is_map
	+ by (metis (mono_tags, lifting) commutative_square_def cs)
	+ moreover have "\<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk> \<odot> ?W = V"
	+ using w w_in_hom v CLS_in_hom comp_CLS
	+ B.isomorphic_symmetric CLS_REP hk.leg1_is_map
	+ by (metis (mono_tags, lifting) commutative_square_def cs)
	+ ultimately show ?thesis
	+ using HK h_def k_def PRJ\<^sub>0_def PRJ\<^sub>1_def by auto
	+ qed
	+ moreover have
	+ "\<And>W'. PRJ\<^sub>1 K H \<odot> W' = V \<and> PRJ\<^sub>0 K H \<odot> W' = U \<Longrightarrow> W' = ?W"
	+ proof -
	+ fix W'
	+ assume "PRJ\<^sub>1 K H \<odot> W' = V \<and> PRJ\<^sub>0 K H \<odot> W' = U"
	+ hence W': "\<guillemotleft>W' : dom U \<rightarrow> dom \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk>\<guillemotright> \<and> \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<odot> W' = U \<and> \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk> \<odot> W' = V"
	+ using PRJ\<^sub>0_def PRJ\<^sub>1_def HK h_def k_def apply simp
	+ using cs arr_iff_in_hom by blast
	+ let ?w' = "REP W'"
	+ have w': "B.ide ?w'"
	+ using W' ide_REP by auto
	+
	+ have fw'_iso_u: "?f \<star> ?w' \<cong>\<^sub>B ?u"
	+ proof -
	+ have "?f \<star> ?w' \<cong>\<^sub>B REP \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<star> ?w'"
	+ by (metis (no_types, lifting) Cod.simps(1) in_hom_char
	+ REP_CLS REP_simps(3) W W' B.hcomp_isomorphic_ide hk.satisfies_T0
	+ B.in_hhomE B.isomorphic_symmetric w' w_in_hom)
	+ also have "REP \<lbrakk>\<lbrakk>?f\<rbrakk>\<rbrakk> \<star> ?w' \<cong>\<^sub>B ?u"
	+ using W' isomorphic_hcomp_REP cs by blast
	+ finally show ?thesis by blast
	+ qed
	+
	+ have gw'_iso_v: "?g \<star> ?w' \<cong>\<^sub>B ?v"
	+ proof -
	+ have "?g \<star> ?w' \<cong>\<^sub>B REP \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk> \<star> ?w'"
	+ proof -
	+ have "?g \<cong>\<^sub>B REP \<lbrakk>\<lbrakk>?g\<rbrakk>\<rbrakk>"
	+ using REP_CLS B.isomorphic_symmetric hk.leg1_is_map by blast
	+ moreover have "B.ide (REP W')"
	+ using W' by auto
	+ moreover have "src ?f = trg ?w'"
	+ using w_in_hom W W' in_hom_char arr_char B.in_hhom_def
	+ by (meson fw'_iso_u B.hseqE B.ideD(1) B.isomorphic_implies_ide(1))
	+ ultimately show ?thesis
	+ using B.hcomp_isomorphic_ide by simp
	+ qed
	+ also have "... \<cong>\<^sub>B ?v"
	+ using W' isomorphic_hcomp_REP cs by blast
	+ finally show ?thesis by blast
	+ qed
	+
	+ show "W' = ?W"
	+ proof -
	+ have "W' = \<lbrakk>\<lbrakk>?w'\<rbrakk>\<rbrakk>"
	+ using w' W' CLS_REP by auto
	+ also have "... = ?W"
	+ proof -
	+ have "?w' \<cong>\<^sub>B w"
	+ using * w W' hk.has_pseudo_pullback(2) u_is_map v_is_map
	+ B.isomorphic_symmetric fw'_iso_u gw'_iso_v
	+ by blast
	+ thus ?thesis
	+ using CLS_eqI B.iso_class_eqI w' by blast
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ ultimately show ?thesis by auto
	+ qed
	+ qed
	+ qed
	+
	+ lemma is_elementary_category_with_pullbacks:
	+ shows "elementary_category_with_pullbacks comp PRJ\<^sub>0 PRJ\<^sub>1"
	+ ..
	+
	+ lemma is_category_with_pullbacks:
	+ shows "category_with_pullbacks comp"
	+ ..
	+
	+ sublocale elementary_category_with_pullbacks comp PRJ\<^sub>0 PRJ\<^sub>1
	+ using is_elementary_category_with_pullbacks by simp
	+
	+ end
	+
	+ text \<open>
	+ Here we relate the projections of the chosen pullbacks in \<open>Maps(B)\<close> to the
	+ projections associated with the chosen tabulations in \<open>B\<close>.
	+ \<close>
	+
	+ context composite_tabulation_in_maps
	+ begin
	+
	+ interpretation Maps: maps_category V H \<a> \<i> src trg
	+ ..
	+
	+ interpretation r\<^sub>0s\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg s\<^sub>1 r\<^sub>0
	+ using \<rho>.leg0_is_map \<sigma>.leg1_is_map composable by (unfold_locales, auto)
	+
	+ lemma prj_char:
	+ shows "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>0 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
	+ and "Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>1 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "Maps.arr (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
	+ using \<sigma>.leg1_in_hom Maps.CLS_in_hom \<sigma>.leg1_is_map Maps.arr_char by auto
	+ moreover have "Maps.arr (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>)"
	+ using Maps.CLS_in_hom composable r\<^sub>0s\<^sub>1.k_is_map by fastforce
	+ moreover have "Maps.cod (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>) =
	+ Maps.cod (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
	+ unfolding Maps.arr_char
	+ using \<sigma>.leg1_in_hom \<rho>.leg0_in_hom
	+ by (simp add: Maps.cod_char calculation(1) calculation(2))
	+ ultimately have "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> =
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
	+ Maps.REP (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>))\<rbrakk>\<rbrakk> \<and>
	+ Maps.PRJ\<^sub>1 (Maps.CLS r\<^sub>0) (Maps.CLS s\<^sub>1) =
	+ \<lbrakk>\<lbrakk>tab\<^sub>1 ((Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
	+ Maps.REP (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>))\<rbrakk>\<rbrakk>"
	+ unfolding Maps.PRJ\<^sub>0_def Maps.PRJ\<^sub>1_def
	+ using Maps.CLS_in_hom \<sigma>.leg1_is_map \<rho>.leg0_is_map composable by simp
	+ moreover have "r\<^sub>0\<^sup>* \<star> s\<^sub>1 \<cong> (Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* \<star>
	+ Maps.REP (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
	+ proof -
	+ have "r\<^sub>0 \<cong> Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>)"
	+ using Maps.REP_CLS composable isomorphic_symmetric r\<^sub>0s\<^sub>1.k_is_map by fastforce
	+ hence 3: "isomorphic r\<^sub>0\<^sup>* (Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>*"
	+ using \<rho>.leg0_is_map
	+ by (simp add: isomorphic_to_left_adjoint_implies_isomorphic_right_adjoint)
	+ moreover have 4: "s\<^sub>1 \<cong> Maps.REP (MkArr (src s\<^sub>0) (trg s) \<lbrakk>s\<^sub>1\<rbrakk>)"
	+ using Maps.REP_CLS isomorphic_symmetric r\<^sub>0s\<^sub>1.h_is_map by fastforce
	+ ultimately show ?thesis
	+ proof -
	+ have 1: "src r\<^sub>0\<^sup>* = trg s\<^sub>1"
	+ using \<rho>.T0.antipar(2) r\<^sub>0s\<^sub>1.cospan by presburger
	+ have 2: "ide s\<^sub>1"
	+ by simp
	+ have "src (Maps.REP (MkArr (src r\<^sub>0) (trg s) \<lbrakk>r\<^sub>0\<rbrakk>))\<^sup>* = trg s\<^sub>1"
	+ by (metis 3 \<rho>.T0.antipar(2) isomorphic_implies_hpar(3) r\<^sub>0s\<^sub>1.cospan)
	+ thus ?thesis
	+ using 1 2
	+ by (meson 3 4 hcomp_ide_isomorphic hcomp_isomorphic_ide isomorphic_implies_ide(2)
	+ isomorphic_transitive)
	+ qed
	+ qed
	+ ultimately have 1: "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>0 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk> \<and>
	+ Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>1 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
	+ using r\<^sub>0s\<^sub>1.isomorphic_implies_same_tab by simp
	+ show "Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>0 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
	+ using 1 by simp
	+ show "Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>r\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>s\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>prj\<^sub>1 s\<^sub>1 r\<^sub>0\<rbrakk>\<rbrakk>"
	+ using 1 by simp
	+ qed
	+
	+ end
	+
	+ context identity_in_bicategory_of_spans
	+ begin
	+
	+ interpretation Maps: maps_category V H \<a> \<i> src trg ..
	+ interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
	+
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ text \<open>
	+ A 1-cell \<open>r\<close> in a bicategory of spans is a map if and only if the ``input leg''
	+ \<open>tab\<^sub>0 r\<close> of the chosen tabulation of \<open>r\<close> is an equivalence map.
	+ Since a tabulation of \<open>r\<close> is unique up to equivalence, and equivalence maps compose,
	+ the result actually holds if ``chosen tabulation'' is replaced by ``any tabulation''.
	+ \<close>
	+
	+ lemma is_map_iff_tab\<^sub>0_is_equivalence:
	+ shows "is_left_adjoint r \<longleftrightarrow> equivalence_map (tab\<^sub>0 r)"
	+ proof
	+ assume 1: "equivalence_map (tab\<^sub>0 r)"
	+ have 2: "equivalence_pair (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>*"
	+ proof -
	+ obtain g' \<eta>' \<epsilon>' where \<eta>'\<epsilon>': "equivalence_in_bicategory V H \<a> \<i> src trg (tab\<^sub>0 r) g' \<eta>' \<epsilon>'"
	+ using 1 equivalence_map_def by auto
	+ have "adjoint_pair (tab\<^sub>0 r) g'"
	+ using \<eta>'\<epsilon>' equivalence_pair_def equivalence_pair_is_adjoint_pair by blast
	+ moreover have "adjoint_pair (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>*"
	+ using T0.adjunction_in_bicategory_axioms adjoint_pair_def by auto
	+ ultimately have "g' \<cong> (tab\<^sub>0 r)\<^sup>*"
	+ using left_adjoint_determines_right_up_to_iso by simp
	+ thus ?thesis
	+ using \<eta>'\<epsilon>' equivalence_pair_def equivalence_pair_isomorphic_right by blast
	+ qed
	+ obtain \<eta>' \<epsilon>' where \<eta>'\<epsilon>': "equivalence_in_bicategory V H \<a> \<i> src trg (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>* \<eta>' \<epsilon>'"
	+ using 2 equivalence_pair_def by auto
	+ interpret \<eta>'\<epsilon>': equivalence_in_bicategory V H \<a> \<i> src trg \<open>tab\<^sub>0 r\<close> \<open>(tab\<^sub>0 r)\<^sup>*\<close> \<eta>' \<epsilon>'
	+ using \<eta>'\<epsilon>' by auto
	+ have "is_left_adjoint (tab\<^sub>0 r)\<^sup>*"
	+ using 2 equivalence_pair_is_adjoint_pair equivalence_pair_symmetric by blast
	+ hence "is_left_adjoint (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ using left_adjoints_compose by simp
	+ thus "is_left_adjoint r"
	+ using yields_isomorphic_representation isomorphic_def left_adjoint_preserved_by_iso'
	+ by meson
	+ next
	+ assume 1: "is_left_adjoint r"
	+ have 2: "is_left_adjoint (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ using 1 yields_isomorphic_representation left_adjoint_preserved_by_iso'
	+ isomorphic_symmetric isomorphic_def
	+ by meson
	+ hence "is_left_adjoint (tab\<^sub>0 r)\<^sup>*"
	+ using is_ide BS4 [of "tab\<^sub>1 r" "(tab\<^sub>0 r)\<^sup>*"] by auto
	+ hence "is_left_adjoint ((tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>0 r) \<and> is_left_adjoint (tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ using left_adjoints_compose T0.antipar by simp
	+ hence 3: "iso \<eta> \<and> iso \<epsilon>"
	+ using BS3 [of "src (tab\<^sub>0 r)" "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>0 r" \<eta> \<eta>]
	+ BS3 [of "tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*" "trg (tab\<^sub>0 r)" \<epsilon> \<epsilon>]
	+ T0.unit_in_hom T0.counit_in_hom obj_is_self_adjoint
	+ by auto
	+ hence "equivalence_in_bicategory V H \<a> \<i> src trg (tab\<^sub>0 r) (tab\<^sub>0 r)\<^sup>* \<eta> \<epsilon>"
	+ apply unfold_locales by auto
	+ thus "equivalence_map (tab\<^sub>0 r)"
	+ using equivalence_map_def by blast
	+ qed
	+
	+ text \<open>
	+ The chosen tabulation (and indeed, any other tabulation, which is equivalent)
	+ of an object is symmetric in the sense that its two legs are isomorphic.
	+ \<close>
	+
	+ lemma obj_has_symmetric_tab:
	+ assumes "obj r"
	+ shows "tab\<^sub>0 r \<cong> tab\<^sub>1 r"
	+ proof -
	+ have "tab\<^sub>0 r \<cong> r \<star> tab\<^sub>0 r"
	+ proof -
	+ have "trg (tab\<^sub>0 r) = r"
	+ using assms by auto
	+ moreover have "\<guillemotleft>\<l>\<^sup>-\<^sup>1[tab\<^sub>0 r] : tab\<^sub>0 r \<Rightarrow> trg (tab\<^sub>0 r) \<star> tab\<^sub>0 r\<guillemotright> \<and> iso \<l>\<^sup>-\<^sup>1[tab\<^sub>0 r]"
	+ using assms by simp
	+ ultimately show ?thesis
	+ unfolding isomorphic_def by metis
	+ qed
	+ also have "... \<cong> tab\<^sub>1 r"
	+ proof -
	+ have "\<guillemotleft>tab : tab\<^sub>1 r \<Rightarrow> r \<star> tab\<^sub>0 r\<guillemotright>"
	+ using tab_in_hom by simp
	+ moreover have "is_left_adjoint (r \<star> tab\<^sub>0 r)"
	+ using assms left_adjoints_compose obj_is_self_adjoint by simp
	+ ultimately show ?thesis
	+ using BS3 [of "tab\<^sub>1 r" "r \<star> tab\<^sub>0 r" tab tab] isomorphic_symmetric isomorphic_def
	+ by auto
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ text \<open>
	+ The chosen tabulation of \<open>r\<close> determines a span in \<open>Maps(B)\<close>.
	+ \<close>
	+
	+ lemma determines_span:
	+ assumes "ide r"
	+ shows "span_in_category Maps.comp \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>\<rparr>"
	+ using assms Maps.CLS_in_hom [of "tab\<^sub>0 r"] Maps.CLS_in_hom [of "tab\<^sub>1 r"]
	+ tab\<^sub>0_in_hom tab\<^sub>1_in_hom
	+ apply unfold_locales by fastforce
	+
	+ end
	+
	+ subsection "Arrows of Tabulations in Maps"
	+
	+ text \<open>
	+ Here we consider the situation of two tabulations: a tabulation \<open>\<rho>\<close> of \<open>r\<close>
	+ and a tabulation \<open>\<sigma>\<close> of \<open>s\<close>, both ``legs'' of each tabulation being maps,
	+ together with an arbitrary 2-cell \<open>\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>\<close>.
	+ The 2-cell \<open>\<mu>\<close> at the base composes with the tabulation \<open>\<rho>\<close> to yield a 2-cell
	+ \<open>\<Delta> = (\<mu> \<star> r\<^sub>0) \<cdot> \<rho>\<close> ``over'' s. By property \<open>T1\<close> of tabulation \<open>\<sigma>\<close>, this induces a map
	+ from the apex of \<open>\<rho>\<close> to the apex of \<open>\<sigma>\<close>, which together with the other data
	+ forms a triangular prism whose sides commute up to (unique) isomorphism.
	+ \<close>
	+ text \<open>
	+$$
	+\xymatrix{
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \dtwocell\omit{^<-1>\sigma} & \\
	+ &{\rm trg}~s && {\rm src}~s \ar[ll]^{s} \\
	+ & \rrtwocell\omit{^\mu} &&\\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \ar@ {.>}[uuur]^<>(0.3){{\rm chine}} \dtwocell\omit{^\rho}& \\
	+ {\rm trg}~r \ar@ {=}[uuur] && {\rm src}~r \ar[ll]^{r} \ar@ {=}[uuur]
	+}
	+$$
	+ \<close>
	+
	+ locale arrow_of_tabulations_in_maps =
	+ bicategory_of_spans V H \<a> \<i> src trg +
	+ \<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
	+ \<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and r :: 'a
	+ and \<rho> :: 'a
	+ and r\<^sub>0 :: 'a
	+ and r\<^sub>1 :: 'a
	+ and s :: 'a
	+ and \<sigma> :: 'a
	+ and s\<^sub>0 :: 'a
	+ and s\<^sub>1 :: 'a
	+ and \<mu> :: 'a +
	+ assumes in_hom: "\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>"
	+ begin
	+
	+ abbreviation (input) \<Delta>
	+ where "\<Delta> \<equiv> (\<mu> \<star> r\<^sub>0) \<cdot> \<rho>"
	+
	+ lemma \<Delta>_in_hom [intro]:
	+ shows "\<guillemotleft>\<Delta> : src \<rho> \<rightarrow> trg \<sigma>\<guillemotright>"
	+ and "\<guillemotleft>\<Delta> : r\<^sub>1 \<Rightarrow> s \<star> r\<^sub>0\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<Delta> : r\<^sub>1 \<Rightarrow> s \<star> r\<^sub>0\<guillemotright>"
	+ using in_hom hseqI' \<rho>.leg0_in_hom(2) \<rho>.tab_in_vhom' by auto
	+ thus "\<guillemotleft>\<Delta> : src \<rho> \<rightarrow> trg \<sigma>\<guillemotright>"
	+ by (metis \<rho>.tab_simps(3) \<rho>.base_in_hom(2) \<sigma>.tab_simps(3) \<sigma>.base_in_hom(2) arrI in_hom
	+ seqI' vcomp_in_hhom vseq_implies_hpar(1-2))
	+ qed
	+
	+ lemma \<Delta>_simps [simp]:
	+ shows "arr \<Delta>"
	+ and "src \<Delta> = src \<rho>" and "trg \<Delta> = trg \<sigma>"
	+ and "dom \<Delta> = r\<^sub>1" and "cod \<Delta> = s \<star> r\<^sub>0"
	+ using \<Delta>_in_hom by auto
	+
	+ abbreviation is_induced_map
	+ where "is_induced_map w \<equiv> \<sigma>.is_induced_by_cell w r\<^sub>0 \<Delta>"
	+
	+ text \<open>
	+ The following is an equivalent restatement, in elementary terms, of the conditions
	+ for being an induced map.
	+ \<close>
	+
	+ abbreviation (input) is_induced_map'
	+ where "is_induced_map' w \<equiv>
	+ ide w \<and>
	+ (\<exists>\<nu> \<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ \<Delta> = (s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu>)"
	+
	+ lemma is_induced_map_iff:
	+ shows "is_induced_map w \<longleftrightarrow> is_induced_map' w"
	+ proof
	+ assume w: "is_induced_map' w"
	+ show "is_induced_map w"
	+ proof
	+ have 1: "dom \<Delta> = r\<^sub>1"
	+ by auto
	+ interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg
	+ r\<^sub>0 \<open>dom \<Delta>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w
	+ proof -
	+ have "arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 w"
	+ using w apply unfold_locales by auto
	+ thus "arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) s \<sigma> s\<^sub>0 s\<^sub>1 w"
	+ using 1 by simp
	+ qed
	+ show "arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) s\<^sub>0 s\<^sub>1 w"
	+ using w.arrow_of_spans_of_maps_axioms by auto
	+ show "\<sigma>.composite_cell w w.the_\<theta> \<cdot> w.the_\<nu> = \<Delta>"
	+ proof -
	+ obtain \<theta> \<nu>
	+ where \<theta>\<nu>: "\<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ \<Delta> = (s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu>"
	+ using w w.the_\<theta>_props(1) by auto
	+ have "(s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu> = \<Delta>"
	+ using \<theta>\<nu> by argo
	+ moreover have "\<theta> = w.the_\<theta> \<and> \<nu> = w.the_\<nu>"
	+ using \<theta>\<nu> 1 w.the_\<nu>_props(1) w.leg0_uniquely_isomorphic w.leg1_uniquely_isomorphic
	+ by auto
	+ ultimately show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ qed
	+ next
	+ assume w: "is_induced_map w"
	+ show "is_induced_map' w"
	+ proof -
	+ interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 w
	+ using w in_hom hseqI' by auto
	+ interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 w
	+ ..
	+ have "dom \<Delta> = r\<^sub>1" by auto
	+ thus ?thesis
	+ using w comp_assoc w.the_\<nu>_props(1) w.the_\<nu>_props(2) w.uw\<theta> by metis
	+ qed
	+ qed
	+
	+ lemma exists_induced_map:
	+ shows "\<exists>w. is_induced_map w"
	+ proof -
	+ obtain w \<theta> \<nu>
	+ where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : s\<^sub>0 \<star> w \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ \<Delta> = (s \<star> \<theta>) \<cdot> \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> \<nu>"
	+ using \<Delta>_in_hom \<rho>.ide_leg0 \<sigma>.T1 comp_assoc
	+ by (metis in_homE)
	+ thus ?thesis
	+ using is_induced_map_iff by blast
	+ qed
	+
	+ lemma induced_map_unique:
	+ assumes "is_induced_map w" and "is_induced_map w'"
	+ shows "w \<cong> w'"
	+ using assms \<sigma>.induced_map_unique by blast
	+
	+ definition chine
	+ where "chine \<equiv> SOME w. is_induced_map w"
	+
	+ lemma chine_is_induced_map:
	+ shows "is_induced_map chine"
	+ unfolding chine_def
	+ using exists_induced_map someI_ex [of is_induced_map] by simp
	+
	+ lemma chine_in_hom [intro]:
	+ shows "\<guillemotleft>chine : src r\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright>"
	+ and "\<guillemotleft>chine: chine \<Rightarrow> chine\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>chine : src r\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright>"
	+ using chine_is_induced_map
	+ by (metis \<Delta>_simps(1) \<Delta>_simps(4) \<rho>.leg1_simps(3) \<sigma>.ide_base \<sigma>.ide_leg0 \<sigma>.leg0_simps(3)
	+ \<sigma>.tab_simps(2) arrow_of_spans_of_maps.is_ide arrow_of_spans_of_maps.the_\<nu>_simps(2)
	+ assoc_simps(2) hseqE in_hhom_def seqE src_vcomp vseq_implies_hpar(1))
	+ show "\<guillemotleft>chine: chine \<Rightarrow> chine\<guillemotright>"
	+ using chine_is_induced_map
	+ by (meson arrow_of_spans_of_maps.is_ide ide_in_hom(2))
	+ qed
	+
	+ lemma chine_simps [simp]:
	+ shows "arr chine" and "ide chine"
	+ and "src chine = src r\<^sub>0" and "trg chine = src s\<^sub>0"
	+ and "dom chine = chine" and "cod chine = chine"
	+ using chine_in_hom apply auto
	+ by (meson arrow_of_spans_of_maps.is_ide chine_is_induced_map)
	+
	+ end
	+
	+ sublocale arrow_of_tabulations_in_maps \<subseteq>
	+ arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 chine
	+ using chine_is_induced_map is_induced_map_iff
	+ by (unfold_locales, auto)
	+
	+ sublocale arrow_of_tabulations_in_maps \<subseteq>
	+ arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 chine
	+ ..
	+
	+ context arrow_of_tabulations_in_maps
	+ begin
	+
	+ text \<open>
	+ The two factorizations of the composite 2-cell \<open>\<Delta>\<close> amount to a naturality condition.
	+ \<close>
	+
	+ lemma \<Delta>_naturality:
	+ shows "(\<mu> \<star> r\<^sub>0) \<cdot> \<rho> = (s \<star> the_\<theta>) \<cdot> \<a>[s, s\<^sub>0, chine] \<cdot> (\<sigma> \<star> chine) \<cdot> the_\<nu>"
	+ using chine_is_induced_map is_induced_map_iff
	+ by (metis leg0_uniquely_isomorphic(2) leg1_uniquely_isomorphic(2) the_\<nu>_props(1) uw\<theta>)
	+
	+ lemma induced_map_preserved_by_iso:
	+ assumes "is_induced_map w" and "isomorphic w w'"
	+ shows "is_induced_map w'"
	+ proof -
	+ interpret w: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s\<^sub>0 s\<^sub>1 w
	+ using assms in_hom hseqI' by auto
	+ interpret w: arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 w
	+ ..
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow> w'\<guillemotright> \<and> iso \<phi>"
	+ using assms(2) isomorphic_def by auto
	+ show ?thesis
	+ proof
	+ interpret w': arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 \<open>dom \<Delta>\<close> s\<^sub>0 s\<^sub>1 w'
	+ proof
	+ show "is_left_adjoint r\<^sub>0"
	+ by (simp add: \<rho>.satisfies_T0)
	+ show "is_left_adjoint (dom \<Delta>)"
	+ by (simp add: \<rho>.leg1_is_map)
	+ show "ide w'" using assms by force
	+ show "\<exists>\<theta>. \<guillemotleft>\<theta> : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>) : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
	+ using \<phi> w.the_\<theta>_props \<sigma>.leg0_in_hom(2) assms(2) comp_in_hom_simp' hcomp_in_vhom
	+ inv_in_hom isomorphic_implies_hpar(4) w.the_\<theta>_simps(4) w.w_simps(4)
	+ by presburger
	+ thus ?thesis by auto
	+ qed
	+ have "\<guillemotleft>(s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso ((s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>)"
	+ proof (intro conjI)
	+ show "\<guillemotleft>(s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright>"
	+ using \<phi> w.the_\<nu>_props
	+ by (intro comp_in_homI, auto)
	+ thus "iso ((s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>)"
	+ using \<phi> w.the_\<nu>_props
	+ by (meson \<sigma>.ide_leg1 arrI iso_hcomp hseqE ide_is_iso isos_compose seqE)
	+ qed
	+ hence "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>"
	+ by auto
	+ thus "\<exists>\<nu>. \<guillemotleft>\<nu> : dom \<Delta> \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>"
	+ using in_hom hseqI' by auto
	+ qed
	+ interpret w': arrow_of_spans_of_maps_to_tabulation V H \<a> \<i> src trg
	+ r\<^sub>0 \<open>dom \<Delta>\<close> s \<sigma> s\<^sub>0 s\<^sub>1 w'
	+ ..
	+ show "arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) s\<^sub>0 s\<^sub>1 w'"
	+ using w'.arrow_of_spans_of_maps_axioms in_hom hseqI' by auto
	+ show "\<sigma>.composite_cell w' w'.the_\<theta> \<cdot> w'.the_\<nu> = \<Delta>"
	+ proof -
	+ have 1: "w'.the_\<theta> = w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>)"
	+ proof -
	+ have "\<guillemotleft>w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>) : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
	+ using w.the_\<theta>_props \<phi>
	+ by (intro comp_in_homI, auto)
	+ moreover have "\<guillemotleft>w'.the_\<theta> : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright>"
	+ using w'.the_\<theta>_props by simp
	+ ultimately show ?thesis
	+ using w'.leg0_uniquely_isomorphic(2) by blast
	+ qed
	+ moreover have "w'.the_\<nu> = (s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>"
	+ proof -
	+ have "\<guillemotleft>(s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu> : dom \<Delta> \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright>"
	+ using w.the_\<nu>_props \<phi>
	+ by (intro comp_in_homI, auto)
	+ moreover have "iso ((s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>)"
	+ using w.the_\<nu>_props \<phi> iso_hcomp
	+ by (meson \<sigma>.ide_leg1 arrI calculation hseqE ide_is_iso isos_compose seqE)
	+ ultimately show ?thesis
	+ using w'.the_\<nu>_props w'.leg1_uniquely_isomorphic(2) by blast
	+ qed
	+ ultimately have "\<sigma>.composite_cell w' w'.the_\<theta> \<cdot> w'.the_\<nu> =
	+ \<sigma>.composite_cell w' (w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>)) \<cdot> (s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>"
	+ by simp
	+ also have "... = (s \<star> w.the_\<theta> \<cdot> (s\<^sub>0 \<star> inv \<phi>)) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot>
	+ (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>) \<cdot> w.the_\<nu>"
	+ using comp_assoc by simp
	+ also have "... = (s \<star> w.the_\<theta>) \<cdot> ((s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot>
	+ (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>)) \<cdot> w.the_\<nu>"
	+ using 1 comp_assoc w'.the_\<theta>_simps(1) whisker_left
	+ by auto
	+ also have "... = (s \<star> w.the_\<theta>) \<cdot> (\<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w)) \<cdot> w.the_\<nu>"
	+ proof -
	+ have "(s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot> (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>) =
	+ \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w)"
	+ proof -
	+ have "(s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot> (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>) =
	+ \<a>[s, s\<^sub>0, w] \<cdot> ((s \<star> s\<^sub>0) \<star> inv \<phi>) \<cdot> (\<sigma> \<star> w') \<cdot> (s\<^sub>1 \<star> \<phi>)"
	+ proof -
	+ have "(s \<star> s\<^sub>0 \<star> inv \<phi>) \<cdot> \<a>[s, s\<^sub>0, w'] = \<a>[s, s\<^sub>0, w] \<cdot> ((s \<star> s\<^sub>0) \<star> inv \<phi>)"
	+ using assms \<phi> assoc_naturality [of s s\<^sub>0 "inv \<phi>"] w.w_simps(4)
	+ by (metis \<sigma>.leg0_simps(2-5) \<sigma>.base_simps(2-4) arr_inv cod_inv dom_inv
	+ in_homE trg_cod)
	+ thus ?thesis using comp_assoc by metis
	+ qed
	+ also have "... = \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>) \<cdot> (s\<^sub>1 \<star> \<phi>)"
	+ proof -
	+ have "((s \<star> s\<^sub>0) \<star> inv \<phi>) \<cdot> (\<sigma> \<star> w') = (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>)"
	+ using \<phi> comp_arr_dom comp_cod_arr in_hhom_def
	+ interchange [of "s \<star> s\<^sub>0" \<sigma> "inv \<phi>" w']
	+ interchange [of \<sigma> s\<^sub>1 w "inv \<phi>"]
	+ by auto
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = \<a>[s, s\<^sub>0, w] \<cdot> (\<sigma> \<star> w)"
	+ proof -
	+ have "(\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>) \<cdot> (s\<^sub>1 \<star> \<phi>) = \<sigma> \<star> w"
	+ proof -
	+ have "(\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi>) \<cdot> (s\<^sub>1 \<star> \<phi>) = (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> inv \<phi> \<cdot> \<phi>)"
	+ using \<phi> whisker_left in_hhom_def by auto
	+ also have "... = (\<sigma> \<star> w) \<cdot> (s\<^sub>1 \<star> w)"
	+ using \<phi> comp_inv_arr' by auto
	+ also have "... = \<sigma> \<star> w"
	+ using whisker_right [of w \<sigma> s\<^sub>1] comp_arr_dom in_hhom_def by auto
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<Delta>"
	+ using assms(1) comp_assoc w.is_ide w.the_\<nu>_props(1) w.the_\<theta>_props(1) by simp
	+ finally show ?thesis
	+ using comp_assoc by auto
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ In the special case that \<open>\<mu>\<close> is an identity 2-cell, the induced map from the apex of \<open>\<rho>\<close>
	+ to the apex of \<open>\<sigma>\<close> is an equivalence map.
	+ \<close>
	+
	+ locale identity_arrow_of_tabulations_in_maps =
	+ arrow_of_tabulations_in_maps +
	+ assumes is_ide: "ide \<mu>"
	+ begin
	+
	+ lemma r_eq_s:
	+ shows "r = s"
	+ using is_ide by (metis ide_char in_hom in_homE)
	+
	+ lemma \<Delta>_eq_\<rho>:
	+ shows "\<Delta> = \<rho>"
	+ by (meson \<Delta>_simps(1) comp_ide_arr ide_hcomp hseq_char' ide_u is_ide seqE
	+ seq_if_composable)
	+
	+ lemma chine_is_equivalence:
	+ shows "equivalence_map chine"
	+ proof -
	+ obtain w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'
	+ where e: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg w' w \<psi> \<phi> \<and>
	+ \<guillemotleft>w : src s\<^sub>0 \<rightarrow> src r\<^sub>0\<guillemotright> \<and> \<guillemotleft>w' : src r\<^sub>0 \<rightarrow> src s\<^sub>0\<guillemotright> \<and>
	+ \<guillemotleft>\<theta> : r\<^sub>0 \<star> w \<Rightarrow> s\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu> : s\<^sub>1 \<Rightarrow> r\<^sub>1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ \<sigma> = (s \<star> \<theta>) \<cdot> \<a>[s, r\<^sub>0, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> \<and>
	+ \<guillemotleft>\<theta>' : s\<^sub>0 \<star> w' \<Rightarrow> r\<^sub>0\<guillemotright> \<and> \<guillemotleft>\<nu>' : r\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
	+ \<rho> = (s \<star> \<theta>') \<cdot> \<a>[s, s\<^sub>0, w'] \<cdot> (\<sigma> \<star> w') \<cdot> \<nu>'"
	+ using r_eq_s \<sigma>.apex_unique_up_to_equivalence [of \<rho> r\<^sub>0 r\<^sub>1] \<rho>.tabulation_axioms by blast
	+ have w': "equivalence_map w'"
	+ using e equivalence_map_def by auto
	+ hence "is_induced_map w'"
	+ using e r_eq_s \<Delta>_eq_\<rho> is_induced_map_iff comp_assoc equivalence_map_is_ide by metis
	+ hence "isomorphic chine w'"
	+ using induced_map_unique chine_is_induced_map by simp
	+ thus ?thesis
	+ using w' equivalence_map_preserved_by_iso isomorphic_symmetric by blast
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ The following gives an interpretation of @{locale arrow_of_tabulations_in_maps}
	+ in the special case that the tabulations are those that we have chosen for the
	+ domain and codomain of the underlying 2-cell \<open>\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>\<close>.
	+ In this case, we can recover \<open>\<mu>\<close> from \<open>\<Delta>\<close> via adjoint transpose.
	+ \<close>
	+
	+ locale arrow_in_bicategory_of_spans =
	+ bicategory_of_spans V H \<a> \<i> src trg +
	+ r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r +
	+ s: identity_in_bicategory_of_spans V H \<a> \<i> src trg s
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and r :: 'a
	+ and s :: 'a
	+ and \<mu> :: 'a +
	+ assumes in_hom: "\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>"
	+ begin
	+
	+ abbreviation (input) r\<^sub>0 where "r\<^sub>0 \<equiv> tab\<^sub>0 r"
	+ abbreviation (input) r\<^sub>1 where "r\<^sub>1 \<equiv> tab\<^sub>1 r"
	+ abbreviation (input) s\<^sub>0 where "s\<^sub>0 \<equiv> tab\<^sub>0 s"
	+ abbreviation (input) s\<^sub>1 where "s\<^sub>1 \<equiv> tab\<^sub>1 s"
	+
	+ lemma is_arrow_of_tabulations_in_maps:
	+ shows "arrow_of_tabulations_in_maps V H \<a> \<i> src trg r r.tab r\<^sub>0 r\<^sub>1 s s.tab s\<^sub>0 s\<^sub>1 \<mu>"
	+ using in_hom by (unfold_locales, auto)
	+
	+ end
	+
	+ sublocale identity_in_bicategory_of_spans \<subseteq> arrow_in_bicategory_of_spans V H \<a> \<i> src trg r r r
	+ apply unfold_locales using is_ide by auto
	+
	+ context arrow_in_bicategory_of_spans
	+ begin
	+
	+ interpretation arrow_of_tabulations_in_maps V H \<a> \<i> src trg r r.tab r\<^sub>0 r\<^sub>1 s s.tab s\<^sub>0 s\<^sub>1 \<mu>
	+ using is_arrow_of_tabulations_in_maps by simp
	+ interpretation r: arrow_of_tabulations_in_maps V H \<a> \<i> src trg r r.tab r\<^sub>0 r\<^sub>1 r r.tab r\<^sub>0 r\<^sub>1 r
	+ using r.is_arrow_of_tabulations_in_maps by simp
	+
	+ lemma \<mu>_in_terms_of_\<Delta>:
	+ shows "\<mu> = r.T0.trnr\<^sub>\<epsilon> (cod \<mu>) \<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab)"
	+ proof -
	+ have \<mu>: "arr \<mu>"
	+ using in_hom by auto
	+ have "\<mu> \<cdot> r.T0.trnr\<^sub>\<epsilon> r r.tab = r.T0.trnr\<^sub>\<epsilon> s \<Delta>"
	+ proof -
	+ have "\<mu> \<cdot> r.T0.trnr\<^sub>\<epsilon> r r.tab =
	+ (\<mu> \<cdot> \<r>[r]) \<cdot> (r \<star> r.\<epsilon>) \<cdot> \<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>] \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>)"
	+ unfolding r.T0.trnr\<^sub>\<epsilon>_def using comp_assoc by simp
	+ also have "... = \<r>[s] \<cdot> ((\<mu> \<star> src \<mu>) \<cdot> (r \<star> r.\<epsilon>)) \<cdot>
	+ \<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>] \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>)"
	+ using \<mu> runit_naturality comp_assoc
	+ by (metis in_hom in_homE)
	+ also have "... = \<r>[s] \<cdot> (s \<star> r.\<epsilon>) \<cdot> ((\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*) \<cdot>
	+ \<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>]) \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>)"
	+ proof -
	+ have "(\<mu> \<star> src \<mu>) \<cdot> (r \<star> r.\<epsilon>) = \<mu> \<star> r.\<epsilon>"
	+ using \<mu> interchange comp_arr_dom comp_cod_arr
	+ by (metis in_hom in_homE r.T0.counit_simps(1) r.T0.counit_simps(3) r.u_simps(3)
	+ src_dom)
	+ also have "... = (s \<star> r.\<epsilon>) \<cdot> (\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ using in_hom interchange [of s \<mu> r.\<epsilon> "tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*"]
	+ comp_arr_dom comp_cod_arr r.T0.counit_simps(1) r.T0.counit_simps(2)
	+ by auto
	+ finally have "(\<mu> \<star> src \<mu>) \<cdot> (r \<star> r.\<epsilon>) = (s \<star> r.\<epsilon>) \<cdot> (\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ by blast
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<r>[s] \<cdot> (s \<star> r.\<epsilon>) \<cdot> \<a>[s, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot>
	+ ((\<mu> \<star> tab\<^sub>0 r) \<star> (tab\<^sub>0 r)\<^sup>) \<cdot> (r.tab \<star> (tab\<^sub>0 r)\<^sup>)"
	+ proof -
	+ have "(\<mu> \<star> tab\<^sub>0 r \<star> (tab\<^sub>0 r)\<^sup>) \<cdot> \<a>[r, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>] =
	+ \<a>[s, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>] \<cdot> ((\<mu> \<star> tab\<^sub>0 r) \<star> (tab\<^sub>0 r)\<^sup>)"
	+ using \<mu> assoc_naturality [of \<mu> "tab\<^sub>0 r" "(tab\<^sub>0 r)\<^sup>*"] hseqI'
	+ by (metis ide_char in_hom in_homE r.T0.antipar(1) r.T0.ide_right r.u_simps(3)
	+ src_dom u_simps(2) u_simps(4-5))
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<r>[s] \<cdot> (s \<star> r.\<epsilon>) \<cdot> \<a>[s, tab\<^sub>0 r, (tab\<^sub>0 r)\<^sup>*] \<cdot>
	+ ((\<mu> \<star> tab\<^sub>0 r) \<cdot> r.tab \<star> (tab\<^sub>0 r)\<^sup>*)"
	+ using \<mu> whisker_right hseqI' \<Delta>_simps(1) by auto
	+ also have "... = r.T0.trnr\<^sub>\<epsilon> s \<Delta>"
	+ unfolding r.T0.trnr\<^sub>\<epsilon>_def by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using \<mu> r.yields_isomorphic_representation invert_side_of_triangle(2)
	+ by (metis in_hom in_homE seqI')
	+ qed
	+
	+ end
	+
	+ subsubsection "Vertical Composite"
	+
	+ locale vertical_composite_of_arrows_of_tabulations_in_maps =
	+ bicategory_of_spans V H \<a> \<i> src trg +
	+ \<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
	+ \<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 +
	+ \<tau>: tabulation_in_maps V H \<a> \<i> src trg t \<tau> t\<^sub>0 t\<^sub>1 +
	+ \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 \<mu> +
	+ \<pi>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 \<pi>
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and r :: 'a
	+ and \<rho> :: 'a
	+ and r\<^sub>0 :: 'a
	+ and r\<^sub>1 :: 'a
	+ and s :: 'a
	+ and \<sigma> :: 'a
	+ and s\<^sub>0 :: 'a
	+ and s\<^sub>1 :: 'a
	+ and t :: 'a
	+ and \<tau> :: 'a
	+ and t\<^sub>0 :: 'a
	+ and t\<^sub>1 :: 'a
	+ and \<mu> :: 'a
	+ and \<pi> :: 'a
	+ begin
	+
	+ text \<open>
	+$$
	+\xymatrix{
	+ &&& {\rm src}~\tau \ar[dl]_{t_1} \ar[dr]^{t_0} \dtwocell\omit{^<-1>\tau} & \\
	+ &&{\rm trg}~t && {\rm src}~t \ar[ll]^{s} \\
	+ && \rrtwocell\omit{^\pi} && \\
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \ar[uuur]^<>(0.3){\pi.{\rm chine}} \dtwocell\omit{^<-1>\sigma} & \\
	+ &{\rm trg}~s \ar@ {=}[uuur] && {\rm src}~s \ar[ll]^{s} \ar@ {=}[uuur] \\
	+ & \rrtwocell\omit{^\mu} &&\\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \ar[uuur]^<>(0.3){\mu.{\rm chine}} \dtwocell\omit{^\rho} & \\
	+ {\rm trg}~r \ar@ {=}[uuur] && {\rm src}~r \ar[ll]^{r} \ar@ {=}[uuur]
	+}
	+$$
	+ \<close>
	+
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ interpretation arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 \<open>\<pi> \<cdot> \<mu>\<close>
	+ using \<mu>.in_hom \<pi>.in_hom by (unfold_locales, blast)
	+
	+ lemma is_arrow_of_tabulations_in_maps:
	+ shows "arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 (\<pi> \<cdot> \<mu>)"
	+ ..
	+
	+ lemma chine_char:
	+ shows "chine \<cong> \<pi>.chine \<star> \<mu>.chine"
	+ proof -
	+ have "is_induced_map (\<pi>.chine \<star> \<mu>.chine)"
	+ proof -
	+ let ?f = "\<mu>.chine"
	+ have f: "\<guillemotleft>?f : src \<rho> \<rightarrow> src \<sigma>\<guillemotright> \<and> is_left_adjoint ?f \<and> ide ?f \<and> \<mu>.is_induced_map ?f"
	+ using \<mu>.chine_is_induced_map \<mu>.is_map by auto
	+ let ?g = "\<pi>.chine"
	+ have g: "\<guillemotleft>?g : src \<sigma> \<rightarrow> src \<tau>\<guillemotright> \<and> is_left_adjoint ?g \<and> ide ?g \<and> \<pi>.is_induced_map ?g"
	+ using \<pi>.chine_is_induced_map \<pi>.is_map by auto
	+ let ?\<theta> = "\<mu>.the_\<theta> \<cdot> (\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]"
	+ let ?\<nu> = "\<a>[t\<^sub>1, ?g, ?f] \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
	+ have \<theta>: "\<guillemotleft>?\<theta> : t\<^sub>0 \<star> ?g \<star> ?f \<Rightarrow> r\<^sub>0\<guillemotright>"
	+ using f g \<pi>.the_\<theta>_props \<mu>.the_\<theta>_props
	+ by (intro comp_in_homI hcomp_in_vhom, auto+)
	+ have \<nu>: "\<guillemotleft>?\<nu> : r\<^sub>1 \<Rightarrow> t\<^sub>1 \<star> ?g \<star> ?f\<guillemotright>"
	+ using f g \<pi>.the_\<theta>_props \<mu>.the_\<theta>_props
	+ by (intro comp_in_homI hcomp_in_vhom, auto)
	+ interpret gf: arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 r\<^sub>1 t\<^sub>0 t\<^sub>1 \<open>?g \<star> ?f\<close>
	+ proof
	+ show "ide (?g \<star> ?f)" by simp
	+ show "\<exists>\<theta>. \<guillemotleft>\<theta> : t\<^sub>0 \<star> ?g \<star> ?f \<Rightarrow> r\<^sub>0\<guillemotright>"
	+ using \<theta> by auto
	+ show "\<exists>\<nu>. \<guillemotleft>\<nu> : r\<^sub>1 \<Rightarrow> t\<^sub>1 \<star> ?g \<star> ?f\<guillemotright> \<and> iso \<nu>"
	+ using \<nu> \<mu>.the_\<nu>_props \<mu>.the_\<theta>_props \<pi>.the_\<nu>_props \<pi>.the_\<theta>_props hseqI' isos_compose
	+ by auto
	+ qed
	+ show ?thesis
	+ proof (intro conjI)
	+ have \<theta>_eq: "?\<theta> = gf.the_\<theta>"
	+ using \<theta> gf.the_\<theta>_props gf.leg0_uniquely_isomorphic by auto
	+ have \<nu>_eq: "?\<nu> = gf.the_\<nu>"
	+ using \<nu> gf.the_\<nu>_props gf.leg1_uniquely_isomorphic by auto
	+ have A: "src ?g = trg ?f"
	+ using f g by fastforce
	+ show "arrow_of_spans_of_maps V H \<a> \<i> src trg r\<^sub>0 (dom \<Delta>) t\<^sub>0 t\<^sub>1 (?g \<star> ?f)"
	+ using gf.arrow_of_spans_of_maps_axioms by simp
	+ have "((t \<star> gf.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f)) \<cdot> gf.the_\<nu> = \<Delta>"
	+ proof -
	+ have "\<Delta> = (\<pi> \<star> r\<^sub>0) \<cdot> (\<mu> \<star> r\<^sub>0) \<cdot> \<rho>"
	+ using whisker_right comp_assoc
	+ by (metis \<Delta>_simps(1) hseqE ide_u seqE)
	+ also have "... = ((\<pi> \<star> r\<^sub>0) \<cdot> (s \<star> \<mu>.the_\<theta>)) \<cdot> \<a>[s, s\<^sub>0, ?f] \<cdot> (\<sigma> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
	+ using \<mu>.\<Delta>_naturality comp_assoc by simp
	+ also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> ((\<pi> \<star> s\<^sub>0 \<star> ?f) \<cdot> \<a>[s, s\<^sub>0, ?f]) \<cdot> (\<sigma> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
	+ proof -
	+ have "(\<pi> \<star> r\<^sub>0) \<cdot> (s \<star> \<mu>.the_\<theta>) = \<pi> \<star> \<mu>.the_\<theta>"
	+ using f comp_arr_dom comp_cod_arr \<mu>.the_\<theta>_props \<pi>.in_hom
	+ interchange [of \<pi> s r\<^sub>0 \<mu>.the_\<theta>]
	+ by auto
	+ also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (\<pi> \<star> s\<^sub>0 \<star> ?f)"
	+ using f comp_arr_dom comp_cod_arr \<mu>.the_\<theta>_props \<pi>.in_hom
	+ interchange [of t \<pi> \<mu>.the_\<theta> "s\<^sub>0 \<star> ?f"]
	+ by auto
	+ finally have "(\<pi> \<star> r\<^sub>0) \<cdot> (s \<star> \<mu>.the_\<theta>) = (t \<star> \<mu>.the_\<theta>) \<cdot> (\<pi> \<star> s\<^sub>0 \<star> ?f)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot> (((\<pi> \<star> s\<^sub>0) \<star> ?f) \<cdot> (\<sigma> \<star> ?f)) \<cdot> \<mu>.the_\<nu>"
	+ proof -
	+ have "(\<pi> \<star> s\<^sub>0 \<star> ?f) \<cdot> \<a>[s, s\<^sub>0, ?f] = \<a>[t, s\<^sub>0, ?f] \<cdot> ((\<pi> \<star> s\<^sub>0) \<star> ?f)"
	+ using f assoc_naturality [of \<pi> s\<^sub>0 ?f] \<pi>.in_hom by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot> (\<pi>.\<Delta> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
	+ using whisker_right comp_assoc by simp
	+ also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot>
	+ ((t \<star> \<pi>.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g] \<cdot> (\<tau> \<star> ?g) \<cdot> \<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
	+ using \<pi>.\<Delta>_naturality by simp
	+ also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> \<a>[t, s\<^sub>0, ?f] \<cdot>
	+ (((t \<star> \<pi>.the_\<theta>) \<star> ?f) \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f) \<cdot> ((\<tau> \<star> ?g) \<star> ?f) \<cdot>
	+ (\<pi>.the_\<nu> \<star> ?f)) \<cdot> \<mu>.the_\<nu>"
	+ using f g \<pi>.the_\<theta>_props \<pi>.the_\<nu>_props whisker_right
	+ by (metis \<pi>.\<Delta>_simps(1) \<pi>.\<Delta>_naturality seqE)
	+ also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (\<a>[t, s\<^sub>0, ?f] \<cdot>
	+ ((t \<star> \<pi>.the_\<theta>) \<star> ?f)) \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f) \<cdot> ((\<tau> \<star> ?g) \<star> ?f) \<cdot>
	+ (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
	+ using comp_assoc by simp
	+ also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (t \<star> \<pi>.the_\<theta> \<star> ?f) \<cdot>
	+ (\<a>[t, t\<^sub>0 \<star> ?g, ?f] \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f)) \<cdot>
	+ ((\<tau> \<star> ?g) \<star> ?f) \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
	+ using f \<pi>.the_\<theta>_props assoc_naturality [of t "\<pi>.the_\<theta>" ?f] \<pi>.\<theta>_simps(3) comp_assoc
	+ by auto
	+ also have "... = (t \<star> \<mu>.the_\<theta>) \<cdot> (t \<star> \<pi>.the_\<theta> \<star> ?f) \<cdot>
	+ (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<a>[t \<star> t\<^sub>0, ?g, ?f] \<cdot>
	+ ((\<tau> \<star> ?g) \<star> ?f)) \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
	+ proof -
	+ have "seq \<a>[t, t\<^sub>0, ?g \<star> ?f] \<a>[t \<star> t\<^sub>0, ?g, ?f]"
	+ using f g by fastforce
	+ moreover have "inv (t \<star> \<a>[t\<^sub>0, ?g, ?f]) = t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]"
	+ using f g by simp
	+ moreover have "iso (t \<star> \<a>[t\<^sub>0, ?g, ?f])"
	+ using f g by simp
	+ have "\<a>[t, t\<^sub>0 \<star> ?g, ?f] \<cdot> (\<a>[t, t\<^sub>0, ?g] \<star> ?f) =
	+ (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> \<a>[t \<star> t\<^sub>0, ?g, ?f]"
	+ proof -
	+ have "seq \<a>[t, t\<^sub>0, ?g \<star> ?f] \<a>[t \<star> t\<^sub>0, ?g, ?f]"
	+ using f g by fastforce
	+ moreover have "inv (t \<star> \<a>[t\<^sub>0, ?g, ?f]) = t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]"
	+ using f g by simp
	+ moreover have "iso (t \<star> \<a>[t\<^sub>0, ?g, ?f])"
	+ using f g by simp
	+ ultimately show ?thesis
	+ using A f g pentagon hseqI' invert_side_of_triangle(1)
	+ by (metis \<pi>.w_simps(4) \<tau>.ide_base \<tau>.ide_leg0 \<tau>.leg0_simps(3))
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((t \<star> \<mu>.the_\<theta>) \<cdot> (t \<star> \<pi>.the_\<theta> \<star> ?f)) \<cdot>
	+ (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f) \<cdot>
	+ \<a>[t\<^sub>1, ?g, ?f] \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
	+ using f g assoc_naturality [of \<tau> ?g ?f] comp_assoc by simp
	+ also have "... = (t \<star> \<mu>.the_\<theta> \<cdot> (\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f]) \<cdot>
	+ \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot>
	+ (\<tau> \<star> ?g \<star> ?f) \<cdot> \<a>[t\<^sub>1, ?g, ?f] \<cdot> (\<pi>.the_\<nu> \<star> ?f) \<cdot> \<mu>.the_\<nu>"
	+ proof -
	+ have 1: "seq \<mu>.the_\<theta> ((\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f])"
	+ using \<theta>_eq by auto
	+ hence "t \<star> (\<pi>.the_\<theta> \<star> ?f) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f] =
	+ (t \<star> \<pi>.the_\<theta> \<star> ?f) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, ?g, ?f])"
	+ using whisker_left \<tau>.ide_base by blast
	+ thus ?thesis
	+ using 1 whisker_left \<tau>.ide_base comp_assoc by presburger
	+ qed
	+ also have "... = ((t \<star> gf.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f)) \<cdot> gf.the_\<nu>"
	+ using \<theta>_eq \<nu>_eq by (simp add: comp_assoc)
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ thus "((t \<star> gf.the_\<theta>) \<cdot> \<a>[t, t\<^sub>0, ?g \<star> ?f] \<cdot> (\<tau> \<star> ?g \<star> ?f)) \<cdot>
	+ arrow_of_spans_of_maps.the_\<nu> (\<cdot>) (\<star>) (dom ((\<pi> \<cdot> \<mu> \<star> r\<^sub>0) \<cdot> \<rho>)) t\<^sub>1 (?g \<star> ?f) =
	+ \<Delta>"
	+ by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using chine_is_induced_map induced_map_unique by simp
	+ qed
	+
	+ end
	+
	+ sublocale vertical_composite_of_arrows_of_tabulations_in_maps \<subseteq>
	+ arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 "\<pi> \<cdot> \<mu>"
	+ using is_arrow_of_tabulations_in_maps by simp
	+
	+ subsubsection "Horizontal Composite"
	+
	+ locale horizontal_composite_of_arrows_of_tabulations_in_maps =
	+ bicategory_of_spans V H \<a> \<i> src trg +
	+ \<rho>: tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 +
	+ \<sigma>: tabulation_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 +
	+ \<tau>: tabulation_in_maps V H \<a> \<i> src trg t \<tau> t\<^sub>0 t\<^sub>1 +
	+ \<mu>: tabulation_in_maps V H \<a> \<i> src trg u \<mu> u\<^sub>0 u\<^sub>1 +
	+ \<rho>\<sigma>: composite_tabulation_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 s \<sigma> s\<^sub>0 s\<^sub>1 +
	+ \<tau>\<mu>: composite_tabulation_in_maps V H \<a> \<i> src trg t \<tau> t\<^sub>0 t\<^sub>1 u \<mu> u\<^sub>0 u\<^sub>1 +
	+ \<omega>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg r \<rho> r\<^sub>0 r\<^sub>1 t \<tau> t\<^sub>0 t\<^sub>1 \<omega> +
	+ \<chi>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg s \<sigma> s\<^sub>0 s\<^sub>1 u \<mu> u\<^sub>0 u\<^sub>1 \<chi>
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and r :: 'a
	+ and \<rho> :: 'a
	+ and r\<^sub>0 :: 'a
	+ and r\<^sub>1 :: 'a
	+ and s :: 'a
	+ and \<sigma> :: 'a
	+ and s\<^sub>0 :: 'a
	+ and s\<^sub>1 :: 'a
	+ and t :: 'a
	+ and \<tau> :: 'a
	+ and t\<^sub>0 :: 'a
	+ and t\<^sub>1 :: 'a
	+ and u :: 'a
	+ and \<mu> :: 'a
	+ and u\<^sub>0 :: 'a
	+ and u\<^sub>1 :: 'a
	+ and \<omega> :: 'a
	+ and \<chi> :: 'a
	+ begin
	+
	+ text \<open>
	+$$
	+\xymatrix{
	+ &&& {\rm src}~t_0u_1.\phi \ar[dl]_{\tau\mu.p_1} \ar[dr]^{\tau\mu.p_0} \ddtwocell\omit{^{t_0u_1.\phi}} \\
	+ && {\rm src}~\tau \ar[dl]_{t_1} \ar[dr]^<>(0.4){t_0} \dtwocell\omit{^<-1>\tau}
	+ && {\rm src}~\mu \ar[dl]_{u_1} \ar[dr]^{u_0} \dtwocell\omit{^<-1>\mu} & \\
	+ & {\rm trg}~t && {\rm src}~t = {\rm trg}~u \ar[ll]^{t}
	+ && {\rm src}~u \ar[ll]^{u} \\
	+ & \xtwocell[r]{}\omit{^\omega}
	+ & {\rm src}~r_0s_1.\phi \ar[uuur]_<>(0.2){{\rm chine}}
	+ \ar[dl]^{\rho\sigma.p_1} \ar[dr]_{\rho\sigma.p_0\hspace{20pt}} \ddtwocell\omit{^{r_0s_1.\phi}}
	+ & \rrtwocell\omit{^\chi} && \\
	+ & {\rm src}~\rho \ar[dl]_{r_1} \ar[dr]^{r_0} \ar[uuur]^<>(0.4){\omega.{\rm chine}} \dtwocell\omit{^\rho}
	+ && {\rm src}~\sigma \ar[dl]_{s_1} \ar[dr]^{s_0} \ar[uuur]^<>(0.4){\chi.{\rm chine}} \dtwocell\omit{^<-1>\sigma} & \\
	+ {\rm trg}~r \ar@ {=}[uuur] && {\rm src}~r = {\rm trg}~s \ar[ll]^{r} \ar@ {=}[uuur]
	+ && {\rm src}~s \ar[ll]^{s} \ar@ {=}[uuur] \\
	+}
	+$$
	+ \<close>
	+
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ interpretation arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>r \<star> s\<close> \<rho>\<sigma>.tab \<open>s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0\<close> \<open>r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>t \<star> u\<close> \<tau>\<mu>.tab \<open>u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0\<close> \<open>t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1\<close> \<open>\<omega> \<star> \<chi>\<close>
	+ using \<rho>\<sigma>.composable \<omega>.in_hom \<chi>.in_hom hseqI'
	+ by (unfold_locales, auto)
	+
	+ lemma is_arrow_of_tabulations_in_maps:
	+ shows "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ (r \<star> s) \<rho>\<sigma>.tab (s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) (r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1)
	+ (t \<star> u) \<tau>\<mu>.tab (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) (\<omega> \<star> \<chi>)"
	+ ..
	+
	+ sublocale arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>r \<star> s\<close> \<rho>\<sigma>.tab \<open>s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0\<close> \<open>r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>t \<star> u\<close> \<tau>\<mu>.tab \<open>u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0\<close> \<open>t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1\<close> \<open>\<omega> \<star> \<chi>\<close>
	+ using is_arrow_of_tabulations_in_maps by simp
	+
	+ interpretation Maps: maps_category V H \<a> \<i> src trg ..
	+ notation Maps.comp (infixr "\<odot>" 55)
	+
	+ interpretation r\<^sub>0s\<^sub>1: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg s\<^sub>1 r\<^sub>0
	+ using \<rho>.leg0_is_map \<sigma>.leg1_is_map \<rho>\<sigma>.composable apply unfold_locales by auto
	+ interpretation r\<^sub>0s\<^sub>1: arrow_of_tabulations_in_maps \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
	+ \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close> r\<^sub>0s\<^sub>1.tab r\<^sub>0s\<^sub>1.p\<^sub>0 r\<^sub>0s\<^sub>1.p\<^sub>1
	+ \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close> r\<^sub>0s\<^sub>1.tab r\<^sub>0s\<^sub>1.p\<^sub>0 r\<^sub>0s\<^sub>1.p\<^sub>1
	+ \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close>
	+ using r\<^sub>0s\<^sub>1.is_arrow_of_tabulations_in_maps by simp
	+ interpretation t\<^sub>0u\<^sub>1: cospan_of_maps_in_bicategory_of_spans \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg u\<^sub>1 t\<^sub>0
	+ using \<tau>.leg0_is_map \<mu>.leg1_is_map \<tau>\<mu>.composable apply unfold_locales by auto
	+ interpretation t\<^sub>0u\<^sub>1: arrow_of_tabulations_in_maps \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
	+ \<open>t\<^sub>0\<^sup>* \<star> u\<^sub>1\<close> t\<^sub>0u\<^sub>1.tab t\<^sub>0u\<^sub>1.p\<^sub>0 t\<^sub>0u\<^sub>1.p\<^sub>1
	+ \<open>t\<^sub>0\<^sup>* \<star> u\<^sub>1\<close> t\<^sub>0u\<^sub>1.tab t\<^sub>0u\<^sub>1.p\<^sub>0 t\<^sub>0u\<^sub>1.p\<^sub>1
	+ \<open>t\<^sub>0\<^sup>* \<star> u\<^sub>1\<close>
	+ using t\<^sub>0u\<^sub>1.is_arrow_of_tabulations_in_maps by simp
	+
	+ interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+
	+ text \<open>
	+ The following lemma states that the rectangular faces of the ``top prism'' commute
	+ up to isomorphism. This was not already proved in @{locale composite_tabulation_in_maps},
	+ because there we did not consider any composite structure of the ``source'' 2-cell.
	+ There are common elements, though to the proof that the composite of tabulations is
	+ a tabulation and the present lemma.
	+ The proof idea is to use property \<open>T2\<close> of the ``base'' tabulations to establish the
	+ existence of the desired isomorphisms. The proofs have to be carried out in
	+ sequence, starting from the ``output'' side, because the arrow \<open>\<beta>\<close> required in the
	+ hypotheses of \<open>T2\<close> depends, for the ``input'' tabulation, on the isomorphism constructed
	+ for the ``output'' tabulation.
	+ \<close>
	+
	+ lemma prj_chine:
	+ shows "\<tau>\<mu>.p\<^sub>0 \<star> chine \<cong> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
	+ and "\<tau>\<mu>.p\<^sub>1 \<star> chine \<cong> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
	+ proof -
	+ have 1: "arrow_of_spans_of_maps V H \<a> \<i> src trg
	+ (s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) (r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1) (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) chine \<and>
	+ (((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>[t \<star> u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<tau>\<mu>.tab \<star> chine)) \<cdot> the_\<nu> =
	+ ((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<rho>\<sigma>.tab"
	+ using chine_is_induced_map by simp
	+ let ?u\<^sub>\<tau> = "u \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
	+ let ?w\<^sub>\<tau> = "\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
	+ let ?w\<^sub>\<tau>' = "\<tau>\<mu>.p\<^sub>1 \<star> chine"
	+ have u\<^sub>\<tau>: "ide ?u\<^sub>\<tau>"
	+ using \<chi>.u_simps(3) by auto
	+ have w\<^sub>\<tau>: "ide ?w\<^sub>\<tau> \<and> is_left_adjoint ?w\<^sub>\<tau>"
	+ by (simp add: \<omega>.is_map \<rho>.T0.antipar(1) left_adjoints_compose)
	+ have w\<^sub>\<tau>': "ide ?w\<^sub>\<tau>' \<and> is_left_adjoint ?w\<^sub>\<tau>'"
	+ by (simp add: is_map left_adjoints_compose)
	+ let ?\<theta>\<^sub>\<tau> = "\<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot> (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
	+ let ?\<theta>\<^sub>\<tau>' = "(u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]"
	+ let ?\<beta>\<^sub>\<tau> = "\<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
	+ have \<theta>\<^sub>\<tau>: "\<guillemotleft>?\<theta>\<^sub>\<tau> : t\<^sub>0 \<star> ?w\<^sub>\<tau> \<Rightarrow> ?u\<^sub>\<tau>\<guillemotright>"
	+ using \<rho>.T0.antipar(1) \<omega>.the_\<theta>_in_hom \<chi>.u_simps(3)
	+ apply (intro comp_in_homI, auto)
	+ by (intro hcomp_in_vhom, auto)
	+ have \<theta>\<^sub>\<tau>': "\<guillemotleft>?\<theta>\<^sub>\<tau>' : t\<^sub>0 \<star> ?w\<^sub>\<tau>' \<Rightarrow> ?u\<^sub>\<tau>\<guillemotright>"
	+ proof (intro comp_in_homI)
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] : t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine \<Rightarrow> (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine\<guillemotright>"
	+ using t\<^sub>0u\<^sub>1.p\<^sub>1_simps assoc'_in_hom by simp
	+ show "\<guillemotleft>t\<^sub>0u\<^sub>1.\<phi> \<star> chine : (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine \<Rightarrow> (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
	+ using \<tau>.T0.antipar(1)
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>(\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine : (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> ((u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine : ((u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> (u \<star> u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
	+ using assoc_in_hom by auto
	+ show "\<guillemotleft>\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] : (u \<star> u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> u \<star> (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
	+ by auto
	+ show "\<guillemotleft>u \<star> the_\<theta> : u \<star> (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> ?u\<^sub>\<tau>\<guillemotright>"
	+ by (intro hcomp_in_vhom, auto)
	+ qed
	+ have \<beta>\<^sub>\<tau>: "\<guillemotleft>?\<beta>\<^sub>\<tau> : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t\<^sub>1 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
	+ proof (intro comp_in_homI)
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> (t\<^sub>1 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
	+ using \<rho>.T0.antipar(1) by auto
	+ show "\<guillemotleft>inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1 : (t\<^sub>1 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
	+ using \<omega>.the_\<nu>_props \<rho>.T0.antipar(1)
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>the_\<nu> : r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine\<guillemotright>"
	+ using the_\<nu>_in_hom(2) by simp
	+ show "\<guillemotleft>\<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] : (t\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine \<Rightarrow> t\<^sub>1 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
	+ using t\<^sub>0u\<^sub>1.p\<^sub>1_simps assoc_in_hom by simp
	+ qed
	+ define LHS where "LHS = (t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>)"
	+ have LHS: "\<guillemotleft>LHS : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
	+ proof (unfold LHS_def, intro comp_in_homI)
	+ show "\<guillemotleft>\<tau> \<star> ?w\<^sub>\<tau> : t\<^sub>1 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> (t \<star> t\<^sub>0) \<star> ?w\<^sub>\<tau>\<guillemotright>"
	+ using \<rho>.T0.antipar(1)
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] : (t \<star> t\<^sub>0) \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau>\<guillemotright>"
	+ using \<rho>.T0.antipar(1) by auto
	+ show "\<guillemotleft>t \<star> ?\<theta>\<^sub>\<tau> : t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
	+ proof -
	+ have "src t = trg (t\<^sub>0 \<star> \<omega>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>1)"
	+ by (metis \<chi>.u_simps(3) \<mu>.ide_base \<sigma>.ide_leg0 \<sigma>.leg1_simps(3) \<tau>\<mu>.composable
	+ \<theta>\<^sub>\<tau> arrI assoc_simps(3) r\<^sub>0s\<^sub>1.ide_u r\<^sub>0s\<^sub>1.p\<^sub>0_simps trg_vcomp vconn_implies_hpar(2))
	+ thus ?thesis
	+ using \<theta>\<^sub>\<tau> by blast
	+ qed
	+ qed
	+ define RHS where "RHS = ((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) \<cdot> ?\<beta>\<^sub>\<tau>"
	+ have RHS: "\<guillemotleft>RHS : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
	+ unfolding RHS_def
	+ proof
	+ show "\<guillemotleft>?\<beta>\<^sub>\<tau> : t\<^sub>1 \<star> ?w\<^sub>\<tau> \<Rightarrow> t\<^sub>1 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
	+ using \<beta>\<^sub>\<tau> by simp
	+ show "\<guillemotleft>(t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') : t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>\<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') : t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<Rightarrow> t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau>'\<guillemotright>"
	+ using \<tau>.T0.antipar(1) by fastforce
	+ show "\<guillemotleft>t \<star> ?\<theta>\<^sub>\<tau>' : t \<star> t\<^sub>0 \<star> ?w\<^sub>\<tau>' \<Rightarrow> t \<star> ?u\<^sub>\<tau>\<guillemotright>"
	+ using w\<^sub>\<tau>' \<theta>\<^sub>\<tau>' \<tau>.leg0_simps(2) \<tau>.leg0_simps(3) hseqI' ideD(1) t\<^sub>0u\<^sub>1.p\<^sub>1_simps
	+ trg_hcomp' \<tau>.base_in_hom(2) hcomp_in_vhom
	+ by presburger
	+ qed
	+ qed
	+ have eq: "LHS = RHS"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) = \<Delta>"
	+ proof -
	+ text \<open>
	+ Here we use \<open>\<omega>.\<Delta>_naturality\<close> to replace @{term \<omega>.chine}
	+ in favor of @{term \<omega>}.
	+ We have to bring @{term \<omega>.the_\<nu>}, @{term \<tau>}, and @{term \<omega>.the_\<theta>} together,
	+ with @{term \<rho>\<sigma>.p\<^sub>1} on the right.
	+ \<close>
	+ have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
	+ \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
	+ (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
	+ (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
	+ \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<tau> \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot>
	+ (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ unfolding LHS_def
	+ using comp_assoc by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
	+ (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
	+ (t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
	+ \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<tau> \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
	+ \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
	+ (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
	+ (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
	+ (t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1])"
	+ using whisker_left \<tau>.ide_base \<theta>\<^sub>\<tau> arrI seqE
	+ by (metis (full_types))
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
	+ (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
	+ (t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> ((t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
	+ \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
	+ ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "(\<tau> \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
	+ \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using assoc_naturality
	+ by (metis \<omega>.w_simps(2-6) \<rho>.leg1_simps(3) \<rho>\<sigma>.leg1_simps(2) \<tau>.tab_simps(1)
	+ \<tau>.tab_simps(2,4-5) hseqE r\<^sub>0s\<^sub>1.leg1_simps(5) r\<^sub>0s\<^sub>1.leg1_simps(6))
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
	+ (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
	+ ((t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot>
	+ (\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
	+ (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "(t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot>
	+ \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
	+ \<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "seq \<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
	+ by (simp add: \<rho>.T0.antipar(1))
	+ moreover have "inv (t \<star> \<a>[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) = t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
	+ using \<rho>.T0.antipar(1) inv_hcomp [of t "\<a>[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"] by simp
	+ ultimately show ?thesis
	+ using pentagon \<rho>.T0.antipar(1) iso_hcomp
	+ invert_side_of_triangle(1)
	+ [of "\<a>[t, t\<^sub>0, \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1] \<cdot> \<a>[t \<star> t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
	+ "t \<star> \<a>[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
	+ "\<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1)"]
	+ by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
	+ (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
	+ \<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (((t \<star> \<omega>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
	+ (\<a>[t, t\<^sub>0, \<omega>.chine] \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> ((\<tau> \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1)) \<cdot>
	+ (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "(t \<star> \<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>[t, t\<^sub>0 \<star> \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] =
	+ \<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((t \<star> \<omega>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using assoc_naturality [of t \<omega>.the_\<theta> \<rho>\<sigma>.p\<^sub>1] \<omega>.\<theta>_simps(3) \<rho>\<sigma>.leg1_simps(2) hseq_char
	+ by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
	+ (t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
	+ \<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<cdot> \<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using whisker_right \<rho>.T0.antipar(1) \<omega>.\<Delta>_simps(1) \<omega>.\<Delta>_naturality comp_assoc
	+ by fastforce
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> ((t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
	+ (t \<star> (\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
	+ \<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<cdot> \<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "t \<star> (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0 = (t \<star> (\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)"
	+ using whisker_left whisker_right \<rho>.T0.antipar(1)
	+ by (metis (full_types) \<chi>.\<Delta>_simps(1) \<tau>.ide_base \<theta>\<^sub>\<tau> arrI r\<^sub>0s\<^sub>1.ide_u seqE)
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
	+ \<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<cdot> \<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "(t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> (\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0) =
	+ t \<star> \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>0)"
	+ using hseqI' \<chi>.in_hom whisker_left by auto
	+ also have "... = t \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]"
	+ using assoc_naturality [of \<chi> s\<^sub>0 \<rho>\<sigma>.p\<^sub>0] \<chi>.in_hom by auto
	+ also have "... = (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0])"
	+ proof -
	+ have "seq (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]"
	+ using hseqI' \<chi>.in_hom
	+ apply (intro seqI hseqI)
	+ apply auto
	+ proof -
	+ show "\<guillemotleft>\<chi> : src u \<rightarrow> trg \<chi>\<guillemotright>"
	+ by (metis \<chi>.\<Delta>_simps(1) \<chi>.u_simps(3) hseqE in_hhom_def seqE)
	+ show "dom (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) = s \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
	+ by (metis \<Delta>_simps(1) \<chi>.in_hom hcomp_simps(1,3) hseq_char in_homE seqE
	+ u_simps(4))
	+ qed
	+ thus ?thesis
	+ using whisker_left by simp
	+ qed
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
	+ (\<a>[t, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> ((\<omega> \<star> r\<^sub>0) \<star> \<rho>\<sigma>.p\<^sub>1)) \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using whisker_right comp_assoc by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot>
	+ (\<omega> \<star> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1)) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using assoc_naturality [of \<omega> r\<^sub>0 \<rho>\<sigma>.p\<^sub>1] \<omega>.in_hom \<rho>.T0.antipar(1) comp_assoc
	+ by fastforce
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> ((t \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ (t \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (t \<star> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "(t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> (\<omega> \<star> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1) = \<omega> \<star> r\<^sub>0s\<^sub>1.\<phi>"
	+ using comp_cod_arr comp_arr_dom \<omega>.in_hom interchange comp_ide_arr
	+ by (metis \<tau>.base_in_hom(2) \<tau>.ide_base r\<^sub>0s\<^sub>1.\<phi>_simps(1) r\<^sub>0s\<^sub>1.\<phi>_simps(4) seqI')
	+ also have "... = (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi>)"
	+ using r\<^sub>0s\<^sub>1.\<phi>_in_hom comp_cod_arr comp_arr_dom \<omega>.in_hom interchange
	+ by (metis in_homE)
	+ finally have "(t \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> (\<omega> \<star> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1) = (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (r \<star> r\<^sub>0s\<^sub>1.\<phi>)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
	+ ((t \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
	+ (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
	+ (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using whisker_left \<rho>.T0.antipar(1) \<rho>\<sigma>.composable \<chi>.in_hom hseqI' comp_assoc by auto
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
	+ (\<omega> \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
	+ (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "(t \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (\<omega> \<star> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0) =
	+ \<omega> \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)"
	+ proof -
	+ have "\<guillemotleft>(\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) : s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0 \<Rightarrow> u \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
	+ using \<omega>.in_hom \<chi>.in_hom hseqI'
	+ apply (intro comp_in_homI hcomp_in_vhom, auto)
	+ by auto
	+ thus ?thesis
	+ by (metis (no_types) \<omega>.in_hom comp_arr_dom comp_cod_arr in_homE
	+ interchange)
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
	+ (\<omega> \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> (r \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
	+ (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "\<omega> \<star> (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) =
	+ (\<omega> \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (r \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0))"
	+ proof -
	+ have "seq (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) (\<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0))"
	+ using \<chi>.in_hom hseqI'
	+ apply (intro seqI hseqI, auto)
	+ proof -
	+ show "\<guillemotleft>\<chi> : src u \<rightarrow> trg \<chi>\<guillemotright>"
	+ using \<chi>.in_hom by auto
	+ show "dom (\<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) = s \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
	+ using \<chi>.in_hom hseqI' in_hom by fastforce
	+ qed
	+ thus ?thesis
	+ using comp_arr_dom comp_cod_arr \<omega>.in_hom \<chi>.in_hom hseqI' interchange
	+ by (metis in_homE)
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (r \<star> \<a>[s, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<sigma> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
	+ (r \<star> r\<^sub>0s\<^sub>1.\<phi>) \<cdot> \<a>[r, r\<^sub>0, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<rho> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<omega> \<star> \<chi> \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) =
	+ ((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[r, s, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0]"
	+ using assoc_naturality \<omega>.in_hom \<chi>.in_hom
	+ by (metis \<rho>\<sigma>.leg0_simps(3) assoc'_naturality hcomp_in_vhomE in_hom in_homE
	+ u_simps(2) u_simps(4) u_simps(5))
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<Delta>"
	+ using whisker_left hseqI' \<rho>\<sigma>.tab_def comp_assoc by simp
	+ finally show ?thesis by auto
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ proof -
	+ text \<open>Now cancel @{term \<omega>.the_\<nu>} and its inverse.\<close>
	+ have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
	+ \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
	+ (t \<star> (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
	+ (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
	+ (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
	+ \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> (\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot>
	+ \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ unfolding RHS_def
	+ using comp_assoc by presburger
	+ also have "... = \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
	+ (t \<star> (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
	+ (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
	+ (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
	+ \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> (\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot>
	+ \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu>"
	+ proof -
	+ have "the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
	+ the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
	+ ((t\<^sub>1 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using comp_inv_arr \<rho>.T0.antipar(1) comp_assoc_assoc' by simp
	+ also have "... = the_\<nu> \<cdot> (inv \<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using comp_cod_arr hseqI' \<rho>.T0.antipar(1) by simp
	+ also have "... = the_\<nu> \<cdot> (r\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using whisker_right [of \<rho>\<sigma>.p\<^sub>1] r\<^sub>0s\<^sub>1.ide_leg1 \<omega>.the_\<nu>_props(2) \<omega>.the_\<nu>_simps(4)
	+ \<rho>.leg1_simps(2) comp_inv_arr'
	+ by metis
	+ also have "... = the_\<nu>"
	+ using comp_arr_dom by simp
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ text \<open>
	+ Now reassociate to move @{term the_\<theta>} to the left and get other terms composed
	+ with @{term chine}, where they can be reduced to @{term \<tau>\<mu>.tab}.
	+ \<close>
	+ also have "... = (\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot>
	+ (t \<star> u \<star> the_\<theta>)) \<cdot> (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
	+ (t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
	+ \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> (\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot>
	+ \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> the_\<nu>"
	+ proof -
	+ have "arr ((u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
	+ using \<theta>\<^sub>\<tau>' by blast
	+ moreover have "arr (\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
	+ using calculation by blast
	+ moreover have "arr ((\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
	+ using calculation by blast
	+ moreover have "arr (((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
	+ using calculation by blast
	+ moreover have "arr ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
	+ using calculation by blast
	+ ultimately
	+ have "t \<star> (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> (t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] =
	+ (t \<star> u \<star> the_\<theta>) \<cdot> (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
	+ (t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine])"
	+ using \<theta>\<^sub>\<tau>' whisker_left hseqI' \<rho>.T0.antipar(1) seqE \<tau>.ide_base by presburger
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
	+ (t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ (t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot>
	+ ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot> \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> the_\<nu>"
	+ using assoc'_naturality [of t u the_\<theta>] \<tau>\<mu>.composable \<theta>_simps(3) comp_assoc by auto
	+ also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
	+ (t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ ((t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot>
	+ \<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
	+ proof -
	+ have "(\<tau> \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine) \<cdot> \<a>[t\<^sub>1, \<tau>\<mu>.p\<^sub>1, chine] =
	+ \<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine)"
	+ using assoc_naturality
	+ by (metis \<tau>.leg1_simps(3) \<tau>.tab_simps(1,2,4) \<tau>.tab_simps(5) \<tau>\<mu>.leg0_simps(2)
	+ \<tau>\<mu>.leg1_simps(2) hseqE src_hcomp' t\<^sub>0u\<^sub>1.leg1_simps(3,5-6) w_simps(2)
	+ w_simps(4-6))
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ (t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot>
	+ ((t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
	+ (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
	+ proof -
	+ have "(t \<star> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot>
	+ \<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] =
	+ \<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine)"
	+ using pentagon t\<^sub>0u\<^sub>1.p\<^sub>1_simps uw\<theta> \<tau>.T0.antipar(1) hseqI' iso_hcomp
	+ comp_assoc_assoc'
	+ invert_side_of_triangle(1)
	+ [of "\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1 \<star> chine] \<cdot> \<a>[t \<star> t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]"
	+ "t \<star> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]"
	+ "\<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine)"]
	+ by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ ((t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>[t, u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
	+ ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
	+ (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
	+ proof -
	+ have "(t \<star> t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>[t, t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1, chine] =
	+ \<a>[t, u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine)"
	+ using assoc_naturality [of t t\<^sub>0u\<^sub>1.\<phi> chine] t\<^sub>0u\<^sub>1.cospan by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
	+ ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
	+ (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
	+ proof -
	+ have "(t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>[t, u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0, chine] =
	+ \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> ((t \<star> (\<mu> \<star> \<tau>\<mu>.p\<^sub>0)) \<star> chine)"
	+ using assoc_naturality [of t "\<mu> \<star> \<tau>\<mu>.p\<^sub>0" chine]
	+ by (simp add: \<tau>\<mu>.composable hseqI')
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
	+ ((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot>
	+ ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
	+ (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
	+ proof -
	+ have "(((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)) \<cdot>
	+ ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) =
	+ ((t \<star> ((u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0)) \<star> chine) \<cdot> ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine)"
	+ using whisker_right whisker_left [of t "\<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]" "\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]"]
	+ \<tau>\<mu>.composable hseqI' comp_assoc_assoc'
	+ by simp
	+ also have "... = (t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine"
	+ using comp_cod_arr \<tau>\<mu>.composable hseqI' by simp
	+ finally have "(((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)) \<cdot>
	+ ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) =
	+ (t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
	+ ((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (((\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine)) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)) \<cdot>
	+ ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
	+ (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot> the_\<nu>"
	+ proof -
	+ have "((\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> (\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine)) \<cdot>
	+ ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) =
	+ ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine)"
	+ using comp_inv_arr' comp_cod_arr \<tau>\<mu>.composable hseqI' comp_assoc_assoc'
	+ whisker_right [of chine "\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0]" "\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0]"]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
	+ ((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot>
	+ ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
	+ (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine)) \<cdot> the_\<nu>"
	+ using comp_assoc by simp
	+ also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
	+ ((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine)) \<cdot>
	+ (\<tau>\<mu>.tab \<star> chine) \<cdot> the_\<nu>"
	+ proof -
	+ have "(\<a>\<^sup>-\<^sup>1[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> ((t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot>
	+ ((t \<star> \<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t \<star> t\<^sub>0u\<^sub>1.\<phi>) \<star> chine) \<cdot>
	+ (\<a>[t, t\<^sub>0, \<tau>\<mu>.p\<^sub>1] \<star> chine) \<cdot> ((\<tau> \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) =
	+ \<tau>\<mu>.tab \<star> chine"
	+ using uw\<theta> whisker_right [of chine] hseqI'
	+ by (metis \<tau>\<mu>.tab_def \<tau>\<mu>.tab_in_vhom' arrI seqE)
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((t \<star> u) \<star> the_\<theta>) \<cdot> \<a>[t \<star> u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<tau>\<mu>.tab \<star> chine) \<cdot> the_\<nu>"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[t, u, (u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine] \<cdot> (t \<star> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]) \<cdot>
	+ (t \<star> \<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot> \<a>[t, (u \<star> u\<^sub>0) \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot>
	+ ((t \<star> \<a>\<^sup>-\<^sup>1[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0]) \<star> chine) \<cdot> (\<a>[t, u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0] \<star> chine) =
	+ \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle>, \<^bold>\<langle>u\<^bold>\<rangle>, (\<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle>, (\<^bold>\<langle>u\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ ((\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ (\<^bold>\<a>\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle>, \<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>chine\<^bold>\<rangle>)\<rbrace>"
	+ using \<a>'_def \<alpha>_def \<tau>\<mu>.composable by simp
	+ also have "... = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>t\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>, \<^bold>\<langle>u\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<mu>.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using \<tau>\<mu>.composable
	+ apply (intro E.eval_eqI) by simp_all
	+ also have "... = \<a>[t \<star> u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine]"
	+ using \<a>'_def \<alpha>_def \<tau>\<mu>.composable by simp
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = \<Delta>"
	+ using \<Delta>_naturality by simp
	+ finally show ?thesis by simp
	+ qed
	+ finally have "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
	+ \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ by blast
	+ (*
	+ * TODO: This is common enough that there should be "cancel_iso_left" and
	+ * "cancel_iso_right" rules for doing it.
	+ *)
	+ hence "(LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1) =
	+ (RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (\<omega>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using u\<^sub>\<tau> r\<^sub>0s\<^sub>1.ide_u LHS RHS iso_is_section [of "\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0]"] section_is_mono
	+ monoE hseqI' \<tau>\<mu>.composable comp_assoc
	+ by (metis (no_types, lifting) \<Delta>_simps(1) \<mu>.ide_base
	+ \<open>\<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0] \<cdot> LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, r\<^sub>0s\<^sub>1.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> r\<^sub>0s\<^sub>1.p\<^sub>1) =
	+ ((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0) \<cdot> \<rho>\<sigma>.tab\<close>
	+ \<tau>.ide_base hseq_char ideD(1) ide_u iso_assoc')
	+ hence 1: "LHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] = RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
	+ using epiE LHS RHS iso_is_retraction retraction_is_epi hseqI' \<tau>\<mu>.composable
	+ \<omega>.the_\<nu>_props iso_hcomp
	+ by (metis \<Delta>_simps(1) \<omega>.the_\<nu>_simps(2)
	+ \<open>((\<omega> \<star> \<chi>) \<star> s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0) \<cdot> \<rho>\<sigma>.tab =
	+ \<a>\<^sup>-\<^sup>1[t, u, s\<^sub>0 \<star> r\<^sub>0s\<^sub>1.p\<^sub>0] \<cdot> RHS \<cdot> \<a>[t\<^sub>1, \<omega>.chine, r\<^sub>0s\<^sub>1.p\<^sub>1] \<cdot> (\<omega>.the_\<nu> \<star> r\<^sub>0s\<^sub>1.p\<^sub>1)\<close>
	+ \<rho>.leg1_simps(3) ide_is_iso local.comp_assoc r\<^sub>0s\<^sub>1.ide_leg1 r\<^sub>0s\<^sub>1.p\<^sub>1_simps seqE)
	+ show "LHS = RHS"
	+ proof -
	+ have "epi \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
	+ using iso_is_retraction retraction_is_epi \<rho>.T0.antipar(1) by simp
	+ moreover have "seq LHS \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
	+ using LHS \<rho>.T0.antipar(1) by auto
	+ moreover have "seq RHS \<a>[t\<^sub>1, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]"
	+ using RHS \<rho>.T0.antipar(1) by auto
	+ ultimately show ?thesis
	+ using epiE 1 by blast
	+ qed
	+ qed
	+ have 1: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)"
	+ using LHS_def RHS_def u\<^sub>\<tau> w\<^sub>\<tau> w\<^sub>\<tau>' \<beta>\<^sub>\<tau> \<theta>\<^sub>\<tau> \<theta>\<^sub>\<tau>' eq \<tau>.T2 [of ?w\<^sub>\<tau> ?w\<^sub>\<tau>' ?\<theta>\<^sub>\<tau> ?u\<^sub>\<tau> ?\<theta>\<^sub>\<tau>' ?\<beta>\<^sub>\<tau>]
	+ by fastforce
	+ obtain \<gamma>\<^sub>\<tau> where \<gamma>\<^sub>\<tau>: "\<guillemotleft>\<gamma>\<^sub>\<tau> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma>\<^sub>\<tau> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>)"
	+ using 1 by auto
	+ text \<open>
	+ At this point we could show that @{term \<gamma>\<^sub>\<tau>} is invertible using \<open>BS3\<close>,
	+ but we want to avoid using \<open>BS3\<close> if possible and we also want to
	+ establish a characterization of @{term "inv \<gamma>\<^sub>\<tau>"}. So we show the invertibility of
	+ @{term \<gamma>\<^sub>\<tau>} directly, using a few more applications of \<open>T2\<close>.
	+ \<close>
	+ have iso_\<beta>\<^sub>\<tau>: "iso ?\<beta>\<^sub>\<tau>"
	+ using uw\<theta> \<beta>\<^sub>\<tau> the_\<nu>_props \<omega>.the_\<nu>_props iso_inv_iso hseqI'
	+ iso_assoc' \<omega>.hseq_leg\<^sub>0 iso_inv_iso iso_hcomp
	+ apply (intro isos_compose)
	+ apply (metis \<omega>.is_ide \<rho>\<sigma>.leg1_simps(2) \<tau>.ide_leg1 \<tau>.leg1_simps(2)
	+ \<tau>.leg1_simps(3) hseqE r\<^sub>0s\<^sub>1.ide_leg1 hcomp_simps(1) vconn_implies_hpar(3))
	+ apply (metis \<rho>\<sigma>.leg1_simps(2) hseqE ide_is_iso r\<^sub>0s\<^sub>1.ide_leg1 src_inv
	+ vconn_implies_hpar(1))
	+ apply blast
	+ apply blast
	+ apply blast
	+ apply (metis \<tau>.ide_leg1 \<tau>.leg1_simps(3) hseqE ide_char iso_assoc t\<^sub>0u\<^sub>1.ide_leg1
	+ t\<^sub>0u\<^sub>1.p\<^sub>1_simps w\<^sub>\<tau>')
	+ by blast
	+ hence eq': "((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) =
	+ ((t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>)) \<cdot> inv ?\<beta>\<^sub>\<tau>"
	+ proof -
	+ have "seq ((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) ?\<beta>\<^sub>\<tau>"
	+ using LHS RHS_def eq by blast
	+ hence "(t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') =
	+ (((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) \<cdot> ?\<beta>\<^sub>\<tau>) \<cdot> inv ?\<beta>\<^sub>\<tau>"
	+ by (meson invert_side_of_triangle(2) iso_\<beta>\<^sub>\<tau>)
	+ thus ?thesis
	+ using LHS_def RHS_def eq by presburger
	+ qed
	+ have 2: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> inv ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>)"
	+ using u\<^sub>\<tau> w\<^sub>\<tau> w\<^sub>\<tau>' \<beta>\<^sub>\<tau> \<theta>\<^sub>\<tau> \<theta>\<^sub>\<tau>' eq' \<tau>.T2 [of ?w\<^sub>\<tau>' ?w\<^sub>\<tau> ?\<theta>\<^sub>\<tau>'?u\<^sub>\<tau> ?\<theta>\<^sub>\<tau> "inv ?\<beta>\<^sub>\<tau>"] iso_\<beta>\<^sub>\<tau> comp_assoc
	+ by blast
	+ obtain \<gamma>\<^sub>\<tau>' where
	+ \<gamma>\<^sub>\<tau>': "\<guillemotleft>\<gamma>\<^sub>\<tau>' : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> inv ?\<beta>\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>' \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')"
	+ using 2 by auto
	+ have "inverse_arrows \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>'"
	+ proof
	+ have "\<guillemotleft>\<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright>"
	+ using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' by auto
	+ moreover have "t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau> = t\<^sub>1 \<star> ?w\<^sub>\<tau>"
	+ using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' whisker_left \<beta>\<^sub>\<tau> iso_\<beta>\<^sub>\<tau> comp_inv_arr'
	+ by (metis (no_types, lifting) \<tau>.ide_leg1 calculation in_homE)
	+ moreover have "?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau>)"
	+ proof -
	+ have "?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>)"
	+ using \<gamma>\<^sub>\<tau> by simp
	+ also have "... = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>') \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>)"
	+ using \<gamma>\<^sub>\<tau>' comp_assoc by simp
	+ also have "... = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau>)"
	+ using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' whisker_left
	+ by (metis (full_types) \<tau>.ide_leg0 seqI')
	+ finally show ?thesis by simp
	+ qed
	+ moreover have
	+ "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>) \<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>"
	+ proof -
	+ have "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> t\<^sub>1 \<star> ?w\<^sub>\<tau> = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>)"
	+ proof -
	+ have "(t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>) =
	+ ((t \<star> ?\<theta>\<^sub>\<tau>) \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>)) \<cdot> (t\<^sub>1 \<star> ?w\<^sub>\<tau>)"
	+ by (metis LHS LHS_def comp_arr_dom in_homE)
	+ thus ?thesis
	+ using w\<^sub>\<tau> \<theta>\<^sub>\<tau> \<omega>.w_simps(4) \<tau>.leg1_in_hom(2) \<tau>.leg1_simps(3) hcomp_in_vhom ideD(1)
	+ trg_hcomp' ide_in_hom(2) \<tau>.T2
	+ by presburger
	+ qed
	+ thus "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau> \<Rightarrow> ?w\<^sub>\<tau>\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau> \<and> ?\<theta>\<^sub>\<tau> = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>) \<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>"
	+ by (metis \<theta>\<^sub>\<tau> comp_arr_dom ide_in_hom(2) in_homE w\<^sub>\<tau>)
	+ qed
	+ ultimately have "\<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau> = ?w\<^sub>\<tau>"
	+ by simp
	+ thus "ide (\<gamma>\<^sub>\<tau>' \<cdot> \<gamma>\<^sub>\<tau>)"
	+ using w\<^sub>\<tau> by simp
	+ have "\<guillemotleft>\<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright>"
	+ using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' by auto
	+ moreover have "t\<^sub>1 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' = t\<^sub>1 \<star> ?w\<^sub>\<tau>'"
	+ by (metis \<beta>\<^sub>\<tau> \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' \<tau>.ide_leg1 calculation comp_arr_inv' in_homE iso_\<beta>\<^sub>\<tau> whisker_left)
	+ moreover have "?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>')"
	+ proof -
	+ have "?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')"
	+ using \<gamma>\<^sub>\<tau>' by simp
	+ also have "... = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>) \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')"
	+ using \<gamma>\<^sub>\<tau> comp_assoc by simp
	+ also have "... = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>')"
	+ using \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' whisker_left
	+ by (metis (full_types) \<tau>.ide_leg0 seqI')
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)
	+ \<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>'"
	+ proof -
	+ have "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> t\<^sub>1 \<star> ?w\<^sub>\<tau>' = t\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)"
	+ proof -
	+ have "(t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>') =
	+ ((t \<star> ?\<theta>\<^sub>\<tau>') \<cdot> \<a>[t, t\<^sub>0, ?w\<^sub>\<tau>'] \<cdot> (\<tau> \<star> ?w\<^sub>\<tau>')) \<cdot> (t\<^sub>1 \<star> ?w\<^sub>\<tau>')"
	+ proof -
	+ have 1: "t\<^sub>1 \<star> \<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' = (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>) \<cdot> (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>')"
	+ by (meson \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' \<tau>.ide_leg1 seqI' whisker_left)
	+ have "((LHS \<cdot> inv ?\<beta>\<^sub>\<tau>) \<cdot> (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>)) \<cdot> (t\<^sub>1 \<star> \<gamma>\<^sub>\<tau>') = LHS \<cdot> inv ?\<beta>\<^sub>\<tau>"
	+ using LHS_def RHS_def \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>' eq eq' by presburger
	+ thus ?thesis
	+ unfolding LHS_def
	+ using 1 by (simp add: calculation(2) eq' comp_assoc)
	+ qed
	+ thus ?thesis
	+ using w\<^sub>\<tau>' \<theta>\<^sub>\<tau>' \<omega>.w_simps(4) \<tau>.leg1_in_hom(2) \<tau>.leg1_simps(3) hcomp_in_vhom ideD(1)
	+ trg_hcomp' ide_in_hom(2) \<tau>.T2 \<tau>.T0.antipar(1) t\<^sub>0u\<^sub>1.base_simps(2)
	+ t\<^sub>0u\<^sub>1.leg1_simps(4)
	+ by presburger
	+ qed
	+ thus "\<And>\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<tau>' \<Rightarrow> ?w\<^sub>\<tau>'\<guillemotright> \<and> t\<^sub>1 \<star> \<gamma> = t\<^sub>1 \<star> ?w\<^sub>\<tau>' \<and> ?\<theta>\<^sub>\<tau>' = ?\<theta>\<^sub>\<tau>' \<cdot> (t\<^sub>0 \<star> \<gamma>)
	+ \<Longrightarrow> \<gamma> = ?w\<^sub>\<tau>'"
	+ by (metis \<theta>\<^sub>\<tau>' comp_arr_dom ide_in_hom(2) in_homE w\<^sub>\<tau>')
	+ qed
	+ ultimately have "\<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>' = ?w\<^sub>\<tau>'"
	+ by simp
	+ thus "ide (\<gamma>\<^sub>\<tau> \<cdot> \<gamma>\<^sub>\<tau>')"
	+ using w\<^sub>\<tau>' by simp
	+ qed
	+ thus "\<tau>\<mu>.p\<^sub>1 \<star> chine \<cong> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
	+ using w\<^sub>\<tau> w\<^sub>\<tau>' \<gamma>\<^sub>\<tau> isomorphic_symmetric isomorphic_def by blast
	+ have iso_\<gamma>\<^sub>\<tau>: "iso \<gamma>\<^sub>\<tau>"
	+ using \<open>inverse_arrows \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>'\<close> by auto
	+ have \<gamma>\<^sub>\<tau>'_eq: "\<gamma>\<^sub>\<tau>' = inv \<gamma>\<^sub>\<tau>"
	+ using \<open>inverse_arrows \<gamma>\<^sub>\<tau> \<gamma>\<^sub>\<tau>'\<close> inverse_unique by blast
	+
	+ let ?w\<^sub>\<mu> = "\<tau>\<mu>.p\<^sub>0 \<star> chine"
	+ let ?w\<^sub>\<mu>' = "\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
	+ let ?u\<^sub>\<mu> = "s\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>0"
	+ let ?\<theta>\<^sub>\<mu> = "the_\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]"
	+ let ?\<theta>\<^sub>\<mu>' = "(\<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
	+ let ?\<beta>\<^sub>\<mu> = "\<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot> (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot>
	+ (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ have w\<^sub>\<mu>: "ide ?w\<^sub>\<mu> \<and> is_left_adjoint ?w\<^sub>\<mu>"
	+ using is_map left_adjoints_compose by simp
	+ have w\<^sub>\<mu>': "ide ?w\<^sub>\<mu>' \<and> is_left_adjoint ?w\<^sub>\<mu>'"
	+ using \<chi>.is_map left_adjoints_compose
	+ by (simp add: is_map left_adjoints_compose)
	+ have 1: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<mu> \<Rightarrow> ?w\<^sub>\<mu>'\<guillemotright> \<and> ?\<beta>\<^sub>\<mu> = u\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<mu> = ?\<theta>\<^sub>\<mu>' \<cdot> (u\<^sub>0 \<star> \<gamma>)"
	+ proof -
	+ have \<theta>\<^sub>\<mu>: "\<guillemotleft>?\<theta>\<^sub>\<mu> : u\<^sub>0 \<star> ?w\<^sub>\<mu> \<Rightarrow> ?u\<^sub>\<mu>\<guillemotright>"
	+ by auto
	+ have \<theta>\<^sub>\<mu>': "\<guillemotleft>?\<theta>\<^sub>\<mu>' : u\<^sub>0 \<star> ?w\<^sub>\<mu>' \<Rightarrow> ?u\<^sub>\<mu>\<guillemotright>"
	+ by fastforce
	+ have \<beta>\<^sub>\<mu>: "\<guillemotleft>?\<beta>\<^sub>\<mu> : u\<^sub>1 \<star> ?w\<^sub>\<mu> \<Rightarrow> u\<^sub>1 \<star> ?w\<^sub>\<mu>'\<guillemotright>"
	+ proof (intro comp_in_homI)
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine] : u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0 \<star> chine \<Rightarrow> (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine\<guillemotright>"
	+ by auto
	+ show "\<guillemotleft>inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine : (u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine \<Rightarrow> (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine\<guillemotright>"
	+ using t\<^sub>0u\<^sub>1.\<phi>_in_hom(2) t\<^sub>0u\<^sub>1.\<phi>_uniqueness(2) by auto
	+ show "\<guillemotleft>\<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] : (t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine \<Rightarrow> t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine\<guillemotright>"
	+ using \<tau>.T0.antipar(1) by auto
	+ show "\<guillemotleft>t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau> : t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1 \<star> chine \<Rightarrow> t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
	+ using \<gamma>\<^sub>\<tau> iso_\<gamma>\<^sub>\<tau> using \<tau>.T0.antipar(1) by auto
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] : t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> (t\<^sub>0 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
	+ using \<rho>.T0.antipar(1) by auto
	+ show "\<guillemotleft>\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1 : (t\<^sub>0 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1\<guillemotright>"
	+ using \<rho>.T0.antipar(1) by auto
	+ show "\<guillemotleft>r\<^sub>0s\<^sub>1.\<phi> : r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1 \<Rightarrow> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
	+ by auto
	+ show "\<guillemotleft>\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0 : s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0 \<Rightarrow> (u\<^sub>1 \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
	+ by auto
	+ show "\<guillemotleft>\<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] : (u\<^sub>1 \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0 \<Rightarrow> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<guillemotright>"
	+ by auto
	+ qed
	+ text \<open>
	+ The proof of the equation below needs to make use of the equation
	+ \<open>\<theta>\<^sub>\<tau>' = \<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')\<close> from the previous section. So the overall strategy is to
	+ work toward an expression of the form \<open>\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> \<gamma>\<^sub>\<tau>')\<close> and perform the replacement
	+ to eliminate \<open>\<gamma>\<^sub>\<tau>'\<close>.
	+ \<close>
	+ have eq\<^sub>\<mu>: "(u \<star> ?\<theta>\<^sub>\<mu>) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>) =
	+ ((u \<star> ?\<theta>\<^sub>\<mu>') \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>'] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>')) \<cdot> ?\<beta>\<^sub>\<mu>"
	+ proof -
	+ let ?LHS = "(u \<star> ?\<theta>\<^sub>\<mu>) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
	+ let ?RHS = "((u \<star> ?\<theta>\<^sub>\<mu>') \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>'] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>')) \<cdot> ?\<beta>\<^sub>\<mu>"
	+ have "?RHS = (u \<star> (\<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
	+ \<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
	+ (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
	+ \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ using comp_assoc by simp
	+ also have "... = (u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
	+ \<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0]) \<cdot> (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
	+ (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
	+ \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ proof -
	+ have "u \<star> (\<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] =
	+ (u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0])"
	+ using whisker_left \<mu>.ide_base \<theta>\<^sub>\<mu>' by blast
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
	+ (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot>
	+ (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
	+ (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
	+ \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ proof -
	+ have "seq (u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0])
	+ (\<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0))"
	+ using hseqI'
	+ by (intro seqI hseqI, auto)
	+ moreover have "src u = trg \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
	+ by simp
	+ moreover have "inv (u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) = u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
	+ using hseqI' by simp
	+ moreover have "iso (u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0])"
	+ by simp
	+ moreover have "iso \<a>[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
	+ by simp
	+ ultimately have "(u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot> \<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0] =
	+ \<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
	+ using pentagon hseqI' comp_assoc
	+ invert_opposite_sides_of_square
	+ [of "u \<star> \<a>[u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
	+ "\<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0)"
	+ "\<a>[u, u\<^sub>0, \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0]" "\<a>[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"]
	+ inv_hcomp \<chi>.is_ide \<chi>.w_simps(3) \<chi>.w_simps(4) \<mu>.base_simps(2) \<mu>.ide_base
	+ \<mu>.ide_leg0 \<mu>.leg0_simps(2) \<mu>.leg0_simps(3) \<sigma>.leg1_simps(3)
	+ assoc'_eq_inv_assoc ide_hcomp r\<^sub>0s\<^sub>1.ide_u r\<^sub>0s\<^sub>1.p\<^sub>0_simps hcomp_simps(1)
	+ by presburger
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot>
	+ (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot>
	+ \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
	+ (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
	+ \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ proof -
	+ have "(u \<star> \<chi>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>[u, u\<^sub>0 \<star> \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] =
	+ \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0)"
	+ using assoc_naturality [of u \<chi>.the_\<theta> \<rho>\<sigma>.p\<^sub>0] \<chi>.\<theta>_simps(3) by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot>
	+ (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
	+ (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
	+ \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> (\<mu> \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0) =
	+ ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]"
	+ using assoc'_naturality [of \<mu> \<chi>.chine \<rho>\<sigma>.p\<^sub>0] by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot>
	+ (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
	+ (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
	+ \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ using comp_assoc by metis
	+ also have "... = \<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> (((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0)) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
	+ (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1] \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
	+ \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ proof -
	+ have "(\<a>\<^sup>-\<^sup>1[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0] \<cdot> \<a>[u\<^sub>1, \<chi>.chine, \<rho>\<sigma>.p\<^sub>0]) \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) =
	+ \<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0"
	+ using comp_inv_arr' comp_cod_arr hseqI' by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (\<a>[u, s\<^sub>0, \<rho>\<sigma>.p\<^sub>0] \<cdot> ((\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> r\<^sub>0s\<^sub>1.\<phi> \<cdot>
	+ (\<omega>.the_\<theta> \<star> \<rho>\<sigma>.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[t\<^sub>0, \<omega>.chine, \<rho>\<sigma>.p\<^sub>1]) \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>) \<cdot>
	+ \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ proof -
	+ have "arr ((u \<star> \<chi>.the_\<theta>) \<cdot> \<a>[u, u\<^sub>0, \<chi>.chine] \<cdot> (\<mu> \<star> \<chi>.chine) \<cdot> \<chi>.the_\<nu>)"
	+ using hseqI' \<chi>.\<theta>_simps(3)
	+ by (intro seqI hseqI, auto)
	+ hence "((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) =
	+ (u \<star> \<chi>.the_\<theta>) \<cdot> \<a>[u, u\<^sub>0, \<chi>.chine] \<cdot> (\<mu> \<star> \<chi>.chine) \<cdot> \<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0"
	+ using whisker_right hseqI' by simp
	+ also have "... = (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0"
	+ using \<chi>.\<Delta>_naturality by simp
	+ finally have "((u \<star> \<chi>.the_\<theta>) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<a>[u, u\<^sub>0, \<chi>.chine] \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot>
	+ ((\<mu> \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0) \<cdot> (\<chi>.the_\<nu> \<star> \<rho>\<sigma>.p\<^sub>0) =
	+ (\<chi> \<star> s\<^sub>0) \<cdot> \<sigma> \<star> \<rho>\<sigma>.p\<^sub>0"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (?\<theta>\<^sub>\<tau> \<cdot> (t\<^sub>0 \<star> inv \<gamma>\<^sub>\<tau>)) \<cdot>
	+ \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ using comp_assoc by simp
	+ also have "... = ?\<theta>\<^sub>\<tau>' \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine] \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ using \<gamma>\<^sub>\<tau>' \<gamma>\<^sub>\<tau>'_eq by simp
	+ also have "... = (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
	+ (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ using comp_assoc by presburger
	+ also have "... = (u \<star> the_\<theta>) \<cdot> \<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ ((\<mu> \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ proof -
	+ have "((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> ((\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
	+ (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine] =
	+ \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ proof -
	+ have "((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> ((\<a>\<^sup>-\<^sup>1[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot> \<a>[t\<^sub>0, \<tau>\<mu>.p\<^sub>1, chine]) \<cdot>
	+ (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine] =
	+ ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> ((t\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>1) \<star> chine) \<cdot>
	+ (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ using comp_inv_arr' hseqI' \<tau>.T0.antipar(1) by auto
	+ also have "... = ((t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> (inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine)) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ using comp_cod_arr hseqI' t\<^sub>0u\<^sub>1.\<phi>_uniqueness by simp
	+ also have "... = (t\<^sub>0u\<^sub>1.\<phi> \<cdot> inv t\<^sub>0u\<^sub>1.\<phi> \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ using whisker_right t\<^sub>0u\<^sub>1.\<phi>_uniqueness by simp
	+ also have "... = ((u\<^sub>1 \<star> \<tau>\<mu>.p\<^sub>0) \<star> chine) \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ using comp_arr_inv' \<tau>.T0.antipar(1) hseqI' t\<^sub>0u\<^sub>1.\<phi>_uniqueness by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[u\<^sub>1, \<tau>\<mu>.p\<^sub>0, chine]"
	+ using comp_cod_arr \<tau>.T0.antipar(1) hseqI' by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (u \<star> the_\<theta>) \<cdot> (\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u \<star> u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
	+ using assoc'_naturality [of \<mu> \<tau>\<mu>.p\<^sub>0 chine] comp_assoc by auto
	+ also have "... = ((u \<star> the_\<theta>) \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine])) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
	+ using uw\<theta> pentagon comp_assoc inv_hcomp
	+ invert_opposite_sides_of_square
	+ [of "u \<star> \<a>[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]"
	+ "\<a>[u, u\<^sub>0 \<star> \<tau>\<mu>.p\<^sub>0, chine] \<cdot> (\<a>[u, u\<^sub>0, \<tau>\<mu>.p\<^sub>0] \<star> chine)" "\<a>[u, u\<^sub>0, ?w\<^sub>\<mu>]"
	+ "\<a>[u \<star> u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]"]
	+ \<mu>.base_simps(2) \<mu>.ide_base \<mu>.ide_leg0 \<mu>.leg0_simps(2) assoc'_eq_inv_assoc
	+ ide_hcomp hseqI' hcomp_simps(1) t\<^sub>0u\<^sub>1.ide_u
	+ by force
	+ also have "... = (u \<star> the_\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[u\<^sub>0, \<tau>\<mu>.p\<^sub>0, chine]) \<cdot> \<a>[u, u\<^sub>0, ?w\<^sub>\<mu>] \<cdot> (\<mu> \<star> ?w\<^sub>\<mu>)"
	+ using whisker_left comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w\<^sub>\<mu> \<Rightarrow> ?w\<^sub>\<mu>'\<guillemotright> \<and> ?\<beta>\<^sub>\<mu> = u\<^sub>1 \<star> \<gamma> \<and> ?\<theta>\<^sub>\<mu> = ?\<theta>\<^sub>\<mu>' \<cdot> (u\<^sub>0 \<star> \<gamma>)"
	+ using w\<^sub>\<mu> w\<^sub>\<mu>' \<theta>\<^sub>\<mu> \<theta>\<^sub>\<mu>' \<beta>\<^sub>\<mu> eq\<^sub>\<mu> \<mu>.T2 [of ?w\<^sub>\<mu> ?w\<^sub>\<mu>' ?\<theta>\<^sub>\<mu> ?u\<^sub>\<mu> ?\<theta>\<^sub>\<mu>' ?\<beta>\<^sub>\<mu>] by fast
	+ qed
	+ obtain \<gamma>\<^sub>\<mu> where \<gamma>\<^sub>\<mu>: "\<guillemotleft>\<gamma>\<^sub>\<mu> : ?w\<^sub>\<mu> \<Rightarrow> ?w\<^sub>\<mu>'\<guillemotright> \<and> ?\<beta>\<^sub>\<mu> = u\<^sub>1 \<star> \<gamma>\<^sub>\<mu> \<and> ?\<theta>\<^sub>\<mu> = ?\<theta>\<^sub>\<mu>' \<cdot> (u\<^sub>0 \<star> \<gamma>\<^sub>\<mu>)"
	+ using 1 by auto
	+ show "?w\<^sub>\<mu> \<cong> ?w\<^sub>\<mu>'"
	+ using w\<^sub>\<mu> w\<^sub>\<mu>' \<gamma>\<^sub>\<mu> BS3 [of ?w\<^sub>\<mu> ?w\<^sub>\<mu>' \<gamma>\<^sub>\<mu> \<gamma>\<^sub>\<mu>] isomorphic_def by auto
	+ qed
	+
	+ lemma comp_L:
	+ shows "Maps.seq \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ and "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> =
	+ MkArr (src (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)) (src t) (Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>)"
	+ proof -
	+ show "Maps.seq \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "is_left_adjoint (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)"
	+ using \<omega>.is_map r\<^sub>0s\<^sub>1.leg1_is_map left_adjoints_compose r\<^sub>0s\<^sub>1.p\<^sub>1_simps by auto
	+ thus ?thesis
	+ using Maps.CLS_in_hom r\<^sub>0s\<^sub>1.leg1_is_map
	+ apply (intro Maps.seqI')
	+ apply blast
	+ using Maps.CLS_in_hom [of t\<^sub>0] \<tau>.leg0_is_map \<rho>\<sigma>.leg1_in_hom by auto
	+ qed
	+ thus "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> =
	+ MkArr (src (\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1)) (src t) (Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>)"
	+ using Maps.comp_char by auto
	+ qed
	+
	+ lemma comp_R:
	+ shows "Maps.seq \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ and "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> =
	+ MkArr (src r\<^sub>0s\<^sub>1.p\<^sub>0) (trg u) (Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>0\<rbrakk>)"
	+ proof -
	+ show "Maps.seq \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "is_left_adjoint (\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0)"
	+ using \<chi>.is_map r\<^sub>0s\<^sub>1.leg0_is_map left_adjoints_compose [of \<chi>.chine \<rho>\<sigma>.p\<^sub>0] by simp
	+ thus ?thesis
	+ using Maps.CLS_in_hom \<mu>.leg1_is_map
	+ apply (intro Maps.seqI')
	+ apply blast
	+ using Maps.CLS_in_hom [of u\<^sub>1] \<mu>.leg1_is_map by simp
	+ qed
	+ thus "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> =
	+ MkArr (src r\<^sub>0s\<^sub>1.p\<^sub>0) (trg u) (Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> r\<^sub>0s\<^sub>1.p\<^sub>0\<rbrakk>)"
	+ using Maps.comp_char by auto
	+ qed
	+
	+ lemma comp_L_eq_comp_R:
	+ shows "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ proof (intro Maps.arr_eqI)
	+ show "Maps.seq \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ using comp_L(1) by simp
	+ show "Maps.seq \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using comp_R(1) by simp
	+ show "Maps.Dom (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Dom (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>)"
	+ by (metis (no_types, lifting) Maps.Dom.simps(1) \<omega>.w_simps(2) \<omega>.w_simps(3)
	+ \<rho>.leg1_simps(3) \<rho>\<sigma>.leg1_in_hom(2) comp_L(2) comp_R(2) hcomp_in_vhomE hseqI'
	+ r\<^sub>0s\<^sub>1.leg1_simps(3) hcomp_simps(1))
	+ show "Maps.Cod (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Cod (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>)"
	+ by (metis Maps.Cod.simps(1) \<tau>\<mu>.composable comp_L(2) comp_R(2))
	+ have A: "Maps.Map (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
	+ using comp_L(1) Maps.comp_char by auto
	+ have B: "Maps.Map (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>) = Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
	+ using comp_R(1) Maps.comp_char by auto
	+ have C: "Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk> = Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
	+ proof (intro Maps.Comp_eqI)
	+ show "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<in> Maps.Comp \<lbrakk>t\<^sub>0\<rbrakk> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
	+ proof (intro Maps.in_CompI)
	+ show "is_iso_class \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
	+ using prj_chine(2) is_iso_classI isomorphic_implies_hpar(2) by blast
	+ show "is_iso_class \<lbrakk>t\<^sub>0\<rbrakk>"
	+ using is_iso_classI by auto
	+ show "\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<in> \<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>"
	+ using ide_in_iso_class prj_chine(2) isomorphic_implies_hpar(2) by blast
	+ show "t\<^sub>0 \<in> \<lbrakk>t\<^sub>0\<rbrakk>"
	+ using ide_in_iso_class by simp
	+ show "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<cong> t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1"
	+ using isomorphic_reflexive prj_chine(2) isomorphic_implies_hpar(2) by auto
	+ qed
	+ show "u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0 \<in> Maps.Comp \<lbrakk>u\<^sub>1\<rbrakk> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
	+ proof (intro Maps.in_CompI)
	+ show "is_iso_class \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
	+ using is_iso_classI by simp
	+ show "is_iso_class \<lbrakk>u\<^sub>1\<rbrakk>"
	+ using is_iso_classI by simp
	+ show "\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0 \<in> \<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>"
	+ using ide_in_iso_class by simp
	+ show "u\<^sub>1 \<in> iso_class u\<^sub>1"
	+ using ide_in_iso_class by simp
	+ show "u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0 \<cong> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
	+ using isomorphic_reflexive isomorphic_implies_hpar(2) by auto
	+ qed
	+ show "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<cong> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
	+ proof -
	+ have "t\<^sub>0 \<star> \<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1 \<cong> (t\<^sub>0 \<star> \<omega>.chine) \<star> \<rho>\<sigma>.p\<^sub>1"
	+ using assoc'_in_hom [of t\<^sub>0 \<omega>.chine \<rho>\<sigma>.p\<^sub>1] iso_assoc' isomorphic_def r\<^sub>0s\<^sub>1.p\<^sub>1_simps
	+ by auto
	+ also have "... \<cong> r\<^sub>0 \<star> \<rho>\<sigma>.p\<^sub>1"
	+ using \<omega>.leg0_uniquely_isomorphic hcomp_isomorphic_ide
	+ by (simp add: \<rho>.T0.antipar(1))
	+ also have "... \<cong> s\<^sub>1 \<star> \<rho>\<sigma>.p\<^sub>0"
	+ using isomorphic_def r\<^sub>0s\<^sub>1.\<phi>_uniqueness(2) by blast
	+ also have "... \<cong> (u\<^sub>1 \<star> \<chi>.chine) \<star> \<rho>\<sigma>.p\<^sub>0"
	+ using \<chi>.leg1_uniquely_isomorphic hcomp_isomorphic_ide by auto
	+ also have "... \<cong> u\<^sub>1 \<star> \<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0"
	+ using assoc_in_hom [of u\<^sub>1 \<chi>.chine \<rho>\<sigma>.p\<^sub>0] iso_assoc isomorphic_def by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ show "Maps.Map (\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>) = Maps.Map (\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>)"
	+ using A B C by simp
	+ qed
	+
	+ lemma csq:
	+ shows "Maps.commutative_square \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ proof
	+ show "Maps.cospan \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk>"
	+ using comp_L(1) comp_R(1) comp_L_eq_comp_R
	+ by (metis (no_types, lifting) Maps.cod_comp Maps.seq_char)
	+ show "Maps.span \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using comp_L(1) comp_R(1) comp_L_eq_comp_R
	+ by (metis (no_types, lifting) Maps.dom_comp Maps.seq_char)
	+ show "Maps.dom \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> = Maps.cod \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ using comp_L(1) by auto
	+ show "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using comp_L_eq_comp_R by simp
	+ qed
	+
	+ lemma CLS_chine:
	+ shows "\<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = Maps.tuple \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ proof -
	+ let ?T = "Maps.tuple \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ have "\<exists>!l. \<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> l = \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<and> \<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> l = \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using csq \<tau>\<mu>.prj_char
	+ Maps.universal [of "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"]
	+ by simp
	+ moreover have "\<lbrakk>\<lbrakk>\<tau>\<mu>.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> ?T = \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<and>
	+ \<lbrakk>\<lbrakk>\<tau>\<mu>.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> ?T = \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using csq \<tau>\<mu>.prj_char
	+ Maps.prj_tuple [of "\<lbrakk>\<lbrakk>t\<^sub>0\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>u\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>" "\<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"]
	+ by simp
	+ moreover have "\<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>\<omega>.chine \<star> \<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk> \<and>
	+ \<lbrakk>\<lbrakk>t\<^sub>0u\<^sub>1.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>\<chi>.chine \<star> \<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using prj_chine \<tau>\<mu>.leg0_is_map \<tau>\<mu>.leg1_is_map is_map t\<^sub>0u\<^sub>1.leg1_is_map
	+ t\<^sub>0u\<^sub>1.satisfies_T0 Maps.comp_CLS
	+ by blast
	+ ultimately show "\<lbrakk>\<lbrakk>chine\<rbrakk>\<rbrakk> = ?T" by auto
	+ qed
	+
	+ end
	+
	+ subsection "Equivalence of B and Span(Maps(B))"
	+
	+ subsubsection "The Functor SPN"
	+
	+ text \<open>
	+ We now define a function \<open>SPN\<close> on arrows and will ultimately show that it extends to a
	+ biequivalence from the underlying bicategory \<open>B\<close> to \<open>Span(Maps(B))\<close>.
	+ The idea is that \<open>SPN\<close> takes \<open>\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>\<close> to the isomorphism class of an induced arrow
	+ of spans from the chosen tabulation of \<open>r\<close> to the chosen tabulation of \<open>s\<close>.
	+ To obtain this, we first use isomorphisms \<open>r.tab\<^sub>1 \<star> r.tab\<^sub>0\<^sup>* \<cong> r\<close> and \<open>s.tab\<^sub>1 \<star> s.tab\<^sub>0\<^sup>* \<cong> s\<close>
	+ to transform \<open>\<mu>\<close> to \<open>\<guillemotleft>\<mu>' : r.tab\<^sub>1 \<star> r.tab\<^sub>0\<^sup>* \<Rightarrow> s.tab\<^sub>1 \<star> s.tab\<^sub>0\<^sup>*\<guillemotright>\<close>.
	+ We then take the adjoint transpose of \<open>\<mu>'\<close> to obtain
	+ \<open>\<guillemotleft>\<omega> : r.tab\<^sub>1 \<Rightarrow> (s.tab\<^sub>1 \<star> s.tab\<^sub>0\<^sup>*) \<star> r.tab\<^sub>0\<guillemotright>\<close>. The 2-cell \<open>\<omega>\<close> induces a map \<open>w\<close>
	+ which is an arrow of spans from \<open>(r.tab\<^sub>0, r.tab\<^sub>1)\<close> to \<open>(s.tab\<^sub>0, s.tab\<^sub>1)\<close>.
	+ We take the arrow of \<open>Span(Maps(B))\<close> defined by \<open>w\<close> as the value of \<open>SPN \<mu>\<close>.
	+
	+ Ensuring that \<open>SPN\<close> is functorial is a somewhat delicate point, which requires that all
	+ the underlying definitions that have been set up are ``just so'', with no extra choices
	+ other than those that are forced, and with the tabulation assigned to each 1-cell \<open>r\<close> in
	+ the proper relationship with the canonical tabulation assigned to its chosen factorization
	+ \<open>r = g \<star> f\<^sup>*\<close>.
	+ \<close>
	+
	+ context bicategory_of_spans
	+ begin
	+
	+ interpretation Maps: maps_category V H \<a> \<i> src trg ..
	+ interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
	+
	+ no_notation Fun.comp (infixl "\<circ>" 55)
	+ notation Span.vcomp (infixr "\<bullet>" 55)
	+ notation Span.hcomp (infixr "\<circ>" 53)
	+ notation Maps.comp (infixr "\<odot>" 55)
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ definition spn
	+ where "spn \<mu> \<equiv>
	+ arrow_of_tabulations_in_maps.chine V H \<a> \<i> src trg
	+ (tab_of_ide (dom \<mu>)) (tab\<^sub>0 (dom \<mu>)) (cod \<mu>)
	+ (tab_of_ide (cod \<mu>)) (tab\<^sub>0 (cod \<mu>)) (tab\<^sub>1 (cod \<mu>)) \<mu>"
	+
	+ lemma is_induced_map_spn:
	+ assumes "arr \<mu>"
	+ shows "arrow_of_tabulations_in_maps.is_induced_map V H \<a> \<i> src trg
	+ (tab_of_ide (dom \<mu>)) (tab\<^sub>0 (dom \<mu>)) (cod \<mu>)
	+ (tab_of_ide (cod \<mu>)) (tab\<^sub>0 (cod \<mu>)) (tab\<^sub>1 (cod \<mu>))
	+ \<mu> (spn \<mu>)"
	+ proof -
	+ interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>
	+ using assms by (unfold_locales, auto)
	+ interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
	+ \<open>cod \<mu>\<close> \<mu>.s.tab \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
	+ \<mu>
	+ using \<mu>.is_arrow_of_tabulations_in_maps by simp
	+ show ?thesis
	+ unfolding spn_def
	+ using \<mu>.chine_is_induced_map by blast
	+ qed
	+
	+ lemma spn_props:
	+ assumes "arr \<mu>"
	+ shows "\<guillemotleft>spn \<mu> : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src (tab\<^sub>0 (cod \<mu>))\<guillemotright>"
	+ and "is_left_adjoint (spn \<mu>)"
	+ and "tab\<^sub>0 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>0 (dom \<mu>)"
	+ and "tab\<^sub>1 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>1 (dom \<mu>)"
	+ proof -
	+ interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>
	+ using assms by (unfold_locales, auto)
	+ interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
	+ \<open>cod \<mu>\<close> \<mu>.s.tab \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
	+ \<mu>
	+ using \<mu>.is_arrow_of_tabulations_in_maps by simp
	+ show "\<guillemotleft>spn \<mu> : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src (tab\<^sub>0 (cod \<mu>))\<guillemotright>"
	+ using spn_def by simp
	+ show "is_left_adjoint (spn \<mu>)"
	+ using spn_def by (simp add: \<mu>.is_map)
	+ show "tab\<^sub>0 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>0 (dom \<mu>)"
	+ using spn_def isomorphic_def \<mu>.leg0_uniquely_isomorphic(1) by auto
	+ show "tab\<^sub>1 (cod \<mu>) \<star> spn \<mu> \<cong> tab\<^sub>1 (dom \<mu>)"
	+ using spn_def isomorphic_def isomorphic_symmetric
	+ \<mu>.leg1_uniquely_isomorphic(1)
	+ by auto
	+ qed
	+
	+ lemma spn_in_hom [intro]:
	+ assumes "arr \<mu>"
	+ shows "\<guillemotleft>spn \<mu> : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src (tab\<^sub>0 (cod \<mu>))\<guillemotright>"
	+ and "\<guillemotleft>spn \<mu> : spn \<mu> \<Rightarrow> spn \<mu>\<guillemotright>"
	+ using assms spn_props left_adjoint_is_ide by auto
	+
	+ lemma spn_simps [simp]:
	+ assumes "arr \<mu>"
	+ shows "is_left_adjoint (spn \<mu>)"
	+ and "ide (spn \<mu>)"
	+ and "src (spn \<mu>) = src (tab\<^sub>0 (dom \<mu>))"
	+ and "trg (spn \<mu>) = src (tab\<^sub>0 (cod \<mu>))"
	+ using assms spn_props left_adjoint_is_ide by auto
	+
	+ text \<open>
	+ We need the next result to show that \<open>SPN\<close> is functorial; in particular,
	+ that it takes \<open>\<guillemotleft>r : r \<Rightarrow> r\<guillemotright>\<close> in the underlying bicategory to a 1-cell
	+ in \<open>Span(Maps(B))\<close>. The 1-cells in \<open>Span(Maps(B))\<close> have objects of \<open>Maps(B)\<close>
	+ as their chines, and objects of \<open>Maps(B)\<close> are isomorphism classes of objects in the
	+ underlying bicategory \<open>B\<close>. So we need the induced map associated with \<open>r\<close> to be isomorphic
	+ to an object.
	+ \<close>
	+
	+ lemma spn_ide:
	+ assumes "ide r"
	+ shows "spn r \<cong> src (tab\<^sub>0 r)"
	+ proof -
	+ interpret r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r
	+ using assms by (unfold_locales, auto)
	+ interpret r: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> r
	+ using r.is_arrow_of_tabulations_in_maps by simp
	+ interpret tab: tabulation V H \<a> \<i> src trg r \<open>r.tab\<close> \<open>tab\<^sub>0 r\<close> \<open>dom r.tab\<close>
	+ using assms r.tab_is_tabulation by simp
	+ interpret tab: tabulation_in_maps V H \<a> \<i> src trg r \<open>r.tab\<close> \<open>tab\<^sub>0 r\<close> \<open>dom r.tab\<close>
	+ by (unfold_locales, simp_all)
	+ have "tab.is_induced_by_cell (spn r) (tab\<^sub>0 r) r.tab"
	+ using spn_def comp_ide_arr r.chine_is_induced_map by auto
	+ thus ?thesis
	+ using tab.induced_map_unique [of "tab\<^sub>0 r" "r.tab" "spn r" "src r.s\<^sub>0"]
	+ tab.apex_is_induced_by_cell
	+ by (simp add: comp_assoc)
	+ qed
	+
	+ text \<open>
	+ The other key result we need to show that \<open>SPN\<close> is functorial is to show
	+ that the induced map of a composite is isomorphic to the composite of
	+ induced maps.
	+ \<close>
	+
	+ lemma spn_hcomp:
	+ assumes "seq \<tau> \<mu>" and "g \<cong> spn \<tau>" and "f \<cong> spn \<mu>"
	+ shows "spn (\<tau> \<cdot> \<mu>) \<cong> g \<star> f"
	+ proof -
	+ interpret \<tau>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<tau>\<close> \<open>cod \<tau>\<close> \<tau>
	+ using assms by (unfold_locales, auto)
	+ interpret \<tau>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom \<tau>\<close> \<tau>.r.tab \<open>tab\<^sub>0 (dom \<tau>)\<close> \<open>tab\<^sub>1 (dom \<tau>)\<close>
	+ \<open>cod \<tau>\<close> \<tau>.s.tab \<open>tab\<^sub>0 (cod \<tau>)\<close> \<open>tab\<^sub>1 (cod \<tau>)\<close>
	+ \<tau>
	+ using \<tau>.is_arrow_of_tabulations_in_maps by simp
	+ interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>dom \<tau>\<close> \<mu>
	+ using assms apply unfold_locales
	+ apply auto[1]
	+ by (elim seqE, auto)
	+ interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
	+ \<open>dom \<tau>\<close> \<tau>.r.tab \<open>tab\<^sub>0 (dom \<tau>)\<close> \<open>tab\<^sub>1 (dom \<tau>)\<close>
	+ \<mu>
	+ using \<mu>.is_arrow_of_tabulations_in_maps by simp
	+ interpret \<tau>\<mu>: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom \<mu>\<close> \<mu>.r.tab \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
	+ \<open>dom \<tau>\<close> \<tau>.r.tab \<open>tab\<^sub>0 (dom \<tau>)\<close> \<open>tab\<^sub>1 (dom \<tau>)\<close>
	+ \<open>cod \<tau>\<close> \<tau>.s.tab \<open>tab\<^sub>0 (cod \<tau>)\<close> \<open>tab\<^sub>1 (cod \<tau>)\<close>
	+ \<mu> \<tau>
	+ ..
	+ have "g \<cong> \<tau>.chine"
	+ using assms(2) spn_def by auto
	+ moreover have "f \<cong> \<mu>.chine"
	+ using assms(1) assms(3) spn_def by auto
	+ moreover have "src g = trg f"
	+ using calculation(1-2) isomorphic_implies_hpar(3-4) by auto
	+ moreover have "src g = trg \<mu>.chine"
	+ using calculation(1) isomorphic_implies_hpar(3) by auto
	+ ultimately have "g \<star> f \<cong> \<tau>.chine \<star> \<mu>.chine"
	+ using hcomp_ide_isomorphic hcomp_isomorphic_ide isomorphic_transitive
	+ by (meson \<mu>.is_ide isomorphic_implies_ide(1))
	+ also have "... \<cong> spn (\<tau> \<cdot> \<mu>)"
	+ using spn_def \<tau>\<mu>.chine_char isomorphic_symmetric
	+ by (metis \<tau>\<mu>.in_hom in_homE)
	+ finally show ?thesis
	+ using isomorphic_symmetric by simp
	+ qed
	+
	+ abbreviation (input) SPN\<^sub>0
	+ where "SPN\<^sub>0 r \<equiv> Span.mkIde \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>"
	+
	+ definition SPN
	+ where "SPN \<mu> \<equiv> if arr \<mu> then
	+ \<lparr>Chn = \<lbrakk>\<lbrakk>spn \<mu>\<rbrakk>\<rbrakk>,
	+ Dom = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>\<rbrakk>\<rparr>,
	+ Cod = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (cod \<mu>)\<rbrakk>\<rbrakk>\<rparr>\<rparr>
	+ else Span.null"
	+
	+ lemma Dom_SPN [simp]:
	+ assumes "arr \<mu>"
	+ shows "Dom (SPN \<mu>) = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>\<rbrakk>\<rparr>"
	+ using assms SPN_def by simp
	+
	+ lemma Cod_SPN [simp]:
	+ assumes "arr \<mu>"
	+ shows "Cod (SPN \<mu>) = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (cod \<mu>)\<rbrakk>\<rbrakk>\<rparr>"
	+ using assms SPN_def by simp
	+
	+ text \<open>Now we have to show this does the right thing for us.\<close>
	+
	+ lemma SPN_in_hom:
	+ assumes "arr \<mu>"
	+ shows "Span.in_hom (SPN \<mu>) (SPN\<^sub>0 (dom \<mu>)) (SPN\<^sub>0 (cod \<mu>))"
	+ proof
	+ interpret Dom: span_in_category Maps.comp \<open>Dom (SPN \<mu>)\<close>
	+ proof
	+ interpret r: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close>
	+ using assms by (unfold_locales, auto)
	+ show "Maps.span (Leg0 (Dom (SPN \<mu>))) (Leg1 (Dom (SPN \<mu>)))"
	+ using assms Maps.CLS_in_hom SPN_def
	+ by (metis (no_types, lifting) Maps.in_homE bicategory_of_spans.Dom_SPN
	+ bicategory_of_spans_axioms r.leg1_is_map r.leg1_simps(3) r.satisfies_T0
	+ span_data.simps(1) span_data.simps(2))
	+ qed
	+ interpret Dom': span_in_category Maps.comp
	+ \<open>\<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>\<rbrakk>\<rparr>\<close>
	+ using assms Dom.span_in_category_axioms SPN_def by simp
	+ interpret Cod: span_in_category Maps.comp "Cod (SPN \<mu>)"
	+ proof
	+ interpret s: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>cod \<mu>\<close>
	+ using assms by (unfold_locales, auto)
	+ show "Maps.span (Leg0 (Cod (SPN \<mu>))) (Leg1 (Cod (SPN \<mu>)))"
	+ using assms Maps.CLS_in_hom SPN_def
	+ by (metis (no_types, lifting) bicategory_of_spans.Cod_SPN bicategory_of_spans_axioms
	+ ide_dom s.base_simps(2) s.base_simps(3) s.determines_span span_in_category.is_span)
	+ qed
	+ interpret Cod': span_in_category Maps.comp
	+ \<open>\<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (cod \<mu>)\<rbrakk>\<rbrakk>\<rparr>\<close>
	+ using assms Cod.span_in_category_axioms SPN_def by simp
	+ show 1: "Span.arr (SPN \<mu>)"
	+ proof (unfold Span.arr_char)
	+ show "arrow_of_spans Maps.comp (SPN \<mu>)"
	+ proof (unfold_locales)
	+ show "Maps.in_hom (Chn (SPN \<mu>)) Dom.apex Cod.apex"
	+ unfolding SPN_def Maps.in_hom_char
	+ using assms Dom'.apex_def Cod'.apex_def Dom'.is_span Cod'.is_span Maps.arr_char
	+ by auto
	+ show "Cod.leg0 \<odot> Chn (SPN \<mu>) = Dom.leg0"
	+ unfolding SPN_def
	+ using assms spn_props [of \<mu>] Maps.comp_CLS [of "tab\<^sub>0 (cod \<mu>)" "spn \<mu>"] by simp
	+ show "Cod.leg1 \<odot> Chn (SPN \<mu>) = Dom.leg1"
	+ unfolding SPN_def
	+ using assms spn_props [of \<mu>] Maps.comp_CLS [of "tab\<^sub>1 (cod \<mu>)" "spn \<mu>"] by simp
	+ qed
	+ qed
	+ show "Span.dom (SPN \<mu>) = SPN\<^sub>0 (dom \<mu>)"
	+ using assms 1 Span.dom_char Dom'.apex_def SPN_def by simp
	+ show "Span.cod (SPN \<mu>) = SPN\<^sub>0 (cod \<mu>)"
	+ using assms 1 Span.cod_char Cod'.apex_def SPN_def by simp
	+ qed
	+
	+ interpretation SPN: "functor" V Span.vcomp SPN
	+ proof
	+ show "\<And>\<mu>. \<not> arr \<mu> \<Longrightarrow> SPN \<mu> = Span.null"
	+ unfolding SPN_def by simp
	+ show 1: "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.arr (SPN \<mu>)"
	+ using SPN_in_hom by auto
	+ show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.dom (SPN \<mu>) = SPN (dom \<mu>)"
	+ proof -
	+ fix \<mu>
	+ assume \<mu>: "arr \<mu>"
	+ have 1: "Maps.arr (MkArr (src (tab\<^sub>0 (dom \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>)"
	+ proof -
	+ have "src (tab\<^sub>0 (dom \<mu>)) \<in> Collect obj"
	+ using \<mu> by simp
	+ moreover have "src \<mu> \<in> Collect obj"
	+ using \<mu> by simp
	+ moreover have "\<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (local.dom \<mu>))) (src \<mu>)"
	+ proof -
	+ have "\<guillemotleft>tab\<^sub>0 (dom \<mu>) : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src \<mu>\<guillemotright>"
	+ using \<mu> by simp
	+ moreover have "is_left_adjoint (tab\<^sub>0 (dom \<mu>))"
	+ using \<mu> tab\<^sub>0_simps [of "dom \<mu>"] by auto
	+ ultimately show ?thesis by auto
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ have "\<lbrakk>spn (dom \<mu>)\<rbrakk> = \<lbrakk>src (tab\<^sub>0 (dom \<mu>))\<rbrakk>"
	+ using \<mu> spn_ide iso_class_eqI by auto
	+ hence "SPN (dom \<mu>) = SPN\<^sub>0 (dom \<mu>)"
	+ unfolding SPN_def
	+ using \<mu> 1 Maps.dom_char by simp
	+ thus "Span.dom (SPN \<mu>) = SPN (dom \<mu>)"
	+ using \<mu> SPN_in_hom by auto
	+ qed
	+ show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.cod (SPN \<mu>) = SPN (cod \<mu>)"
	+ proof -
	+ fix \<mu>
	+ assume \<mu>: "arr \<mu>"
	+ have 1: "Maps.arr (MkArr (src (tab\<^sub>0 (cod \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk>)"
	+ proof -
	+ have "src (tab\<^sub>0 (cod \<mu>)) \<in> Collect obj"
	+ using \<mu> by simp
	+ moreover have "src \<mu> \<in> Collect obj"
	+ using \<mu> by simp
	+ moreover have "\<lbrakk>tab\<^sub>0 (cod \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (cod \<mu>))) (src \<mu>)"
	+ proof -
	+ have "\<guillemotleft>tab\<^sub>0 (cod \<mu>) : src (tab\<^sub>0 (cod \<mu>)) \<rightarrow> src \<mu>\<guillemotright>"
	+ using \<mu> by simp
	+ moreover have "is_left_adjoint (tab\<^sub>0 (cod \<mu>))"
	+ using \<mu> by simp
	+ ultimately show ?thesis by auto
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ have "\<lbrakk>spn (cod \<mu>)\<rbrakk> = \<lbrakk>src (tab\<^sub>0 (cod \<mu>))\<rbrakk>"
	+ using \<mu> spn_ide iso_class_eqI by auto
	+ hence "SPN (cod \<mu>) = SPN\<^sub>0 (cod \<mu>)"
	+ unfolding SPN_def
	+ using \<mu> 1 Maps.dom_char by simp
	+ thus "Span.cod (SPN \<mu>) = SPN (cod \<mu>)"
	+ using \<mu> SPN_in_hom by auto
	+ qed
	+ show "\<And>\<nu> \<mu>. seq \<nu> \<mu> \<Longrightarrow> SPN (\<nu> \<cdot> \<mu>) = SPN \<nu> \<bullet> SPN \<mu>"
	+ proof -
	+ fix \<mu> \<nu>
	+ assume seq: "seq \<nu> \<mu>"
	+ have "Dom (SPN (\<nu> \<cdot> \<mu>)) = Dom (SPN \<nu> \<bullet> SPN \<mu>)"
	+ using seq 1 Span.vcomp_def Span.arr_char
	+ by (elim seqE, simp)
	+ moreover have "Cod (SPN (\<nu> \<cdot> \<mu>)) = Cod (SPN \<nu> \<bullet> SPN \<mu>)"
	+ using seq 1 Span.vcomp_def Span.arr_char
	+ by (elim seqE, simp)
	+ moreover have "Chn (SPN (\<nu> \<cdot> \<mu>)) = Chn (SPN \<nu> \<bullet> SPN \<mu>)"
	+ proof -
	+ have *: "\<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk> = Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
	+ proof
	+ show "\<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk> \<subseteq> Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
	+ proof
	+ fix h
	+ assume h: "h \<in> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
	+ show "h \<in> Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
	+ proof -
	+ have 1: "spn \<nu> \<in> \<lbrakk>spn \<nu>\<rbrakk>"
	+ using seq ide_in_iso_class by auto
	+ moreover have 2: "spn \<mu> \<in> \<lbrakk>spn \<mu>\<rbrakk>"
	+ using seq ide_in_iso_class by auto
	+ moreover have "spn \<nu> \<star> spn \<mu> \<cong> h"
	+ proof -
	+ have "spn \<nu> \<star> spn \<mu> \<cong> spn (\<nu> \<cdot> \<mu>)"
	+ using seq spn_hcomp 1 2 iso_class_def isomorphic_reflexive
	+ isomorphic_symmetric
	+ by simp
	+ thus ?thesis
	+ using h isomorphic_transitive iso_class_def by simp
	+ qed
	+ ultimately show ?thesis
	+ unfolding Maps.Comp_def
	+ by (metis (mono_tags, lifting) is_iso_classI spn_simps(2)
	+ mem_Collect_eq seq seqE)
	+ qed
	+ qed
	+ show "Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk> \<subseteq> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
	+ proof
	+ fix h
	+ assume h: "h \<in> Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>"
	+ show "h \<in> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
	+ proof -
	+ obtain f g where 1: "g \<in> \<lbrakk>spn \<nu>\<rbrakk> \<and> f \<in> \<lbrakk>spn \<mu>\<rbrakk> \<and> g \<star> f \<cong> h"
	+ using h Maps.Comp_def [of "iso_class (spn \<nu>)" "iso_class (spn \<mu>)"]
	+ iso_class_def iso_class_elems_isomorphic
	+ by blast
	+ have fg: "g \<cong> spn \<nu> \<and> f \<cong> spn \<mu> \<and> g \<star> f \<cong> h"
	+ proof -
	+ have "spn \<nu> \<in> \<lbrakk>spn \<nu>\<rbrakk> \<and> spn \<mu> \<in> \<lbrakk>spn \<mu>\<rbrakk>"
	+ using seq ide_in_iso_class by auto
	+ thus ?thesis
	+ using 1 iso_class_elems_isomorphic isomorphic_symmetric is_iso_classI
	+ by (meson spn_simps(2) seq seqE)
	+ qed
	+ have "g \<star> f \<in> \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
	+ using seq fg 1 spn_hcomp iso_class_def isomorphic_symmetric by simp
	+ thus ?thesis
	+ using fg isomorphic_transitive iso_class_def by blast
	+ qed
	+ qed
	+ qed
	+ have "Chn (SPN \<nu> \<bullet> SPN \<mu>) =
	+ MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk> \<odot>
	+ MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>"
	+ using 1 seq SPN_def Span.vcomp_def Span.arr_char
	+ apply (elim seqE)
	+ apply simp
	+ by (metis (no_types, lifting) seq vseq_implies_hpar(1) vseq_implies_hpar(2))
	+ also have "... = MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<nu>)))
	+ (Maps.Comp \<lbrakk>spn \<nu>\<rbrakk> \<lbrakk>spn \<mu>\<rbrakk>)"
	+ proof -
	+ have "Maps.seq (MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>)
	+ (MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>)"
	+ proof
	+ show "Maps.in_hom (MkArr (src (tab\<^sub>0 (local.dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>)
	+ (Maps.MkIde (src (tab\<^sub>0 (dom \<mu>))))
	+ (Maps.MkIde (src (tab\<^sub>0 (cod \<mu>))))"
	+ proof -
	+ have "src (tab\<^sub>0 (dom \<mu>)) \<in> Collect obj"
	+ using in_hhom_def seq by auto
	+ moreover have "src (tab\<^sub>0 (cod \<mu>)) \<in> Collect obj"
	+ using seq by auto
	+ moreover have "\<lbrakk>spn \<mu>\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>)))"
	+ using spn_props
	+ by (metis (mono_tags, lifting) mem_Collect_eq seq seqE)
	+ ultimately show ?thesis
	+ using Maps.MkArr_in_hom by simp
	+ qed
	+ show "Maps.in_hom (MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>)
	+ (Maps.MkIde (src (tab\<^sub>0 (cod \<mu>))))
	+ (Maps.MkIde (src (tab\<^sub>0 (cod \<nu>))))"
	+ proof -
	+ have "src (tab\<^sub>0 (cod \<mu>)) \<in> Collect obj"
	+ using in_hhom_def seq by auto
	+ moreover have "src (tab\<^sub>0 (cod \<nu>)) \<in> Collect obj"
	+ using seq by auto
	+ moreover have "\<lbrakk>spn \<nu>\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>)))"
	+ using spn_props
	+ by (metis (mono_tags, lifting) mem_Collect_eq seq seqE)
	+ ultimately show ?thesis
	+ using Maps.MkArr_in_hom by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using Maps.comp_char
	+ [of "MkArr (src (tab\<^sub>0 (cod \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn \<nu>\<rbrakk>"
	+ "MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<mu>))) \<lbrakk>spn \<mu>\<rbrakk>"]
	+ by simp
	+ qed
	+ also have "... = MkArr (src (tab\<^sub>0 (dom \<mu>))) (src (tab\<^sub>0 (cod \<nu>))) \<lbrakk>spn (\<nu> \<cdot> \<mu>)\<rbrakk>"
	+ using * by simp
	+ also have "... = Chn (SPN (\<nu> \<cdot> \<mu>))"
	+ using seq SPN_def Span.vcomp_def
	+ by (elim seqE, simp)
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show "SPN (\<nu> \<cdot> \<mu>) = SPN \<nu> \<bullet> SPN \<mu>" by simp
	+ qed
	+ qed
	+
	+ lemma SPN_is_functor:
	+ shows "functor V Span.vcomp SPN"
	+ ..
	+
	+ interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
	+ proof
	+ show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.isomorphic (SPN (src \<mu>)) (Span.src (SPN \<mu>))"
	+ proof -
	+ fix \<mu>
	+ assume \<mu>: "arr \<mu>"
	+ let ?src = "Maps.MkIde (src \<mu>)"
	+ have src: "Maps.ide ?src"
	+ using \<mu> by simp
	+ interpret src: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>src \<mu>\<close>
	+ using \<mu> by (unfold_locales, auto)
	+ interpret src: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>src \<mu>\<close> src.tab \<open>tab\<^sub>0 (src \<mu>)\<close> \<open>tab\<^sub>1 (src \<mu>)\<close>
	+ \<open>src \<mu>\<close> src.tab \<open>tab\<^sub>0 (src \<mu>)\<close> \<open>tab\<^sub>1 (src \<mu>)\<close>
	+ \<open>src \<mu>\<close>
	+ using src.is_arrow_of_tabulations_in_maps by simp
	+ interpret src: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?src, Leg1 = ?src\<rparr>\<close>
	+ using src by (unfold_locales, simp)
	+
	+ let ?tab\<^sub>0 = "MkArr (src (tab\<^sub>0 (src \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
	+ have tab\<^sub>0_src: "\<guillemotleft>tab\<^sub>0 (src \<mu>) : src (tab\<^sub>0 (src \<mu>)) \<rightarrow> src \<mu>\<guillemotright> \<and>
	+ is_left_adjoint (tab\<^sub>0 (src \<mu>)) \<and> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
	+ using \<mu> by simp
	+ have tab\<^sub>0: "Maps.arr ?tab\<^sub>0"
	+ using \<mu> Maps.arr_MkArr tab\<^sub>0_src by blast
	+ let ?tab\<^sub>1 = "MkArr (src (tab\<^sub>0 (src \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk>"
	+ have tab\<^sub>1_src: "\<guillemotleft>tab\<^sub>1 (src \<mu>) : src (tab\<^sub>0 (src \<mu>)) \<rightarrow> src \<mu>\<guillemotright> \<and>
	+ is_left_adjoint (tab\<^sub>1 (src \<mu>)) \<and> \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk>"
	+ using \<mu> by simp
	+ have tab\<^sub>1: "Maps.arr ?tab\<^sub>1"
	+ using \<mu> Maps.arr_MkArr tab\<^sub>1_src by blast
	+ interpret tab: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<close>
	+ using tab\<^sub>0 tab\<^sub>1 Maps.dom_char Maps.cod_char by (unfold_locales, simp)
	+
	+ have "src \<mu> \<star> tab\<^sub>0 (src \<mu>) \<cong> tab\<^sub>0 (src \<mu>)"
	+ using \<mu> iso_lunit isomorphic_def
	+ by (metis lunit_in_hom(2) src.ide_u src.u_simps(3) src_src)
	+ hence "src \<mu> \<star> tab\<^sub>0 (src \<mu>) \<cong> tab\<^sub>1 (src \<mu>)"
	+ using \<mu> src.obj_has_symmetric_tab isomorphic_transitive by blast
	+
	+ have "\<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (src \<mu>))) (src \<mu>)"
	+ using \<mu> tab\<^sub>0_src by blast
	+ have "\<lbrakk>src \<mu>\<rbrakk> \<in> Maps.Hom (src \<mu>) (src \<mu>)"
	+ proof -
	+ have "\<guillemotleft>src \<mu> : src \<mu> \<rightarrow> src \<mu>\<guillemotright> \<and> is_left_adjoint (src \<mu>) \<and> \<lbrakk>src \<mu>\<rbrakk> = \<lbrakk>src \<mu>\<rbrakk>"
	+ using \<mu> obj_is_self_adjoint by simp
	+ thus ?thesis by auto
	+ qed
	+
	+ interpret SPN_src: arrow_of_spans Maps.comp \<open>SPN (src \<mu>)\<close>
	+ using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
	+ have SPN_src: "SPN (src \<mu>) =
	+ \<lparr>Chn = MkArr (src (tab\<^sub>0 (src \<mu>))) (src (tab\<^sub>0 (src \<mu>))) \<lbrakk>spn (src \<mu>)\<rbrakk>,
	+ Dom = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>,
	+ Cod = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<rparr>"
	+ unfolding SPN_def using \<mu> by simp
	+
	+ interpret src_SPN: arrow_of_spans Maps.comp \<open>Span.src (SPN \<mu>)\<close>
	+ using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
	+ have src_SPN: "Span.src (SPN \<mu>) =
	+ \<lparr>Chn = ?src,
	+ Dom = \<lparr>Leg0 = ?src, Leg1 = ?src\<rparr>,
	+ Cod = \<lparr>Leg0 = ?src, Leg1 = ?src\<rparr>\<rparr>"
	+ proof -
	+ let ?tab\<^sub>0_dom = "MkArr (src (tab\<^sub>0 (dom \<mu>))) (src \<mu>) \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>"
	+ have "Maps.arr ?tab\<^sub>0_dom"
	+ proof -
	+ have "\<guillemotleft>tab\<^sub>0 (dom \<mu>) : src (tab\<^sub>0 (dom \<mu>)) \<rightarrow> src \<mu>\<guillemotright> \<and>
	+ is_left_adjoint (tab\<^sub>0 (dom \<mu>)) \<and> \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (dom \<mu>)\<rbrakk>"
	+ using \<mu> by simp
	+ thus ?thesis
	+ using \<mu> Maps.arr_MkArr by blast
	+ qed
	+ thus ?thesis
	+ using \<mu> Maps.cod_char Span.src_def by simp
	+ qed
	+
	+ text \<open>
	+ The idea of the proof is that @{term "iso_class (tab\<^sub>0 (src \<mu>))"} is invertible
	+ in \<open>Maps(B)\<close> and determines an invertible arrow of spans from @{term "SPN (src \<mu>)"}
	+ to @{term "Span.src (SPN \<mu>)"}.
	+ \<close>
	+
	+ let ?\<phi> = "\<lparr>Chn = ?tab\<^sub>0, Dom = Dom (SPN (src \<mu>)), Cod = Cod (Span.src (SPN \<mu>))\<rparr>"
	+ interpret \<phi>: arrow_of_spans Maps.comp ?\<phi>
	+ apply (unfold_locales, simp_all)
	+ proof -
	+ show "Maps.in_hom ?tab\<^sub>0 SPN_src.dom.apex src_SPN.cod.apex"
	+ using \<mu> tab\<^sub>0 Maps.dom_char Maps.cod_char SPN_src src_SPN
	+ tab.apex_def src_SPN.cod.apex_def
	+ apply (intro Maps.in_homI) by simp_all
	+ show "src_SPN.cod.leg0 \<odot> ?tab\<^sub>0 = SPN_src.dom.leg0"
	+ proof -
	+ have "Maps.seq src_SPN.cod.leg0 ?tab\<^sub>0"
	+ using \<mu> src_SPN tab\<^sub>0 Maps.dom_char Maps.cod_char
	+ by (intro Maps.seqI, auto)
	+ moreover have "Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
	+ proof -
	+ have "tab\<^sub>0 (src \<mu>) \<in> Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
	+ using \<mu> is_iso_classI ide_in_iso_class [of "src \<mu>"]
	+ ide_in_iso_class [of "tab\<^sub>0 (src \<mu>)"] \<open>src \<mu> \<star> tab\<^sub>0 (src \<mu>) \<cong> tab\<^sub>0 (src \<mu>)\<close>
	+ by auto
	+ thus ?thesis
	+ using Maps.Comp_eq_iso_class_memb
	+ \<open>\<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (src \<mu>))) (src \<mu>)\<close>
	+ \<open>\<lbrakk>src \<mu>\<rbrakk> \<in> Maps.Hom (src \<mu>) (src \<mu>)\<close>
	+ by meson
	+ qed
	+ ultimately show ?thesis
	+ using \<mu> Maps.comp_char [of src_SPN.cod.leg0 ?tab\<^sub>0] src_SPN by simp
	+ qed
	+ show "src_SPN.cod.leg1 \<odot> ?tab\<^sub>0 = SPN_src.dom.leg1"
	+ proof -
	+ have "Maps.seq src_SPN.cod.leg1 ?tab\<^sub>0"
	+ using \<mu> src_SPN tab\<^sub>0 Maps.dom_char Maps.cod_char
	+ by (intro Maps.seqI, auto)
	+ moreover have "Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (src \<mu>)\<rbrakk>"
	+ proof -
	+ have "tab\<^sub>1 (src \<mu>) \<in> Maps.Comp \<lbrakk>src \<mu>\<rbrakk> \<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk>"
	+ using \<mu> is_iso_classI ide_in_iso_class [of "src \<mu>"]
	+ ide_in_iso_class [of "tab\<^sub>0 (src \<mu>)"]
	+ \<open>isomorphic (src \<mu> \<star> tab\<^sub>0 (src \<mu>)) (tab\<^sub>1 (src \<mu>))\<close>
	+ by auto
	+ thus ?thesis
	+ using Maps.Comp_eq_iso_class_memb
	+ \<open>\<lbrakk>tab\<^sub>0 (src \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (src \<mu>))) (src \<mu>)\<close>
	+ \<open>\<lbrakk>src \<mu>\<rbrakk> \<in> Maps.Hom (src \<mu>) (src \<mu>)\<close>
	+ by meson
	+ qed
	+ ultimately show ?thesis
	+ using \<mu> Maps.comp_char [of src_SPN.cod.leg1 ?tab\<^sub>0] src_SPN by simp
	+ qed
	+ qed
	+ have "Span.in_hom ?\<phi> (SPN (src \<mu>)) (Span.src (SPN \<mu>))"
	+ using \<mu> tab\<^sub>0 spn_ide [of "src \<mu>"] iso_class_eqI
	+ Span.arr_char Span.dom_char Span.cod_char \<phi>.arrow_of_spans_axioms
	+ SPN_src src_SPN src.apex_def tab.apex_def Maps.dom_char
	+ apply (intro Span.in_homI) by auto
	+ (* The preceding cannot be written "by (intro Span.in_homI, auto)", why? *)
	+ moreover have "Maps.iso ?tab\<^sub>0"
	+ using \<mu> tab\<^sub>0 ide_in_iso_class src.is_map_iff_tab\<^sub>0_is_equivalence obj_is_self_adjoint
	+ Maps.iso_char' [of ?tab\<^sub>0]
	+ by auto
	+ ultimately show "Span.isomorphic (SPN (src \<mu>)) (Span.src (SPN \<mu>))"
	+ using Span.isomorphic_def Span.iso_char by auto
	+ qed
	+ show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Span.isomorphic (SPN (trg \<mu>)) (Span.trg (SPN \<mu>))"
	+ proof -
	+ fix \<mu>
	+ assume \<mu>: "arr \<mu>"
	+ let ?trg = "Maps.MkIde (trg \<mu>)"
	+ have trg: "Maps.ide ?trg"
	+ using \<mu> by simp
	+ interpret trg: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>trg \<mu>\<close>
	+ using \<mu> by (unfold_locales, auto)
	+ interpret trg: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?trg, Leg1 = ?trg\<rparr>\<close>
	+ using trg by (unfold_locales, simp)
	+
	+ let ?tab\<^sub>0 = "MkArr (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
	+ have tab\<^sub>0_trg: "\<guillemotleft>tab\<^sub>0 (trg \<mu>) : src (tab\<^sub>0 (trg \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and>
	+ is_left_adjoint (tab\<^sub>0 (trg \<mu>)) \<and> \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
	+ using \<mu> by simp
	+ have tab\<^sub>0: "Maps.arr ?tab\<^sub>0"
	+ using \<mu> Maps.arr_MkArr tab\<^sub>0_trg by blast
	+ let ?tab\<^sub>1 = "MkArr (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
	+ have tab\<^sub>1_trg: "\<guillemotleft>tab\<^sub>1 (trg \<mu>) : src (tab\<^sub>0 (trg \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and>
	+ is_left_adjoint (tab\<^sub>1 (trg \<mu>)) \<and> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
	+ using \<mu> by simp
	+ have tab\<^sub>1: "Maps.arr ?tab\<^sub>1"
	+ using \<mu> Maps.arr_MkArr tab\<^sub>1_trg by blast
	+ interpret tab: span_in_category Maps.comp \<open>\<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<close>
	+ using tab\<^sub>0 tab\<^sub>1 Maps.dom_char Maps.cod_char by (unfold_locales, simp)
	+
	+ have "trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>0 (trg \<mu>)"
	+ proof -
	+ have "\<guillemotleft>\<l>[tab\<^sub>1 (trg \<mu>)] : trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<Rightarrow> tab\<^sub>1 (trg \<mu>)\<guillemotright>"
	+ using \<mu> by simp
	+ moreover have "iso \<l>[tab\<^sub>1 (trg \<mu>)]"
	+ using \<mu> iso_lunit by simp
	+ ultimately have "trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)"
	+ using isomorphic_def by auto
	+ also have "tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>0 (trg \<mu>)"
	+ using \<mu> trg.obj_has_symmetric_tab isomorphic_symmetric by auto
	+ finally show ?thesis by blast
	+ qed
	+ hence "trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)"
	+ using \<mu> trg.obj_has_symmetric_tab isomorphic_transitive by blast
	+
	+ have "\<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>)"
	+ proof -
	+ have "\<guillemotleft>tab\<^sub>1 (trg \<mu>) : src (tab\<^sub>0 (trg \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and> is_left_adjoint (tab\<^sub>0 (trg \<mu>)) \<and>
	+ \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
	+ using \<mu> by simp
	+ thus ?thesis by auto
	+ qed
	+ have "\<lbrakk>trg \<mu>\<rbrakk> \<in> Maps.Hom (trg \<mu>) (trg \<mu>)"
	+ proof -
	+ have "\<guillemotleft>trg \<mu> : trg \<mu> \<rightarrow> trg \<mu>\<guillemotright> \<and> is_left_adjoint (trg \<mu>) \<and> \<lbrakk>trg \<mu>\<rbrakk> = \<lbrakk>trg \<mu>\<rbrakk>"
	+ using \<mu> obj_is_self_adjoint by simp
	+ thus ?thesis by auto
	+ qed
	+
	+ interpret SPN_trg: arrow_of_spans Maps.comp \<open>SPN (trg \<mu>)\<close>
	+ using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
	+ have SPN_trg: "SPN (trg \<mu>) =
	+ \<lparr>Chn = MkArr (src (tab\<^sub>1 (trg \<mu>))) (src (tab\<^sub>1 (trg \<mu>))) \<lbrakk>spn (trg \<mu>)\<rbrakk>,
	+ Dom = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>,
	+ Cod = \<lparr>Leg0 = ?tab\<^sub>0, Leg1 = ?tab\<^sub>1\<rparr>\<rparr>"
	+ unfolding SPN_def using \<mu> by simp
	+
	+ interpret trg_SPN: arrow_of_spans Maps.comp \<open>Span.trg (SPN \<mu>)\<close>
	+ using \<mu> SPN.preserves_reflects_arr Span.arr_char by blast
	+ have trg_SPN: "Span.trg (SPN \<mu>) = \<lparr>Chn = ?trg,
	+ Dom = \<lparr>Leg0 = ?trg, Leg1 = ?trg\<rparr>,
	+ Cod = \<lparr>Leg0 = ?trg, Leg1 = ?trg\<rparr>\<rparr>"
	+ proof -
	+ let ?tab\<^sub>1_dom = "MkArr (src (tab\<^sub>1 (dom \<mu>))) (trg \<mu>) \<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>"
	+ have "Maps.arr ?tab\<^sub>1_dom"
	+ proof -
	+ have "\<guillemotleft>tab\<^sub>1 (dom \<mu>) : src (tab\<^sub>1 (dom \<mu>)) \<rightarrow> trg \<mu>\<guillemotright> \<and>
	+ is_left_adjoint (tab\<^sub>1 (dom \<mu>)) \<and> \<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (dom \<mu>)\<rbrakk>"
	+ using \<mu> by simp
	+ thus ?thesis
	+ using \<mu> Maps.arr_MkArr by blast
	+ qed
	+ thus ?thesis
	+ using \<mu> Maps.cod_char Span.trg_def by simp
	+ qed
	+
	+ let ?\<phi> = "\<lparr>Chn = ?tab\<^sub>1, Dom = Dom (SPN (trg \<mu>)), Cod = Cod (Span.trg (SPN \<mu>))\<rparr>"
	+ interpret \<phi>: arrow_of_spans Maps.comp ?\<phi>
	+ apply (unfold_locales, simp_all)
	+ proof -
	+ show "Maps.in_hom ?tab\<^sub>1 SPN_trg.dom.apex trg_SPN.cod.apex"
	+ using \<mu> tab\<^sub>0 tab\<^sub>1 Maps.dom_char Maps.cod_char SPN_trg trg_SPN
	+ tab.apex_def trg_SPN.cod.apex_def
	+ apply (intro Maps.in_homI) by simp_all
	+ (* The preceding cannot be written "by (intro Maps.in_homI, simp_all)", why? *)
	+ show "Maps.comp trg_SPN.cod.leg0 ?tab\<^sub>1 = SPN_trg.dom.leg0"
	+ proof -
	+ have "Maps.seq trg_SPN.cod.leg0 ?tab\<^sub>1"
	+ using \<mu> trg_SPN tab\<^sub>1 Maps.dom_char Maps.cod_char
	+ by (intro Maps.seqI, auto)
	+ moreover have "Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
	+ proof -
	+ have "tab\<^sub>1 (trg \<mu>) \<in> Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
	+ using \<mu> is_iso_classI ide_in_iso_class [of "trg \<mu>"]
	+ ide_in_iso_class [of "tab\<^sub>1 (trg \<mu>)"] \<open>trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)\<close>
	+ by auto
	+ thus ?thesis
	+ using Maps.Comp_eq_iso_class_memb
	+ \<open>iso_class (tab\<^sub>1 (trg \<mu>)) \<in> Maps.Hom (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>)\<close>
	+ \<open>iso_class (trg \<mu>) \<in> Maps.Hom (trg \<mu>) (trg \<mu>)\<close>
	+ by meson
	+ qed
	+ moreover have "\<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk>"
	+ using \<mu> iso_class_eqI trg.obj_has_symmetric_tab by auto
	+ ultimately show ?thesis
	+ using \<mu> Maps.comp_char [of trg_SPN.cod.leg0 ?tab\<^sub>1] trg_SPN
	+ by simp
	+ qed
	+ show "trg_SPN.cod.leg1 \<odot> ?tab\<^sub>1 = SPN_trg.dom.leg1"
	+ proof -
	+ have "Maps.seq trg_SPN.cod.leg1 ?tab\<^sub>1"
	+ using \<mu> trg_SPN tab\<^sub>1 Maps.dom_char Maps.cod_char
	+ by (intro Maps.seqI, auto)
	+ moreover have "Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
	+ proof -
	+ have "tab\<^sub>1 (trg \<mu>) \<in> Maps.Comp \<lbrakk>trg \<mu>\<rbrakk> \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
	+ using \<mu> is_iso_classI ide_in_iso_class [of "trg \<mu>"]
	+ ide_in_iso_class [of "tab\<^sub>1 (trg \<mu>)"] \<open>trg \<mu> \<star> tab\<^sub>1 (trg \<mu>) \<cong> tab\<^sub>1 (trg \<mu>)\<close>
	+ by auto
	+ thus ?thesis
	+ using Maps.Comp_eq_iso_class_memb
	+ \<open>\<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk> \<in> Maps.Hom (src (tab\<^sub>0 (trg \<mu>))) (trg \<mu>)\<close>
	+ \<open>\<lbrakk>trg \<mu>\<rbrakk> \<in> Maps.Hom (trg \<mu>) (trg \<mu>)\<close>
	+ by meson
	+ qed
	+ ultimately show ?thesis
	+ using \<mu> Maps.comp_char [of trg_SPN.cod.leg1 ?tab\<^sub>1] trg_SPN by simp
	+ qed
	+ qed
	+ have \<phi>: "Span.in_hom ?\<phi> (SPN (trg \<mu>)) (Span.trg (SPN \<mu>))"
	+ using \<mu> tab\<^sub>0 spn_ide [of "trg \<mu>"] iso_class_eqI
	+ Span.arr_char Span.dom_char Span.cod_char \<phi>.arrow_of_spans_axioms
	+ SPN_trg trg_SPN trg.apex_def tab.apex_def Maps.dom_char
	+ apply (intro Span.in_homI) by auto
	+ have "Maps.iso ?tab\<^sub>1"
	+ proof -
	+ have "Maps.iso ?tab\<^sub>0"
	+ using \<mu> tab\<^sub>0 ide_in_iso_class trg.is_map_iff_tab\<^sub>0_is_equivalence obj_is_self_adjoint
	+ Maps.iso_char' [of ?tab\<^sub>0]
	+ by auto
	+ moreover have "?tab\<^sub>0 = ?tab\<^sub>1"
	+ proof -
	+ have "\<lbrakk>tab\<^sub>0 (trg \<mu>)\<rbrakk> = \<lbrakk>tab\<^sub>1 (trg \<mu>)\<rbrakk>"
	+ using \<mu> iso_class_eqI trg.obj_has_symmetric_tab by auto
	+ thus ?thesis by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ thus "Span.isomorphic (SPN (trg \<mu>)) (Span.trg (SPN \<mu>))"
	+ using \<phi> Span.isomorphic_def Span.iso_char by auto
	+ qed
	+ qed
	+
	+ lemma SPN_is_weak_arrow_of_homs:
	+ shows "weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN"
	+ ..
	+
	+ end
	+
	+ subsubsection "Compositors"
	+
	+ text \<open>
	+ To complete the proof that \<open>SPN\<close> is a pseudofunctor, we need to obtain a natural
	+ isomorphism \<open>\<Phi>\<close>, whose component at \<open>(r, s)\<close> is an isomorphism \<open>\<Phi> (r, s)\<close>
	+ from the horizontal composite \<open>SPN r \<circ> SPN s\<close> to \<open>SPN (r \<star> s)\<close> in \<open>Span(Maps(B))\<close>,
	+ and we need to prove that the coherence conditions are satisfied.
	+
	+ We have shown that the tabulations of \<open>r\<close> and \<open>s\<close> compose to yield a tabulation of \<open>r \<star> s\<close>.
	+ Since tabulations of the same arrow are equivalent, this tabulation must be equivalent
	+ to the chosen tabulation of \<open>r \<star> s\<close>. We therefore obtain an equivalence map from the
	+ apex of \<open>SPN r \<circ> SPN s\<close> to the apex of \<open>SPN (r \<star> s)\<close> which commutes with the
	+ legs of these spans up to isomorphism. This equivalence map determines an invertible
	+ arrow in \<open>Span(Maps(B))\<close>. Moreover, by property \<open>T2\<close>, any two such equivalence maps are
	+ connected by a unique 2-cell, which is consequently an isomorphism. This shows that
	+ the arrow in \<open>Span(Maps(B))\<close> is uniquely determined, which fact we can exploit to establish
	+ the required coherence conditions.
	+ \<close>
	+
	+ locale two_composable_identities_in_bicategory_of_spans =
	+ bicategory_of_spans V H \<a> \<i> src trg +
	+ r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r +
	+ s: identity_in_bicategory_of_spans V H \<a> \<i> src trg s
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and r :: 'a
	+ and s :: 'a +
	+ assumes composable: "src r = trg s"
	+ begin
	+
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ interpretation r: arrow_in_bicategory_of_spans V H \<a> \<i> src trg r r r
	+ by (unfold_locales, auto)
	+ interpretation r: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
	+ r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close>
	+ r
	+ using r.is_arrow_of_tabulations_in_maps by simp
	+ interpretation s: arrow_in_bicategory_of_spans V H \<a> \<i> src trg s s s
	+ by (unfold_locales, auto)
	+ interpretation s: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
	+ s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
	+ s
	+ using s.is_arrow_of_tabulations_in_maps by simp
	+
	+ sublocale identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>r \<star> s\<close>
	+ apply unfold_locales by (simp add: composable)
	+ sublocale horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
	+ r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
	+ r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close>
	+ r s
	+ using composable by (unfold_locales, auto)
	+
	+ abbreviation p\<^sub>0 where "p\<^sub>0 \<equiv> \<rho>\<sigma>.p\<^sub>0"
	+ abbreviation p\<^sub>1 where "p\<^sub>1 \<equiv> \<rho>\<sigma>.p\<^sub>1"
	+
	+ text \<open>
	+ We will take as the composition isomorphism from \<open>SPN r \<circ> SPN s\<close> to \<open>SPN (r \<star> s)\<close>
	+ the arrow of tabulations, induced by the identity \<open>r \<star> s\<close>, from the composite of
	+ the chosen tabulations of \<open>r\<close> and \<open>s\<close> to the chosen tabulation of \<open>r \<star> s\<close>.
	+ As this arrow of tabulations is induced by an identity, it is an equivalence map.
	+ \<close>
	+
	+ interpretation cmp: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>r \<star> s\<close> \<rho>\<sigma>.tab \<open>tab\<^sub>0 s \<star> \<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 r \<star> \<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>r \<star> s\<close> tab \<open>tab\<^sub>0 (r \<star> s)\<close> \<open>tab\<^sub>1 (r \<star> s)\<close>
	+ \<open>r \<star> s\<close>
	+ using composable
	+ by (unfold_locales, auto)
	+
	+ lemma cmp_interpretation:
	+ shows "identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ (r \<star> s) \<rho>\<sigma>.tab (tab\<^sub>0 s \<star> \<rho>\<sigma>.p\<^sub>0) (tab\<^sub>1 r \<star> \<rho>\<sigma>.p\<^sub>1)
	+ (r \<star> s) tab (tab\<^sub>0 (r \<star> s)) (tab\<^sub>1 (r \<star> s))
	+ (r \<star> s)"
	+ ..
	+
	+ definition cmp
	+ where "cmp = cmp.chine"
	+
	+ lemma cmp_props:
	+ shows "\<guillemotleft>cmp : src \<rho>\<sigma>.tab \<rightarrow> src tab\<guillemotright>"
	+ and "\<guillemotleft>cmp : cmp \<Rightarrow> cmp\<guillemotright>"
	+ and "equivalence_map cmp"
	+ and "tab\<^sub>0 (r \<star> s) \<star> cmp \<cong> tab\<^sub>0 s \<star> \<rho>\<sigma>.p\<^sub>0"
	+ and "tab\<^sub>1 (r \<star> s) \<star> cmp \<cong> tab\<^sub>1 r \<star> \<rho>\<sigma>.p\<^sub>1"
	+ using cmp_def cmp.leg0_uniquely_isomorphic(1) cmp.leg1_uniquely_isomorphic(1)
	+ isomorphic_symmetric cmp.chine_is_equivalence
	+ by auto
	+
	+ lemma cmp_in_hom [intro]:
	+ shows "\<guillemotleft>cmp : src \<rho>\<sigma>.tab \<rightarrow> src tab\<guillemotright>"
	+ and "\<guillemotleft>cmp : cmp \<Rightarrow> cmp\<guillemotright>"
	+ using cmp_props by auto
	+
	+ lemma cmp_simps [simp]:
	+ shows "arr cmp" and "ide cmp"
	+ and "src cmp = src \<rho>\<sigma>.tab" and "trg cmp = src tab"
	+ and "dom cmp = cmp" and "cod cmp = cmp"
	+ using cmp_props equivalence_map_is_ide by auto
	+
	+ text \<open>
	+ Now we have to use the above properties of the underlying bicategory to
	+ exhibit the composition isomoprhisms as actual arrows in \<open>Span(Maps(B))\<close>
	+ and to prove the required naturality and coherence conditions.
	+ \<close>
	+
	+ interpretation Maps: maps_category V H \<a> \<i> src trg ..
	+ interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
	+
	+ no_notation Fun.comp (infixl "\<circ>" 55)
	+ notation Span.vcomp (infixr "\<bullet>" 55)
	+ notation Span.hcomp (infixr "\<circ>" 53)
	+ notation Maps.comp (infixr "\<odot>" 55)
	+
	+ interpretation SPN: "functor" V Span.vcomp SPN
	+ using SPN_is_functor by simp
	+ interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
	+ using SPN_is_weak_arrow_of_homs by simp
	+
	+ interpretation SPN_r_SPN_s: arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
	+ using composable Span.ide_char [of "SPN r \<circ> SPN s"] by simp
	+ interpretation SPN_r_SPN_s: identity_arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
	+ using composable Span.ide_char [of "SPN r \<circ> SPN s"]
	+ by (unfold_locales, simp)
	+ interpretation SPN_rs: arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
	+ using composable Span.arr_char r.base_simps(2) s.base_simps(2) by blast
	+ interpretation SPN_rs: identity_arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
	+ using composable Span.ide_char SPN.preserves_ide r.is_ide s.is_ide
	+ by (unfold_locales, simp)
	+
	+ text \<open>
	+ The following are the legs (as arrows of \<open>Maps\<close>) of the spans \<open>SPN r\<close> and \<open>SPN s\<close>.
	+ \<close>
	+
	+ definition R\<^sub>0 where "R\<^sub>0 = \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk>"
	+ definition R\<^sub>1 where "R\<^sub>1 = \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>"
	+ definition S\<^sub>0 where "S\<^sub>0 = \<lbrakk>\<lbrakk>tab\<^sub>0 s\<rbrakk>\<rbrakk>"
	+ definition S\<^sub>1 where "S\<^sub>1 = \<lbrakk>\<lbrakk>tab\<^sub>1 s\<rbrakk>\<rbrakk>"
	+
	+ lemma span_legs_eq:
	+ shows "Leg0 (Dom (SPN r)) = R\<^sub>0" and "Leg1 (Dom (SPN r)) = R\<^sub>1"
	+ and "Leg0 (Dom (SPN s)) = S\<^sub>0" and "Leg1 (Dom (SPN s)) = S\<^sub>1"
	+ using SPN_def R\<^sub>0_def R\<^sub>1_def S\<^sub>0_def S\<^sub>1_def composable by auto
	+
	+ lemma R\<^sub>0_in_hom [intro]:
	+ shows "Maps.in_hom R\<^sub>0 (Maps.MkIde (src r.s\<^sub>0)) (Maps.MkIde (src r))"
	+ by (simp add: Maps.MkArr_in_hom' R\<^sub>0_def)
	+
	+ lemma R\<^sub>1_in_hom [intro]:
	+ shows "Maps.in_hom R\<^sub>1 (Maps.MkIde (src r.s\<^sub>0)) (Maps.MkIde (trg r))"
	+ by (simp add: Maps.MkArr_in_hom' R\<^sub>1_def)
	+
	+ lemma S\<^sub>0_in_hom [intro]:
	+ shows "Maps.in_hom S\<^sub>0 (Maps.MkIde (src s.s\<^sub>0)) (Maps.MkIde (src s))"
	+ by (simp add: Maps.MkArr_in_hom' S\<^sub>0_def)
	+
	+ lemma S\<^sub>1_in_hom [intro]:
	+ shows "Maps.in_hom S\<^sub>1 (Maps.MkIde (src s.s\<^sub>0)) (Maps.MkIde (trg s))"
	+ by (simp add: Maps.MkArr_in_hom' S\<^sub>1_def)
	+
	+ lemma RS_simps [simp]:
	+ shows "Maps.arr R\<^sub>0" and "Maps.dom R\<^sub>0 = Maps.MkIde (src r.s\<^sub>0)"
	+ and "Maps.cod R\<^sub>0 = Maps.MkIde (src r)"
	+ and "Maps.Dom R\<^sub>0 = src r.s\<^sub>0" and "Maps.Cod R\<^sub>0 = src r"
	+ and "Maps.arr R\<^sub>1" and "Maps.dom R\<^sub>1 = Maps.MkIde (src r.s\<^sub>0)"
	+ and "Maps.cod R\<^sub>1 = Maps.MkIde (trg r)"
	+ and "Maps.Dom R\<^sub>1 = src r.s\<^sub>0" and "Maps.Cod R\<^sub>1 = trg r"
	+ and "Maps.arr S\<^sub>0" and "Maps.dom S\<^sub>0 = Maps.MkIde (src s.s\<^sub>0)"
	+ and "Maps.cod S\<^sub>0 = Maps.MkIde (src s)"
	+ and "Maps.Dom S\<^sub>0 = src s.s\<^sub>0" and "Maps.Cod S\<^sub>0 = src s"
	+ and "Maps.arr S\<^sub>1" and "Maps.dom S\<^sub>1 = Maps.MkIde (src s.s\<^sub>0)"
	+ and "Maps.cod S\<^sub>1 = Maps.MkIde (trg s)"
	+ and "Maps.Dom S\<^sub>1 = src s.s\<^sub>0" and "Maps.Cod S\<^sub>1 = trg s"
	+ using R\<^sub>0_in_hom R\<^sub>1_in_hom S\<^sub>0_in_hom S\<^sub>1_in_hom composable
	+ by (auto simp add: R\<^sub>0_def R\<^sub>1_def S\<^sub>0_def S\<^sub>1_def)
	+
	+ text \<open>
	+ The apex of the composite span @{term "SPN r \<circ> SPN s"} (defined in terms of pullback)
	+ coincides with the apex of the composite tabulation \<open>\<rho>\<sigma>\<close> (defined using
	+ the chosen tabulation of \<open>(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s)\<close>). We need this to be true in order
	+ to define the compositor of a pseudofunctor from the underlying bicategory \<open>B\<close>
	+ to \<open>Span(Maps(B))\<close>. It is only true if we have carefully chosen pullbacks in \<open>Maps(B)\<close>
	+ in order to ensure the relationship with the chosen tabulations.
	+ \<close>
	+
	+ lemma SPN_r_SPN_s_apex_eq:
	+ shows "SPN_r_SPN_s.apex = Maps.MkIde (src \<rho>\<sigma>.tab)"
	+ proof -
	+ have "obj (Maps.Cod SPN_r_SPN_s.leg0)"
	+ using Maps.arr_char [of "SPN_r_SPN_s.leg0"] by simp
	+ moreover have "obj (Maps.Dom SPN_r_SPN_s.leg0)"
	+ using Maps.arr_char [of "SPN_r_SPN_s.leg0"] by simp
	+ moreover have "SPN_r_SPN_s.leg0 \<noteq> Null"
	+ using Maps.arr_char [of "SPN_r_SPN_s.leg0"] by simp
	+ moreover have "Maps.Dom SPN_r_SPN_s.leg0 = src \<rho>\<sigma>.tab"
	+ proof -
	+ interpret REP_S\<^sub>1: map_in_bicategory V H \<a> \<i> src trg \<open>Maps.REP S\<^sub>1\<close>
	+ using Maps.REP_in_Map Maps.arr_char Maps.in_HomD S\<^sub>1_def
	+ apply unfold_locales
	+ by (meson Maps.REP_in_hhom(2) S\<^sub>1_in_hom)
	+ interpret REP_R\<^sub>0: map_in_bicategory V H \<a> \<i> src trg \<open>Maps.REP R\<^sub>0\<close>
	+ using Maps.REP_in_Map Maps.arr_char Maps.in_HomD R\<^sub>0_def
	+ apply unfold_locales
	+ by (meson Maps.REP_in_hhom(2) R\<^sub>0_in_hom)
	+ have "Maps.Dom SPN_r_SPN_s.leg0 = Maps.Dom (S\<^sub>0 \<odot> Maps.PRJ\<^sub>0 R\<^sub>0 S\<^sub>1)"
	+ using composable Span.hcomp_def S\<^sub>0_def R\<^sub>0_def S\<^sub>1_def by simp
	+ also have "... = Maps.Dom \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "is_left_adjoint (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
	+ proof -
	+ have "ide ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
	+ proof -
	+ have "src (Maps.REP R\<^sub>0)\<^sup>* = trg (Maps.REP S\<^sub>1)"
	+ using REP_R\<^sub>0.is_map REP_S\<^sub>1.is_map left_adjoint_is_ide R\<^sub>0_def S\<^sub>1_def
	+ by (metis (no_types, lifting) Maps.REP_CLS REP_R\<^sub>0.antipar(2)
	+ isomorphic_implies_hpar(4) composable r.leg0_simps(3)
	+ r.satisfies_T0 s.leg1_is_map s.leg1_simps(3) s.leg1_simps(4))
	+ thus ?thesis by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ moreover have "Maps.Dom (S\<^sub>0 \<odot> \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>) =
	+ src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
	+ proof -
	+ have "Maps.arr (\<lbrakk>\<lbrakk>prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)\<rbrakk>\<rbrakk>)"
	+ using Maps.CLS_in_hom Maps.prj0_simps(1) Maps.PRJ\<^sub>0_def composable by fastforce
	+ moreover have "Maps.Dom S\<^sub>0 = Maps.Cod \<lbrakk>\<lbrakk>prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "Maps.Cod \<lbrakk>\<lbrakk>prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)\<rbrakk>\<rbrakk> =
	+ trg (prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0))"
	+ by simp
	+ also have "... = src (Maps.REP S\<^sub>1)"
	+ proof -
	+ have "ide (Maps.REP S\<^sub>1)"
	+ by simp
	+ moreover have "is_left_adjoint (Maps.REP R\<^sub>0)"
	+ by auto
	+ moreover have "trg (Maps.REP S\<^sub>1) = trg (Maps.REP R\<^sub>0)"
	+ by (simp add: composable)
	+ ultimately show ?thesis
	+ using S\<^sub>1_def Maps.REP_CLS r.leg0_is_map s.leg1_is_map by simp
	+ qed
	+ also have "... = src (tab\<^sub>0 s)"
	+ using tab\<^sub>0_in_hom(1) by simp
	+ also have "... = Maps.Dom S\<^sub>0"
	+ using S\<^sub>0_def by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately have
	+ "Maps.Dom (S\<^sub>0 \<odot> \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>) =
	+ Maps.Dom \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)\<rbrakk>\<rbrakk>"
	+ using Maps.CLS_in_hom by simp
	+ thus ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using Maps.PRJ\<^sub>0_def Maps.CLS_in_hom Maps.dom_char composable Span.hcomp_def
	+ \<rho>\<sigma>.tab_in_hom s.leg0_is_map s.leg1_is_map Maps.span_prj
	+ r.satisfies_T0 s.satisfies_T0
	+ Maps.Dom.simps(1) RS_simps(1) RS_simps(16) RS_simps(18) RS_simps(3)
	+ by presburger
	+ qed
	+ also have "... = src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
	+ by simp
	+ finally have
	+ "Maps.Dom SPN_r_SPN_s.leg0 = src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1))"
	+ by simp
	+ also have "... = src (tab\<^sub>0 (r.s\<^sub>0\<^sup>* \<star> s.s\<^sub>1))"
	+ proof -
	+ interpret r\<^sub>0's\<^sub>1: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>r.s\<^sub>0\<^sup>* \<star> s.s\<^sub>1\<close>
	+ using composable by (unfold_locales, simp)
	+ have "(Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1 \<cong> r.s\<^sub>0\<^sup>* \<star> s.s\<^sub>1"
	+ proof -
	+ have "(Maps.REP R\<^sub>0)\<^sup>* \<cong> r.s\<^sub>0\<^sup>*"
	+ proof -
	+ have 1: "adjoint_pair (Maps.REP R\<^sub>0) (Maps.REP R\<^sub>0)\<^sup>*"
	+ using REP_R\<^sub>0.is_map left_adjoint_extends_to_adjoint_pair by blast
	+ moreover have "adjoint_pair r.s\<^sub>0 (Maps.REP R\<^sub>0)\<^sup>*"
	+ proof -
	+ have "Maps.REP R\<^sub>0 \<cong> r.s\<^sub>0"
	+ unfolding R\<^sub>0_def
	+ using Maps.REP_CLS r.leg0_is_map composable by force
	+ thus ?thesis
	+ using 1 adjoint_pair_preserved_by_iso isomorphic_def
	+ REP_R\<^sub>0.triangle_in_hom(4) REP_R\<^sub>0.triangle_right'
	+ by auto
	+ qed
	+ ultimately show ?thesis
	+ using r.leg0_is_map left_adjoint_determines_right_up_to_iso
	+ left_adjoint_extends_to_adjoint_pair
	+ by auto
	+ qed
	+ moreover have "Maps.REP S\<^sub>1 \<cong> s.s\<^sub>1"
	+ unfolding S\<^sub>1_def
	+ using Maps.REP_CLS s.leg1_is_map composable by force
	+ moreover have "\<exists>a. a \<cong> (tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<and> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1 \<cong> a"
	+ using calculation composable isomorphic_implies_hpar(3)
	+ hcomp_ide_isomorphic hcomp_isomorphic_ide [of "(Maps.REP R\<^sub>0)\<^sup>" "r.s\<^sub>0\<^sup>" s.s\<^sub>1]
	+ by auto
	+ ultimately show ?thesis
	+ using isomorphic_transitive by blast
	+ qed
	+ thus ?thesis
	+ using r\<^sub>0's\<^sub>1.isomorphic_implies_same_tab isomorphic_symmetric by metis
	+ qed
	+ also have "... = src \<rho>\<sigma>.tab"
	+ using VV.ide_char VV.arr_char composable Span.hcomp_def \<rho>\<sigma>.tab_simps(2) by auto
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using composable Maps.arr_char Maps.dom_char SPN_r_SPN_s.dom.apex_def
	+ apply auto
	+ by (metis (no_types, lifting) Maps.not_arr_null SPN_r_SPN_s.chine_eq_apex
	+ SPN_r_SPN_s.chine_simps(1))
	+ qed
	+
	+ text \<open>
	+ We will be taking the arrow @{term "CLS cmp"} of \<open>Maps\<close> as the composition isomorphism from
	+ @{term "SPN r \<circ> SPN s"} to @{term "SPN (r \<star> s)"}. The following result shows that it
	+ has the right domain and codomain for that purpose.
	+ \<close>
	+
	+ lemma iso_class_cmp_in_hom:
	+ shows "Maps.in_hom (MkArr (src \<rho>\<sigma>.tab) (src tab) \<lbrakk>cmp\<rbrakk>)
	+ SPN_r_SPN_s.apex SPN_rs.apex"
	+ and "Maps.in_hom \<lbrakk>\<lbrakk>cmp\<rbrakk>\<rbrakk> SPN_r_SPN_s.apex SPN_rs.apex"
	+ proof -
	+ show "Maps.in_hom (MkArr (src \<rho>\<sigma>.tab) (src tab) \<lbrakk>cmp\<rbrakk>)
	+ SPN_r_SPN_s.apex SPN_rs.apex"
	+ proof -
	+ have "obj (src \<rho>\<sigma>.tab)"
	+ using obj_src \<rho>\<sigma>.tab_in_hom by blast
	+ moreover have "obj (src tab)"
	+ using obj_src by simp
	+ moreover have "\<lbrakk>cmp\<rbrakk> \<in> Maps.Hom (src \<rho>\<sigma>.tab) (src tab)"
	+ by (metis (mono_tags, lifting) cmp.is_map cmp_def cmp_props(1) mem_Collect_eq)
	+ moreover have "SPN_r_SPN_s.apex = Maps.MkIde (src \<rho>\<sigma>.tab)"
	+ using SPN_r_SPN_s_apex_eq by simp
	+ moreover have "SPN_rs.apex = Maps.MkIde (src tab)"
	+ using SPN_def composable SPN_rs.cod.apex_def Maps.arr_char Maps.dom_char
	+ SPN_rs.dom.leg_simps(1)
	+ by fastforce
	+ ultimately show ?thesis
	+ using Maps.MkArr_in_hom by simp
	+ qed
	+ thus "Maps.in_hom \<lbrakk>\<lbrakk>cmp\<rbrakk>\<rbrakk> SPN_r_SPN_s.apex SPN_rs.apex" by simp
	+ qed
	+
	+ interpretation r\<^sub>0's\<^sub>1: two_composable_identities_in_bicategory_of_spans
	+ V H \<a> \<i> src trg \<open>(Maps.REP R\<^sub>0)\<^sup>*\<close> \<open>Maps.REP S\<^sub>1\<close>
	+ proof
	+ show "ide (Maps.REP S\<^sub>1)"
	+ using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
	+ by (meson Maps.REP_in_hhom(2) S\<^sub>1_in_hom)
	+ show "ide (Maps.REP R\<^sub>0)\<^sup>*"
	+ using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
	+ Maps.REP_in_hhom(2) R\<^sub>0_in_hom by auto
	+ show "src (Maps.REP R\<^sub>0)\<^sup>* = trg (Maps.REP S\<^sub>1)"
	+ using Maps.REP_in_hhom(2) R\<^sub>0_in_hom composable by auto
	+ qed
	+
	+ interpretation R\<^sub>0'S\<^sub>1: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s\<close>
	+ by (unfold_locales, simp add: composable)
	+
	+ lemma prj_tab_agreement:
	+ shows "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<cong> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1"
	+ and "\<rho>\<sigma>.p\<^sub>0 \<cong> prj\<^sub>0 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)"
	+ and "\<rho>\<sigma>.p\<^sub>1 \<cong> prj\<^sub>1 (Maps.REP S\<^sub>1) (Maps.REP R\<^sub>0)"
	+ proof -
	+ show 1: "(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s \<cong> (Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1"
	+ proof -
	+ have "(tab\<^sub>0 r)\<^sup>* \<cong> (Maps.REP R\<^sub>0)\<^sup>*"
	+ using Maps.REP_CLS isomorphic_symmetric R\<^sub>0_def composable r.satisfies_T0
	+ isomorphic_to_left_adjoint_implies_isomorphic_right_adjoint
	+ by fastforce
	+ moreover have "tab\<^sub>1 s \<cong> Maps.REP S\<^sub>1"
	+ by (metis Maps.REP_CLS isomorphic_symmetric S\<^sub>1_def s.leg1_is_map s.leg1_simps(3-4))
	+ moreover have "src (Maps.REP R\<^sub>0)\<^sup>* = trg (tab\<^sub>1 s)"
	+ using composable r.T0.antipar right_adjoint_simps(2) by fastforce
	+ ultimately show ?thesis
	+ using hcomp_isomorphic_ide [of "(tab\<^sub>0 r)\<^sup>" "(Maps.REP R\<^sub>0)\<^sup>" "tab\<^sub>1 s"]
	+ hcomp_ide_isomorphic isomorphic_transitive composable
	+ by auto
	+ qed
	+ show "\<rho>\<sigma>.p\<^sub>0 \<cong> tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
	+ using 1 R\<^sub>0'S\<^sub>1.isomorphic_implies_same_tab isomorphic_reflexive by auto
	+ show "\<rho>\<sigma>.p\<^sub>1 \<cong> tab\<^sub>1 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)"
	+ using 1 R\<^sub>0'S\<^sub>1.isomorphic_implies_same_tab isomorphic_reflexive by auto
	+ qed
	+
	+ lemma chine_hcomp_SPN_SPN:
	+ shows "Span.chine_hcomp (SPN r) (SPN s) = Maps.MkIde (src \<rho>\<sigma>.p\<^sub>0)"
	+ proof -
	+ have "Span.chine_hcomp (SPN r) (SPN s) =
	+ Maps.MkIde (src (tab\<^sub>0 ((Maps.REP R\<^sub>0)\<^sup>* \<star> Maps.REP S\<^sub>1)))"
	+ using Span.chine_hcomp_ide_ide [of "SPN r" "SPN s"] composable
	+ Maps.pbdom_def Maps.PRJ\<^sub>0_def Maps.CLS_in_hom Maps.dom_char R\<^sub>0_def S\<^sub>1_def
	+ apply simp
	+ using Maps.prj0_simps(1) RS_simps(1) RS_simps(16) RS_simps(18) RS_simps(3)
	+ by presburger
	+ also have "... = Maps.MkIde (src \<rho>\<sigma>.p\<^sub>0)"
	+ using prj_tab_agreement isomorphic_implies_hpar(3) by force
	+ finally show ?thesis by simp
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ The development above focused on two specific composable 1-cells in bicategory \<open>B\<close>.
	+ Here we reformulate those results as statements about the entire bicategory.
	+ \<close>
	+
	+ context bicategory_of_spans
	+ begin
	+
	+ interpretation Maps: maps_category V H \<a> \<i> src trg ..
	+ interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
	+
	+ no_notation Fun.comp (infixl "\<circ>" 55)
	+ notation Span.vcomp (infixr "\<bullet>" 55)
	+ notation Span.hcomp (infixr "\<circ>" 53)
	+ notation Maps.comp (infixr "\<odot>" 55)
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ interpretation SPN: "functor" V Span.vcomp SPN
	+ using SPN_is_functor by simp
	+ interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
	+ using SPN_is_weak_arrow_of_homs by simp
	+
	+ interpretation SPN_SPN: "functor" VV.comp Span.VV.comp SPN.FF
	+ using SPN.functor_FF by auto
	+ interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
	+ SPN.FF \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<circ> snd \<mu>\<nu>\<close>
	+ ..
	+ interpretation SPNoH: composite_functor VV.comp V
	+ Span.vcomp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
	+ ..
	+
	+ text \<open>
	+ Given arbitrary composable 1-cells \<open>r\<close> and \<open>s\<close>, obtain an arrow of spans in \<open>Maps\<close>
	+ having the isomorphism class of \<open>rs.cmp\<close> as its chine.
	+ \<close>
	+
	+ definition CMP
	+ where "CMP r s \<equiv>
	+ \<lparr>Chn = \<lbrakk>\<lbrakk>two_composable_identities_in_bicategory_of_spans.cmp V H \<a> \<i> src trg r s\<rbrakk>\<rbrakk>,
	+ Dom = Dom (SPN r \<circ> SPN s), Cod = Dom (SPN (r \<star> s))\<rparr>"
	+
	+ lemma compositor_in_hom [intro]:
	+ assumes "ide r" and "ide s" and "src r = trg s"
	+ shows "Span.in_hhom (CMP r s) (SPN.map\<^sub>0 (src s)) (SPN.map\<^sub>0 (trg r))"
	+ and "Span.in_hom (CMP r s) (HoSPN_SPN.map (r, s)) (SPNoH.map (r, s))"
	+ proof -
	+ have rs: "VV.ide (r, s)"
	+ using assms VV.ide_char VV.arr_char by simp
	+ interpret rs: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg r s
	+ using rs VV.ide_char VV.arr_char apply unfold_locales by auto
	+(*
	+ interpret rs: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>r \<star> s\<close> \<open>tab_of_ide (r \<star> s)\<close> \<open>tab\<^sub>0 (r \<star> s)\<close> \<open>tab\<^sub>1 (r \<star> s)\<close>
	+ \<open>r \<star> s\<close> \<open>tab_of_ide (r \<star> s)\<close> \<open>tab\<^sub>0 (r \<star> s)\<close> \<open>tab\<^sub>1 (r \<star> s)\<close>
	+ \<open>r \<star> s\<close>
	+ apply unfold_locales by auto
	+*)
	+ interpret cmp: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>r \<star> s\<close> rs.\<rho>\<sigma>.tab \<open>tab\<^sub>0 s \<star> rs.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 r \<star> rs.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>r \<star> s\<close> rs.tab \<open>tab\<^sub>0 (r \<star> s)\<close> \<open>tab\<^sub>1 (r \<star> s)\<close>
	+ \<open>r \<star> s\<close>
	+ by (unfold_locales, auto)
	+ have "rs.cmp = cmp.chine"
	+ using rs.cmp_def by simp
	+
	+ interpret SPN_r_SPN_s: arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
	+ using rs.composable Span.ide_char [of "SPN r \<circ> SPN s"] by simp
	+ interpret SPN_r_SPN_s: identity_arrow_of_spans Maps.comp \<open>SPN r \<circ> SPN s\<close>
	+ using rs.composable Span.ide_char [of "SPN r \<circ> SPN s"]
	+ by (unfold_locales, simp)
	+ interpret SPN_rs: arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
	+ using Span.arr_char rs.is_ide SPN.preserves_arr by blast
	+ interpret SPN_rs: identity_arrow_of_spans Maps.comp \<open>SPN (r \<star> s)\<close>
	+ using Span.ide_char rs.is_ide SPN.preserves_ide
	+ by (unfold_locales, simp)
	+
	+ interpret Dom: span_in_category Maps.comp \<open>Dom (CMP r s)\<close>
	+ by (unfold_locales, simp add: CMP_def)
	+ interpret Cod: span_in_category Maps.comp \<open>Cod (CMP r s)\<close>
	+ proof -
	+ (* TODO: I don't understand what makes this so difficult. *)
	+ have "\<guillemotleft>tab\<^sub>0 (r \<star> s) : src (tab\<^sub>0 (r \<star> s)) \<rightarrow> src s\<guillemotright> \<and> is_left_adjoint (tab\<^sub>0 (r \<star> s)) \<and>
	+ \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> = \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk>"
	+ by simp
	+ hence "\<exists>f. \<guillemotleft>f : src (tab\<^sub>0 (r \<star> s)) \<rightarrow> src s\<guillemotright> \<and> is_left_adjoint f \<and> \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> = \<lbrakk>f\<rbrakk>"
	+ by blast
	+ moreover have "\<exists>f. \<guillemotleft>f : src (tab\<^sub>0 (r \<star> s)) \<rightarrow> trg r\<guillemotright> \<and> is_left_adjoint f \<and>
	+ \<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk> = \<lbrakk>f\<rbrakk>"
	+ by (metis rs.base_simps(2) rs.leg1_in_hom(1) rs.leg1_is_map trg_hcomp')
	+ ultimately show "span_in_category Maps.comp (Cod (CMP r s))"
	+ using assms Maps.arr_char Maps.dom_char CMP_def
	+ by (unfold_locales, auto)
	+ qed
	+
	+ interpret r\<^sub>0's\<^sub>1: two_composable_identities_in_bicategory_of_spans
	+ V H \<a> \<i> src trg \<open>(Maps.REP rs.R\<^sub>0)\<^sup>*\<close> \<open>Maps.REP rs.S\<^sub>1\<close>
	+ proof
	+ show "ide (Maps.REP rs.S\<^sub>1)"
	+ using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
	+ by (meson Maps.REP_in_hhom(2) rs.S\<^sub>1_in_hom)
	+ show "ide (Maps.REP rs.R\<^sub>0)\<^sup>*"
	+ using Maps.REP_in_Map Maps.arr_char left_adjoint_is_ide
	+ Maps.REP_in_hhom(2) rs.R\<^sub>0_in_hom by auto
	+ show "src (Maps.REP rs.R\<^sub>0)\<^sup>* = trg (Maps.REP rs.S\<^sub>1)"
	+ using Maps.REP_in_hhom(2) rs.R\<^sub>0_in_hom rs.composable by auto
	+ qed
	+
	+ interpret R\<^sub>0'S\<^sub>1: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(tab\<^sub>0 r)\<^sup>* \<star> tab\<^sub>1 s\<close>
	+ by (unfold_locales, simp add: rs.composable)
	+
	+ text \<open>
	+ Here we obtain explicit formulas for the legs and apex of \<open>SPN_r_SPN_s\<close> and \<open>SPN_rs\<close>.
	+ \<close>
	+
	+ have SPN_r_SPN_s_leg0_eq:
	+ "SPN_r_SPN_s.leg0 = Maps.comp rs.S\<^sub>0 (Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1)"
	+ using rs.composable Span.hcomp_def rs.S\<^sub>0_def rs.R\<^sub>0_def rs.S\<^sub>1_def by simp
	+ have SPN_r_SPN_s_leg1_eq:
	+ "SPN_r_SPN_s.leg1 = Maps.comp rs.R\<^sub>1 (Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1)"
	+ using rs.composable Span.hcomp_def rs.R\<^sub>1_def rs.R\<^sub>0_def rs.S\<^sub>1_def by simp
	+ have "SPN_r_SPN_s.apex = Maps.MkIde (src rs.\<rho>\<sigma>.tab)"
	+ using rs.SPN_r_SPN_s_apex_eq by auto
	+
	+ have SPN_rs_leg0_eq: "SPN_rs.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk>\<rbrakk>"
	+ unfolding SPN_def using rs by simp
	+ have SPN_rs_leg1_eq: "SPN_rs.leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk>\<rbrakk>"
	+ unfolding SPN_def using rs by simp
	+ have "SPN_rs.apex = Maps.MkIde (src (tab_of_ide (r \<star> s)))"
	+ using SPN_rs.dom.apex_def Maps.dom_char SPN_rs_leg0_eq SPN_rs.dom.leg_simps(1)
	+ by simp
	+
	+ text \<open>
	+ The composition isomorphism @{term "CMP r s"} is an arrow of spans in \<open>Maps(B)\<close>.
	+ \<close>
	+
	+ interpret arrow_of_spans Maps.comp \<open>CMP r s\<close>
	+ proof
	+ show 1: "Maps.in_hom (Chn (CMP r s)) Dom.apex Cod.apex"
	+ using rs.iso_class_cmp_in_hom rs.composable CMP_def by simp
	+ show "Cod.leg0 \<odot> Chn (CMP r s) = Dom.leg0"
	+ proof (intro Maps.arr_eqI)
	+ show 2: "Maps.seq Cod.leg0 (Chn (CMP r s))"
	+ using 1 Maps.dom_char Maps.cod_char by blast
	+ show 3: "Maps.arr Dom.leg0" by simp
	+ show "Maps.Dom (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Dom Dom.leg0"
	+ using 1 2 Maps.dom_char Maps.cod_char Maps.comp_char
	+ Dom.leg_in_hom Maps.in_hom_char Maps.seq_char
	+ by auto
	+ show "Maps.Cod (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Cod Dom.leg0"
	+ using 2 3 Maps.comp_char [of Cod.leg0 "Chn (CMP r s)"]
	+ Dom.leg_simps Dom.apex_def Maps.dom_char SPN_r_SPN_s_leg0_eq
	+ Maps.comp_char [of rs.S\<^sub>0 "Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1"] CMP_def
	+ by simp
	+ show "Maps.Map (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Map Dom.leg0"
	+ proof -
	+ have "Maps.Map (Cod.leg0 \<odot> Chn (CMP r s)) = Maps.Comp \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk>"
	+ using 1 2 Maps.dom_char Maps.cod_char
	+ Maps.comp_char [of Cod.leg0 "Chn (CMP r s)"] CMP_def
	+ by simp
	+ also have "... = Maps.Comp \<lbrakk>tab\<^sub>0 s\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>0\<rbrakk>"
	+ proof -
	+ have "Maps.Comp \<lbrakk>tab\<^sub>0 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk> = \<lbrakk>tab\<^sub>0 (r \<star> s) \<star> rs.cmp\<rbrakk>"
	+ using Maps.Comp_eq_iso_class_memb Maps.CLS_hcomp cmp.is_map rs.cmp_def
	+ by auto
	+ also have "... = Maps.Comp \<lbrakk>tab\<^sub>0 s\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>0\<rbrakk>"
	+ using Maps.Comp_eq_iso_class_memb Maps.CLS_hcomp iso_class_eqI rs.cmp_props(4)
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = Maps.Map Dom.leg0"
	+ proof -
	+ have "Maps.seq rs.S\<^sub>0 (Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1)"
	+ by (intro Maps.seqI, simp_all add: rs.composable)
	+ moreover have "\<lbrakk>prj\<^sub>0 (Maps.REP rs.S\<^sub>1) (Maps.REP rs.R\<^sub>0)\<rbrakk> = \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>0\<rbrakk>"
	+ using "rs.prj_tab_agreement" iso_class_eqI by auto
	+ moreover have "Maps.Dom (Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1) = src rs.\<rho>\<sigma>.p\<^sub>0"
	+ using rs.prj_tab_agreement Maps.PRJ\<^sub>0_def rs.composable
	+ isomorphic_implies_hpar(3)
	+ by auto
	+ ultimately show ?thesis
	+ using SPN_r_SPN_s_leg0_eq Maps.comp_char [of rs.S\<^sub>0 "Maps.PRJ\<^sub>0 rs.R\<^sub>0 rs.S\<^sub>1"]
	+ rs.S\<^sub>0_def Maps.PRJ\<^sub>0_def rs.composable CMP_def
	+ by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ show "Cod.leg1 \<odot> Chn (CMP r s) = Dom.leg1"
	+ proof (intro Maps.arr_eqI)
	+ show 2: "Maps.seq Cod.leg1 (Chn (CMP r s))"
	+ using 1 Maps.dom_char Maps.cod_char by blast
	+ show 3: "Maps.arr Dom.leg1" by simp
	+ show "Maps.Dom (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Dom Dom.leg1"
	+ using 1 2 Maps.dom_char Maps.cod_char Maps.comp_char
	+ Dom.leg_in_hom Maps.in_hom_char Maps.seq_char
	+ by auto
	+ show "Maps.Cod (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Cod Dom.leg1"
	+ using 2 3 Maps.comp_char [of Cod.leg1 "Chn (CMP r s)"]
	+ Dom.apex_def Maps.dom_char SPN_r_SPN_s_leg1_eq
	+ Maps.comp_char [of rs.R\<^sub>1 "Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1"] CMP_def
	+ by simp
	+ show "Maps.Map (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Map Dom.leg1"
	+ proof -
	+ have "Maps.Map (Cod.leg1 \<odot> Chn (CMP r s)) = Maps.Comp \<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk>"
	+ using 1 2 Maps.dom_char Maps.cod_char
	+ Maps.comp_char [of Cod.leg1 "Chn (CMP r s)"] CMP_def
	+ by simp
	+ also have "... = Maps.Comp \<lbrakk>tab\<^sub>1 r\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>1\<rbrakk>"
	+ proof -
	+ have "Maps.Comp \<lbrakk>tab\<^sub>1 (r \<star> s)\<rbrakk> \<lbrakk>rs.cmp\<rbrakk> = \<lbrakk>tab\<^sub>1 (r \<star> s) \<star> rs.cmp\<rbrakk>"
	+ using Maps.Comp_eq_iso_class_memb Maps.CLS_hcomp cmp.is_map rs.cmp_def
	+ by auto
	+ also have "... = Maps.Comp \<lbrakk>tab\<^sub>1 r\<rbrakk> \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>1\<rbrakk>"
	+ using Maps.Comp_eq_iso_class_memb
	+ Maps.CLS_hcomp [of "tab\<^sub>1 r" rs.\<rho>\<sigma>.p\<^sub>1] iso_class_eqI rs.cmp_props(5)
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = Maps.Map Dom.leg1"
	+ proof -
	+ have "Maps.seq rs.R\<^sub>1 (Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1)"
	+ by (intro Maps.seqI, simp_all add: rs.composable)
	+ moreover have "\<lbrakk>prj\<^sub>1 (Maps.REP rs.S\<^sub>1) (Maps.REP rs.R\<^sub>0)\<rbrakk> = \<lbrakk>rs.\<rho>\<sigma>.p\<^sub>1\<rbrakk>"
	+ using rs.prj_tab_agreement iso_class_eqI by auto
	+ moreover have "Maps.Dom (Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1) = src rs.\<rho>\<sigma>.p\<^sub>1"
	+ using rs.prj_tab_agreement Maps.PRJ\<^sub>1_def rs.composable
	+ isomorphic_implies_hpar(3)
	+ by auto
	+ ultimately show ?thesis
	+ using SPN_r_SPN_s_leg1_eq Maps.comp_char [of rs.R\<^sub>1 "Maps.PRJ\<^sub>1 rs.R\<^sub>0 rs.S\<^sub>1"]
	+ rs.R\<^sub>1_def Maps.PRJ\<^sub>1_def rs.composable CMP_def
	+ by simp
	+ qed
	+ finally show ?thesis by simp
	+ (*
	+ * Very simple, right? Yeah, once you sort through the notational morass and
	+ * figure out what equals what.
	+ *)
	+ qed
	+ qed
	+ qed
	+ show "Span.in_hom (CMP r s) (HoSPN_SPN.map (r, s)) (SPNoH.map (r, s))"
	+ using Span.arr_char arrow_of_spans_axioms Span.dom_char Span.cod_char
	+ CMP_def SPN.FF_def VV.arr_char rs.composable
	+ by auto
	+ thus "Span.in_hhom (CMP r s) (SPN.map\<^sub>0 (src s)) (SPN.map\<^sub>0 (trg r))"
	+ using assms VV.ide_char VV.arr_char VV.in_hom_char SPN.FF_def
	+ Span.src_dom [of "CMP r s"] Span.trg_dom [of "CMP r s"]
	+ by fastforce
	+ qed
	+
	+ lemma compositor_simps [simp]:
	+ assumes "ide r" and "ide s" and "src r = trg s"
	+ shows "Span.arr (CMP r s)"
	+ and "Span.src (CMP r s) = SPN.map\<^sub>0 (src s)" and "Span.trg (CMP r s) = SPN.map\<^sub>0 (trg r)"
	+ and "Span.dom (CMP r s) = HoSPN_SPN.map (r, s)"
	+ and "Span.cod (CMP r s) = SPNoH.map (r, s)"
	+ using assms compositor_in_hom [of r s] by auto
	+
	+ lemma compositor_is_iso:
	+ assumes "ide r" and "ide s" and "src r = trg s"
	+ shows "Span.iso (CMP r s)"
	+ proof -
	+ interpret rs: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg r s
	+ using assms by (unfold_locales, auto)
	+ have "Span.arr (CMP r s)"
	+ using assms compositor_in_hom by blast
	+ moreover have "Maps.iso \<lbrakk>\<lbrakk>rs.cmp\<rbrakk>\<rbrakk>"
	+ using assms Maps.iso_char'
	+ by (metis (mono_tags, lifting) Maps.CLS_in_hom Maps.Map.simps(1) Maps.in_homE
	+ equivalence_is_left_adjoint ide_in_iso_class rs.cmp_props(3) rs.cmp_simps(2))
	+ ultimately show ?thesis
	+ unfolding CMP_def
	+ using assms Span.iso_char by simp
	+ qed
	+
	+ interpretation \<Xi>: transformation_by_components VV.comp Span.vcomp
	+ HoSPN_SPN.map SPNoH.map \<open>\<lambda>rs. CMP (fst rs) (snd rs)\<close>
	+ proof
	+ fix rs
	+ assume rs: "VV.ide rs"
	+ let ?r = "fst rs"
	+ let ?s = "snd rs"
	+ show "Span.in_hom (CMP ?r ?s) (HoSPN_SPN.map rs) (SPNoH.map rs)"
	+ using rs compositor_in_hom [of ?r ?s] VV.ide_char VV.arr_char by simp
	+ next
	+ fix \<mu>\<nu>
	+ assume \<mu>\<nu>: "VV.arr \<mu>\<nu>"
	+ let ?\<mu> = "fst \<mu>\<nu>"
	+ let ?\<nu> = "snd \<mu>\<nu>"
	+ show "CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)) \<bullet> HoSPN_SPN.map \<mu>\<nu> =
	+ SPNoH.map \<mu>\<nu> \<bullet> CMP (fst (VV.dom \<mu>\<nu>)) (snd (VV.dom \<mu>\<nu>))"
	+ proof -
	+ let ?LHS = "CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)) \<bullet> HoSPN_SPN.map \<mu>\<nu>"
	+ let ?RHS = "SPNoH.map \<mu>\<nu> \<bullet> CMP (fst (VV.dom \<mu>\<nu>)) (snd (VV.dom \<mu>\<nu>))"
	+ have LHS:
	+ "Span.in_hom ?LHS (HoSPN_SPN.map (VV.dom \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
	+ proof
	+ show "Span.in_hom (HoSPN_SPN.map \<mu>\<nu>) (HoSPN_SPN.map (VV.dom \<mu>\<nu>))
	+ (HoSPN_SPN.map (VV.cod \<mu>\<nu>))"
	+ using \<mu>\<nu> by blast
	+ show "Span.in_hom (CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>)))
	+ (HoSPN_SPN.map (VV.cod \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
	+ using \<mu>\<nu> by (auto simp add: VV.arr_char)
	+ qed
	+ have RHS:
	+ "Span.in_hom ?RHS (HoSPN_SPN.map (VV.dom \<mu>\<nu>)) (SPNoH.map (VV.cod \<mu>\<nu>))"
	+ using \<mu>\<nu> by (auto simp add: VV.arr_char)
	+ show "?LHS = ?RHS"
	+ proof (intro Span.arr_eqI)
	+ show "Span.par ?LHS ?RHS"
	+ apply (intro conjI)
	+ using LHS RHS apply auto[2]
	+ proof -
	+ show "Span.dom ?LHS = Span.dom ?RHS"
	+ proof -
	+ have "Span.dom ?LHS = HoSPN_SPN.map (VV.dom \<mu>\<nu>)"
	+ using LHS by auto
	+ also have "... = Span.dom ?RHS"
	+ using RHS by auto
	+ finally show ?thesis by simp
	+ qed
	+ show "Span.cod ?LHS = Span.cod ?RHS"
	+ proof -
	+ have "Span.cod ?LHS = SPNoH.map (VV.cod \<mu>\<nu>)"
	+ using LHS by auto
	+ also have "... = Span.cod ?RHS"
	+ using RHS by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ show "Chn ?LHS = Chn ?RHS"
	+ proof -
	+ interpret dom_\<mu>_\<nu>: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
	+ \<open>dom ?\<mu>\<close> \<open>dom ?\<nu>\<close>
	+ using \<mu>\<nu> VV.ide_char VV.arr_char by (unfold_locales, auto)
	+ interpret cod_\<mu>_\<nu>: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
	+ \<open>cod ?\<mu>\<close> \<open>cod ?\<nu>\<close>
	+ using \<mu>\<nu> VV.ide_char VV.arr_char by (unfold_locales, auto)
	+ interpret \<mu>_\<nu>: horizontal_composite_of_arrows_of_tabulations_in_maps
	+ V H \<a> \<i> src trg
	+ \<open>dom ?\<mu>\<close> \<open>tab_of_ide (dom ?\<mu>)\<close> \<open>tab\<^sub>0 (dom ?\<mu>)\<close> \<open>tab\<^sub>1 (dom ?\<mu>)\<close>
	+ \<open>dom ?\<nu>\<close> \<open>tab_of_ide (dom ?\<nu>)\<close> \<open>tab\<^sub>0 (dom ?\<nu>)\<close> \<open>tab\<^sub>1 (dom ?\<nu>)\<close>
	+ \<open>cod ?\<mu>\<close> \<open>tab_of_ide (cod ?\<mu>)\<close> \<open>tab\<^sub>0 (cod ?\<mu>)\<close> \<open>tab\<^sub>1 (cod ?\<mu>)\<close>
	+ \<open>cod ?\<nu>\<close> \<open>tab_of_ide (cod ?\<nu>)\<close> \<open>tab\<^sub>0 (cod ?\<nu>)\<close> \<open>tab\<^sub>1 (cod ?\<nu>)\<close>
	+ ?\<mu> ?\<nu>
	+ using \<mu>\<nu> VV.arr_char by (unfold_locales, auto)
	+
	+ let ?\<mu>\<nu> = "?\<mu> \<star> ?\<nu>"
	+ interpret dom_\<mu>\<nu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom ?\<mu>\<nu>\<close>
	+ using \<mu>\<nu> by (unfold_locales, simp)
	+ interpret cod_\<mu>\<nu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>cod ?\<mu>\<nu>\<close>
	+ using \<mu>\<nu> by (unfold_locales, simp)
	+ interpret \<mu>\<nu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom ?\<mu>\<nu>\<close> \<open>tab_of_ide (dom ?\<mu>\<nu>)\<close> \<open>tab\<^sub>0 (dom ?\<mu>\<nu>)\<close> \<open>tab\<^sub>1 (dom ?\<mu>\<nu>)\<close>
	+ \<open>cod ?\<mu>\<nu>\<close> \<open>tab_of_ide (cod ?\<mu>\<nu>)\<close> \<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close> \<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
	+ ?\<mu>\<nu>
	+ using \<mu>\<nu> by (unfold_locales, auto)
	+
	+ have Chn_LHS_eq:
	+ "Chn ?LHS = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot> Span.chine_hcomp (SPN (fst \<mu>\<nu>)) (SPN (snd \<mu>\<nu>))"
	+ proof -
	+ have "Chn ?LHS = Chn (CMP (fst (VV.cod \<mu>\<nu>)) (snd (VV.cod \<mu>\<nu>))) \<odot>
	+ Chn (HoSPN_SPN.map \<mu>\<nu>)"
	+ using \<mu>\<nu> LHS Span.Chn_vcomp by blast
	+ also have "... = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot> Chn (HoSPN_SPN.map \<mu>\<nu>)"
	+ using \<mu>\<nu> VV.arr_char VV.cod_char CMP_def by simp
	+ also have "... = \<lbrakk>\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>\<rbrakk> \<odot>
	+ Span.chine_hcomp (SPN (fst \<mu>\<nu>)) (SPN (snd \<mu>\<nu>))"
	+ using \<mu>\<nu> VV.arr_char SPN.FF_def Span.hcomp_def by simp
	+ finally show ?thesis by blast
	+ qed
	+ have Chn_RHS_eq:
	+ "Chn ?RHS = MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>))) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
	+ \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<odot>
	+ MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
	+ \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
	+ proof -
	+ have "Chn ?RHS = Chn (SPN (?\<mu> \<star> ?\<nu>)) \<odot>
	+ MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
	+ \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
	+ using \<mu>\<nu> RHS Span.vcomp_def VV.arr_char CMP_def Span.arr_char Span.not_arr_Null
	+ by auto
	+ moreover have "Chn (SPN (?\<mu> \<star> ?\<nu>)) =
	+ MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
	+ (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
	+ \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
	+ proof -
	+ have "Chn (SPN (?\<mu> \<star> ?\<nu>)) =
	+ MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
	+ (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
	+ \<lbrakk>spn ?\<mu>\<nu>\<rbrakk>"
	+ using \<mu>\<nu> SPN_def by simp
	+ also have "... = MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
	+ (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
	+ \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
	+ using spn_def by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+
	+ let ?Chn_LHS =
	+ "MkArr (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)))
	+ \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<odot>
	+ Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)"
	+ let ?Chn_RHS =
	+ "MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>))) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
	+ \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<odot>
	+ MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
	+ \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
	+
	+ have "?Chn_LHS = ?Chn_RHS"
	+ proof (intro Maps.arr_eqI)
	+ interpret LHS: arrow_of_spans Maps.comp ?LHS
	+ using LHS Span.arr_char by auto
	+ interpret RHS: arrow_of_spans Maps.comp ?RHS
	+ using RHS Span.arr_char by auto
	+ show 1: "Maps.arr ?Chn_LHS"
	+ using LHS.chine_in_hom Chn_LHS_eq by auto
	+ show 2: "Maps.arr ?Chn_RHS"
	+ using RHS.chine_in_hom Chn_RHS_eq by auto
	+ text \<open>
	+ Here is where we use \<open>dom_\<mu>_\<nu>.chine_hcomp_SPN_SPN\<close>,
	+ which depends on our having chosen the ``right'' pullbacks for \<open>Maps(B)\<close>.
	+ The map \<open>Chn_LHS\<close> has as its domain the apex of the
	+ horizontal composite of the components of @{term "VV.dom \<mu>\<nu>"},
	+ whereas \<open>Chn_RHS\<close> has as its
	+ domain the apex of the chosen tabulation of \<open>r\<^sub>0\<^sup>* \<star> s\<^sub>1\<close>.
	+ We need these to be equal in order for \<open>Chn_LHS\<close> and \<open>Chn_RHS\<close> to be equal.
	+ \<close>
	+ show "Maps.Dom ?Chn_LHS = Maps.Dom ?Chn_RHS"
	+ proof -
	+ have 3: "Maps.Dom ?Chn_LHS = Maps.Dom (Maps.dom ?Chn_LHS)"
	+ using \<mu>\<nu> 1 Maps.Dom_dom by presburger
	+ also have
	+ "... = Maps.Dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>)))"
	+ proof -
	+ have "... = Maps.Dom (Maps.dom (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)))"
	+ using 1 Maps.seq_char Maps.Dom_comp by auto
	+ also have "... = Maps.Dom (Maps.pbdom (Leg0 (Dom (SPN ?\<mu>)))
	+ (Leg1 (Dom (SPN ?\<nu>))))"
	+ using \<mu>\<nu> VV.arr_char Span.chine_hcomp_in_hom [of "SPN ?\<nu>" "SPN ?\<mu>"]
	+ by auto
	+ also have "... = Maps.Dom (Maps.dom (Maps.pbdom (Leg0 (Dom (SPN ?\<mu>)))
	+ (Leg1 (Dom (SPN ?\<nu>)))))"
	+ proof -
	+ have "Maps.cospan (Leg0 (Dom (SPN (fst \<mu>\<nu>)))) (Leg1 (Dom (SPN (snd \<mu>\<nu>))))"
	+ using \<mu>\<nu> VV.arr_char SPN_in_hom Span.arr_char Span.dom_char SPN_def
	+ Maps.CLS_in_hom Maps.arr_char Maps.cod_char dom_\<mu>_\<nu>.composable
	+ dom_\<mu>_\<nu>.RS_simps(16) dom_\<mu>_\<nu>.S\<^sub>1_def dom_\<mu>_\<nu>.RS_simps(1)
	+ dom_\<mu>_\<nu>.R\<^sub>0_def Maps.pbdom_in_hom
	+ by simp
	+ thus ?thesis
	+ using \<mu>\<nu> VV.arr_char Maps.pbdom_in_hom by simp
	+ qed
	+ also have "... = Maps.Dom
	+ (Maps.dom (Maps.pbdom (Leg0 (Dom (SPN (dom ?\<mu>))))
	+ (Leg1 (Dom (SPN (dom ?\<nu>))))))"
	+ using \<mu>\<nu> SPN_def VV.arr_char by simp
	+ also have "... = Maps.Dom
	+ (Maps.dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>))))"
	+ using \<mu>\<nu> VV.arr_char ide_dom
	+ by (simp add: Span.chine_hcomp_ide_ide)
	+ also have "... = Maps.Dom (Span.chine_hcomp (SPN (dom ?\<mu>)) (SPN (dom ?\<nu>)))"
	+ using Maps.Dom_dom Maps.in_homE SPN.preserves_reflects_arr SPN.preserves_src
	+ SPN.preserves_trg Span.chine_hcomp_in_hom dom_\<mu>_\<nu>.composable
	+ dom_\<mu>_\<nu>.r.base_simps(2) dom_\<mu>_\<nu>.s.base_simps(2)
	+ by (metis (no_types, lifting))
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"
	+ using "dom_\<mu>_\<nu>.chine_hcomp_SPN_SPN" by simp
	+ also have "... = Maps.Dom ?Chn_RHS"
	+ using 2 Maps.seq_char Maps.Dom_comp by auto
	+ finally show ?thesis by simp
	+ qed
	+ show "Maps.Cod ?Chn_LHS = Maps.Cod ?Chn_RHS"
	+ proof -
	+ have "Maps.Cod ?Chn_LHS = src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>))"
	+ using \<mu>\<nu> 1 VV.arr_char Maps.seq_char by auto
	+ also have "... = src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>))"
	+ using \<mu>\<nu> VV.arr_char cod_\<mu>\<nu>.tab_simps(2) by auto
	+ also have "... = Maps.Cod ?Chn_RHS"
	+ by (metis (no_types, lifting) "2" Maps.Cod.simps(1) Maps.Cod_comp Maps.seq_char)
	+ finally show ?thesis by simp
	+ qed
	+ show "Maps.Map ?Chn_LHS = Maps.Map ?Chn_RHS"
	+ proof -
	+ have RHS: "Maps.Map ?Chn_RHS = iso_class (\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp)"
	+ proof -
	+ have "Maps.Map ?Chn_RHS = Maps.Comp \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
	+ using \<mu>\<nu> 2 VV.arr_char Maps.Map_comp
	+ Maps.comp_char
	+ [of "MkArr (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
	+ (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))
	+ \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
	+ "MkArr (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)
	+ (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))
	+ \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"]
	+ by simp
	+ also have "... = \<lbrakk>\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp\<rbrakk>"
	+ proof -
	+ have "\<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk> \<in>
	+ Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))"
	+ proof -
	+ have "\<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk> \<in>
	+ Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.tab) (src (tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)))"
	+ using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.cmp_props(1-3)
	+ by (metis (mono_tags, lifting) equivalence_is_left_adjoint mem_Collect_eq)
	+ thus ?thesis
	+ using \<mu>\<nu> VV.arr_char dom_\<mu>\<nu>.tab_simps(2) by simp
	+ qed
	+ moreover have "\<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<in>
	+ Maps.Hom (src (tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)))
	+ (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))"
	+ using \<mu>\<nu> VV.arr_char \<mu>\<nu>.chine_in_hom \<mu>\<nu>.is_map by auto
	+ moreover have
	+ "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<in> Maps.Comp \<lbrakk>\<mu>\<nu>.chine\<rbrakk> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
	+ proof
	+ show "is_iso_class \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
	+ using is_iso_classI by simp
	+ show "is_iso_class \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
	+ using is_iso_classI by simp
	+ show "dom_\<mu>_\<nu>.cmp \<in> \<lbrakk>dom_\<mu>_\<nu>.cmp\<rbrakk>"
	+ using ide_in_iso_class [of dom_\<mu>_\<nu>.cmp] by simp
	+ show "\<mu>\<nu>.chine \<in> \<lbrakk>\<mu>\<nu>.chine\<rbrakk>"
	+ using ide_in_iso_class by simp
	+ show "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> \<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp"
	+ using \<mu>\<nu> VV.arr_char \<mu>\<nu>.chine_simps dom_\<mu>_\<nu>.cmp_simps dom_\<mu>\<nu>.tab_simps(2)
	+ isomorphic_reflexive
	+ by auto
	+ qed
	+ ultimately show ?thesis
	+ using \<mu>\<nu> dom_\<mu>_\<nu>.cmp_props \<mu>\<nu>.chine_in_hom \<mu>\<nu>.chine_is_induced_map
	+ Maps.Comp_eq_iso_class_memb
	+ by blast
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ have LHS: "Maps.Map ?Chn_LHS = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
	+ proof -
	+ have "Maps.Map ?Chn_LHS =
	+ Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>
	+ (Maps.Map
	+ (Maps.tuple (Maps.CLS (spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1))
	+ (Maps.CLS (tab\<^sub>0 (cod ?\<mu>)))
	+ (Maps.CLS (tab\<^sub>1 (cod ?\<nu>)))
	+ (Maps.CLS (spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0))))"
	+ proof -
	+ have "Maps.Map ?Chn_LHS =
	+ Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>
	+ (Maps.Map (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)))"
	+ using \<mu>\<nu> 1 VV.arr_char Maps.Map_comp cod_\<mu>\<nu>.tab_simps(2)
	+ Maps.comp_char
	+ [of "MkArr (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)
	+ (src (tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)))
	+ \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
	+ "Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)"]
	+ by simp
	+ moreover have "Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>) =
	+ Maps.tuple
	+ (Maps.CLS (spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1))
	+ (Maps.CLS (tab\<^sub>0 (cod ?\<mu>)))
	+ (Maps.CLS (tab\<^sub>1 (cod ?\<nu>)))
	+ (Maps.CLS (spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0))"
	+ proof -
	+ have "Maps.PRJ\<^sub>0
	+ (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
	+ (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
	+ \<lbrakk>\<lbrakk>dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<and>
	+ Maps.PRJ\<^sub>1
	+ (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
	+ (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
	+ \<lbrakk>\<lbrakk>dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ proof -
	+ interpret X: identity_in_bicategory_of_spans V H \<a> \<i> src trg
	+ \<open>(tab\<^sub>0 (dom ?\<mu>))\<^sup>* \<star> tab\<^sub>1 (dom ?\<nu>)\<close>
	+ using \<mu>\<nu> VV.arr_char
	+ by (unfold_locales, simp)
	+ have "Maps.PRJ\<^sub>0
	+ (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
	+ (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 ((Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
	+ \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
	+ Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
	+ \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>))\<rbrakk>\<rbrakk>"
	+ unfolding Maps.PRJ\<^sub>0_def
	+ using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.RS_simps(1) dom_\<mu>_\<nu>.RS_simps(16)
	+ dom_\<mu>_\<nu>.RS_simps(18) dom_\<mu>_\<nu>.RS_simps(3) dom_\<mu>_\<nu>.R\<^sub>0_def
	+ dom_\<mu>_\<nu>.S\<^sub>1_def
	+ by auto
	+ moreover
	+ have "Maps.PRJ\<^sub>1
	+ (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>)
	+ (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>) \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) =
	+ \<lbrakk>\<lbrakk>tab\<^sub>1 ((Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
	+ \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
	+ Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
	+ \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>))\<rbrakk>\<rbrakk>"
	+ unfolding Maps.PRJ\<^sub>1_def
	+ using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.RS_simps(1) dom_\<mu>_\<nu>.RS_simps(16)
	+ dom_\<mu>_\<nu>.RS_simps(18) dom_\<mu>_\<nu>.RS_simps(3) dom_\<mu>_\<nu>.R\<^sub>0_def
	+ dom_\<mu>_\<nu>.S\<^sub>1_def
	+ by auto
	+ moreover
	+ have "(Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<mu>))) (trg (snd \<mu>\<nu>))
	+ \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk>))\<^sup>* \<star>
	+ Maps.REP (MkArr (src (tab\<^sub>0 (dom ?\<nu>))) (trg ?\<nu>)
	+ \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk>) \<cong>
	+ (tab\<^sub>0 (dom ?\<mu>))\<^sup>* \<star> tab\<^sub>1 (dom ?\<nu>)"
	+ proof -
	+ have "MkArr (src (tab\<^sub>0 (dom (fst \<mu>\<nu>)))) (trg (snd \<mu>\<nu>)) \<lbrakk>tab\<^sub>0 (dom ?\<mu>)\<rbrakk> =
	+ dom_\<mu>_\<nu>.R\<^sub>0"
	+ using VV.arr_char \<mu>\<nu> dom_\<mu>_\<nu>.R\<^sub>0_def by simp
	+ moreover have "MkArr (src (tab\<^sub>0 (dom (snd \<mu>\<nu>)))) (trg (snd \<mu>\<nu>))
	+ \<lbrakk>tab\<^sub>1 (dom ?\<nu>)\<rbrakk> =
	+ dom_\<mu>_\<nu>.S\<^sub>1"
	+ using VV.arr_char \<mu>\<nu> dom_\<mu>_\<nu>.S\<^sub>1_def dom_\<mu>_\<nu>.s.leg1_simps(3)
	+ dom_\<mu>_\<nu>.s.leg1_simps(4) trg_dom
	+ by presburger
	+ ultimately show ?thesis
	+ using dom_\<mu>_\<nu>.prj_tab_agreement(1) isomorphic_symmetric
	+ by presburger
	+ qed
	+ ultimately show ?thesis
	+ using X.isomorphic_implies_same_tab isomorphic_symmetric by metis
	+ qed
	+ thus ?thesis
	+ unfolding Span.chine_hcomp_def
	+ using \<mu>\<nu> VV.arr_char SPN_def isomorphic_reflexive
	+ Maps.comp_CLS [of "spn ?\<mu>" dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1 "spn ?\<mu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1"]
	+ Maps.comp_CLS [of "spn ?\<nu>" dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 "spn ?\<nu> \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"]
	+ by simp
	+ qed
	+ moreover have "Maps.Dom (Span.chine_hcomp (SPN ?\<mu>) (SPN ?\<nu>)) =
	+ src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0"
	+ by (metis (no_types, lifting) "1" "2" Maps.Dom.simps(1) Maps.comp_char
	+ \<open>Maps.Dom ?Chn_LHS = Maps.Dom ?Chn_RHS\<close>)
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
	+ proof -
	+ let ?tuple = "Maps.tuple \<lbrakk>\<lbrakk>spn (fst \<mu>\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 (cod ?\<mu>)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (cod ?\<nu>)\<rbrakk>\<rbrakk>
	+ \<lbrakk>\<lbrakk>spn (snd \<mu>\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ have "iso_class \<mu>_\<nu>.chine = Maps.Map ?tuple"
	+ using \<mu>_\<nu>.CLS_chine spn_def Maps.Map.simps(1)
	+ by (metis (no_types, lifting))
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
	+ proof -
	+ have "\<lbrakk>\<mu>_\<nu>.chine\<rbrakk> \<in> Maps.Hom (src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0)"
	+ proof -
	+ have "\<guillemotleft>\<mu>_\<nu>.chine : src dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 \<rightarrow> src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<guillemotright>"
	+ using \<mu>\<nu> VV.arr_char by simp
	+ thus ?thesis
	+ using \<mu>_\<nu>.is_map ide_in_iso_class left_adjoint_is_ide by blast
	+ qed
	+ moreover have "\<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<in>
	+ Maps.Hom (src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0) (src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)))"
	+ proof -
	+ have "\<guillemotleft>cod_\<mu>_\<nu>.cmp : src cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0 \<rightarrow> src (tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>))\<guillemotright>"
	+ using \<mu>\<nu> VV.arr_char cod_\<mu>_\<nu>.cmp_in_hom cod_\<mu>\<nu>.tab_simps(2)
	+ by simp
	+ thus ?thesis
	+ using cod_\<mu>_\<nu>.cmp_props equivalence_is_left_adjoint left_adjoint_is_ide
	+ ide_in_iso_class [of cod_\<mu>_\<nu>.cmp]
	+ by blast
	+ qed
	+ moreover have
	+ "cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine \<in> Maps.Comp \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk> \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
	+ proof
	+ show "is_iso_class \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
	+ using \<mu>_\<nu>.w_simps(1) is_iso_classI by blast
	+ show "is_iso_class \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
	+ using cod_\<mu>_\<nu>.cmp_simps(2) is_iso_classI by blast
	+ show "\<mu>_\<nu>.chine \<in> \<lbrakk>\<mu>_\<nu>.chine\<rbrakk>"
	+ using ide_in_iso_class by simp
	+ show "cod_\<mu>_\<nu>.cmp \<in> \<lbrakk>cod_\<mu>_\<nu>.cmp\<rbrakk>"
	+ using ide_in_iso_class by simp
	+ show "cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine \<cong> cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine"
	+ by (simp add: isomorphic_reflexive)
	+ qed
	+ ultimately show ?thesis
	+ using \<mu>\<nu> cod_\<mu>_\<nu>.cmp_props \<mu>_\<nu>.chine_in_hom \<mu>_\<nu>.chine_is_induced_map
	+ Maps.Comp_eq_iso_class_memb
	+ by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ have EQ: "\<lbrakk>\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp\<rbrakk> = \<lbrakk>cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine\<rbrakk>"
	+ proof (intro iso_class_eqI)
	+ show "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine"
	+ proof -
	+ interpret dom_cmp: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom ?\<mu>\<nu>\<close>
	+ dom_\<mu>_\<nu>.\<rho>\<sigma>.tab
	+ \<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
	+ \<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>dom ?\<mu>\<nu>\<close>
	+ \<open>tab_of_ide (dom ?\<mu> \<star> dom ?\<nu>)\<close>
	+ \<open>tab\<^sub>0 (dom ?\<mu> \<star> dom ?\<nu>)\<close>
	+ \<open>tab\<^sub>1 (dom ?\<mu> \<star> dom ?\<nu>)\<close>
	+ \<open>dom ?\<mu>\<nu>\<close>
	+ using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.cmp_interpretation by simp
	+ interpret cod_cmp: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>cod ?\<mu>\<nu>\<close>
	+ cod_\<mu>_\<nu>.\<rho>\<sigma>.tab
	+ \<open>tab\<^sub>0 (cod ?\<nu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
	+ \<open>tab\<^sub>1 (cod ?\<mu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>cod ?\<mu>\<nu>\<close>
	+ \<open>tab_of_ide (cod ?\<mu> \<star> cod ?\<nu>)\<close>
	+ \<open>tab\<^sub>0 (cod ?\<mu> \<star> cod ?\<nu>)\<close>
	+ \<open>tab\<^sub>1 (cod ?\<mu> \<star> cod ?\<nu>)\<close>
	+ \<open>cod ?\<mu>\<nu>\<close>
	+ using \<mu>\<nu> VV.arr_char cod_\<mu>_\<nu>.cmp_interpretation by simp
	+ interpret L: vertical_composite_of_arrows_of_tabulations_in_maps
	+ V H \<a> \<i> src trg
	+ \<open>dom ?\<mu>\<nu>\<close>
	+ \<open>dom_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
	+ \<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
	+ \<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>dom ?\<mu>\<nu>\<close>
	+ \<open>tab_of_ide (dom ?\<mu>\<nu>)\<close>
	+ \<open>tab\<^sub>0 (dom ?\<mu>\<nu>)\<close>
	+ \<open>tab\<^sub>1 (dom ?\<mu>\<nu>)\<close>
	+ \<open>cod ?\<mu>\<nu>\<close>
	+ cod_\<mu>\<nu>.tab
	+ \<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close>
	+ \<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
	+ \<open>dom ?\<mu>\<nu>\<close>
	+ \<open>?\<mu> \<star> ?\<nu>\<close>
	+ using \<mu>\<nu> VV.arr_char dom_\<mu>_\<nu>.cmp_in_hom
	+ by (unfold_locales, auto)
	+ interpret R: vertical_composite_of_arrows_of_tabulations_in_maps
	+ V H \<a> \<i> src trg
	+ \<open>dom ?\<mu>\<nu>\<close>
	+ \<open>dom_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
	+ \<open>tab\<^sub>0 (dom ?\<nu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
	+ \<open>tab\<^sub>1 (dom ?\<mu>) \<star> dom_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>cod ?\<mu>\<nu>\<close>
	+ \<open>cod_\<mu>_\<nu>.\<rho>\<sigma>.tab\<close>
	+ \<open>tab\<^sub>0 (cod ?\<nu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>0\<close>
	+ \<open>tab\<^sub>1 (cod ?\<mu>) \<star> cod_\<mu>_\<nu>.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>cod ?\<mu>\<nu>\<close>
	+ cod_\<mu>\<nu>.tab
	+ \<open>tab\<^sub>0 (cod ?\<mu>\<nu>)\<close>
	+ \<open>tab\<^sub>1 (cod ?\<mu>\<nu>)\<close>
	+ \<open>?\<mu> \<star> ?\<nu>\<close>
	+ \<open>cod ?\<mu>\<nu>\<close>
	+ using \<mu>\<nu> VV.arr_char cod_\<mu>_\<nu>.cmp_in_hom
	+ by (unfold_locales, auto)
	+ have "\<mu>\<nu>.chine \<star> dom_\<mu>_\<nu>.cmp \<cong> L.chine"
	+ using \<mu>\<nu> VV.arr_char L.chine_char dom_\<mu>_\<nu>.cmp_def isomorphic_symmetric
	+ by simp
	+ also have "... = R.chine"
	+ using L.is_ide \<mu>\<nu> comp_arr_dom comp_cod_arr isomorphic_reflexive by force
	+ also have "... \<cong> cod_\<mu>_\<nu>.cmp \<star> \<mu>_\<nu>.chine"
	+ using \<mu>\<nu> VV.arr_char R.chine_char cod_\<mu>_\<nu>.cmp_def by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ show ?thesis
	+ using LHS RHS EQ by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using Chn_LHS_eq Chn_RHS_eq by simp
	+ qed
	+ qed
	+ qed
	+ qed
	+
	+ interpretation \<Xi>: natural_isomorphism VV.comp Span.vcomp
	+ HoSPN_SPN.map SPNoH.map \<Xi>.map
	+ using VV.ide_char VV.arr_char \<Xi>.map_simp_ide compositor_is_iso
	+ by (unfold_locales, simp)
	+
	+ lemma compositor_is_natural_transformation:
	+ shows "transformation_by_components VV.comp Span.vcomp HoSPN_SPN.map SPNoH.map
	+ (\<lambda>rs. CMP (fst rs) (snd rs))"
	+ ..
	+
	+ lemma compositor_is_natural_isomorphism:
	+ shows "natural_isomorphism VV.comp Span.vcomp HoSPN_SPN.map SPNoH.map \<Xi>.map"
	+ ..
	+
	+ end
	+
	+ subsubsection "Associativity Coherence"
	+
	+ locale three_composable_identities_in_bicategory_of_spans =
	+ bicategory_of_spans V H \<a> \<i> src trg +
	+ f: identity_in_bicategory_of_spans V H \<a> \<i> src trg f +
	+ g: identity_in_bicategory_of_spans V H \<a> \<i> src trg g +
	+ h: identity_in_bicategory_of_spans V H \<a> \<i> src trg h
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and f :: 'a
	+ and g :: 'a
	+ and h :: 'a +
	+ assumes fg: "src f = trg g"
	+ and gh: "src g = trg h"
	+ begin
	+
	+ interpretation f: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f
	+ using f.is_arrow_of_tabulations_in_maps by simp
	+ interpretation h: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ h h.tab \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close> h h.tab \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close> h
	+ using h.is_arrow_of_tabulations_in_maps by simp
	+
	+ interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ interpretation Maps: maps_category V H \<a> \<i> src trg ..
	+ interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
	+
	+ no_notation Fun.comp (infixl "\<circ>" 55)
	+ notation Span.vcomp (infixr "\<bullet>" 55)
	+ notation Span.hcomp (infixr "\<circ>" 53)
	+ notation Maps.comp (infixr "\<odot>" 55)
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ interpretation SPN: "functor" V Span.vcomp SPN
	+ using SPN_is_functor by simp
	+ interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
	+ using SPN_is_weak_arrow_of_homs by simp
	+ interpretation SPN_SPN: "functor" VV.comp Span.VV.comp SPN.FF
	+ using SPN.functor_FF by auto
	+ interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
	+ SPN.FF \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<circ> snd \<mu>\<nu>\<close>
	+ ..
	+ interpretation SPNoH: composite_functor VV.comp V Span.vcomp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
	+ ..
	+
	+ text \<open>
	+ Here come a lot of interpretations for ``composite things''.
	+ We need these in order to have relatively short, systematic names for entities that will
	+ appear in the lemmas to follow.
	+ The names of the interpretations use a prefix notation, where \<open>H\<close> refers to horizontal
	+ composition of 1-cells and \<open>T\<close> refers to composite of tabulations.
	+ So, for example, \<open>THfgh\<close> refers to the composite of the tabulation associated with the
	+ horizontal composition \<open>f \<star> g\<close> with the tabulation associated with \<open>h\<close>.
	+ \<close>
	+ interpretation HHfgh: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>(f \<star> g) \<star> h\<close>
	+ using fg gh by (unfold_locales, auto)
	+ interpretation HfHgh: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>f \<star> g \<star> h\<close>
	+ using fg gh by (unfold_locales, auto)
	+ interpretation Tfg: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg f g
	+ using fg gh by (unfold_locales, auto)
	+ interpretation Tgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg g h
	+ using fg gh by (unfold_locales, auto)
	+ interpretation THfgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
	+ \<open>f \<star> g\<close> h
	+ using fg gh by (unfold_locales, auto)
	+ interpretation THfgh: tabulation V H \<a> \<i> src trg \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab
	+ \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ using THfgh.\<rho>\<sigma>.composite_is_tabulation by simp
	+ interpretation TfHgh: two_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg
	+ f \<open>g \<star> h\<close>
	+ using fg gh by (unfold_locales, auto)
	+ interpretation TfHgh: tabulation V H \<a> \<i> src trg \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab
	+ \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ using TfHgh.\<rho>\<sigma>.composite_is_tabulation by simp
	+
	+ interpretation Tfg_Hfg: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>f \<star> g\<close> \<open>tab_of_ide (f \<star> g)\<close> \<open>tab\<^sub>0 (f \<star> g)\<close> \<open>tab\<^sub>1 (f \<star> g)\<close>
	+ \<open>f \<star> g\<close>
	+ by (unfold_locales, auto)
	+ interpretation Tgh_Hgh: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>g \<star> h\<close> \<open>tab_of_ide (g \<star> h)\<close> \<open>tab\<^sub>0 (g \<star> h)\<close> \<open>tab\<^sub>1 (g \<star> h)\<close>
	+ \<open>g \<star> h\<close>
	+ by (unfold_locales, auto)
	+ interpretation THfgh_HHfgh:
	+ arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>(f \<star> g) \<star> h\<close> \<open>tab_of_ide ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>0 ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>1 ((f \<star> g) \<star> h)\<close>
	+ \<open>(f \<star> g) \<star> h\<close>
	+ using fg gh by (unfold_locales, auto)
	+ interpretation TfHgh_HfHgh:
	+ arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>f \<star> g \<star> h\<close> \<open>tab_of_ide (f \<star> g \<star> h)\<close> \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
	+ \<open>f \<star> g \<star> h\<close>
	+ using fg gh by (unfold_locales, auto)
	+ interpretation TTfgh: composite_tabulation_in_maps V H \<a> \<i> src trg
	+ \<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
	+ h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
	+ using fg gh by (unfold_locales, auto)
	+ interpretation TTfgh_THfgh:
	+ horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>f \<star> g\<close> Tfg.\<rho>\<sigma>.tab \<open>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1\<close>
	+ h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
	+ \<open>f \<star> g\<close> \<open>tab_of_ide (f \<star> g)\<close> \<open>tab\<^sub>0 (f \<star> g)\<close> \<open>tab\<^sub>1 (f \<star> g)\<close>
	+ h \<open>tab_of_ide h\<close> \<open>tab\<^sub>0 h\<close> \<open>tab\<^sub>1 h\<close>
	+ \<open>f \<star> g\<close> h
	+ ..
	+ interpretation TfTgh: composite_tabulation_in_maps V H \<a> \<i> src trg
	+ f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
	+ \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ using fg gh by (unfold_locales, auto)
	+ interpretation TfTgh_TfHgh:
	+ horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
	+ f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
	+ \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
	+ \<open>g \<star> h\<close> \<open>tab_of_ide (g \<star> h)\<close> \<open>tab\<^sub>0 (g \<star> h)\<close> \<open>tab\<^sub>1 (g \<star> h)\<close>
	+ f \<open>g \<star> h\<close>
	+ ..
	+ interpretation TfTgh_TfTgh:
	+ horizontal_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
	+ f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
	+ \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ f \<open>tab_of_ide f\<close> \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close>
	+ \<open>g \<star> h\<close> Tgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ f \<open>g \<star> h\<close>
	+ ..
	+ text \<open>
	+ The following interpretation defines the associativity between the peaks
	+ of the two composite tabulations \<open>TTfgh\<close> (associated to the left) and \<open>TfTgh\<close>
	+ (associated to the right).
	+ \<close>
	+ (* TODO: Try to get rid of the .\<rho>\<sigma> in, e.g., Tfg.\<rho>\<sigma>.p\<^sub>1. *)
	+ interpretation TTfgh_TfTgh:
	+ arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.\<rho>\<sigma>.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
	+ \<open>f \<star> g \<star> h\<close> TfTgh.tab \<open>(tab\<^sub>0 h \<star> Tgh.\<rho>\<sigma>.p\<^sub>0) \<star> TfTgh.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfTgh.p\<^sub>1\<close>
	+ \<open>\<a>[f, g, h]\<close>
	+ using fg gh by (unfold_locales, auto)
	+
	+ text \<open>
	+ This interpretation defines the map, from the apex of the tabulation associated
	+ with the horizontal composite \<open>(f \<star> g) \<star> h\<close> to the apex of the tabulation associated
	+ with the horizontal composite \<open>f \<star> g \<star> h\<close>, induced by the associativity isomorphism
	+ \<open>\<a>[f, g, h]\<close> from \<open>(f \<star> g) \<star> h\<close> to \<open>f \<star> g \<star> h\<close>.
	+ \<close>
	+
	+ interpretation HHfgh_HfHgh: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom (\<alpha> (f, g, h))\<close> \<open>tab_of_ide (dom (\<alpha> (f, g, h)))\<close>
	+ \<open>tab\<^sub>0 (dom (\<alpha> (f, g, h)))\<close> \<open>tab\<^sub>1 (dom (\<alpha> (f, g, h)))\<close>
	+ \<open>cod (\<alpha> (f, g, h))\<close> \<open>tab_of_ide (cod (\<alpha> (f, g, h)))\<close>
	+ \<open>tab\<^sub>0 (cod (\<alpha> (f, g, h)))\<close> \<open>tab\<^sub>1 (cod (\<alpha> (f, g, h)))\<close>
	+ \<open>\<alpha> (f, g, h)\<close>
	+ proof -
	+ have "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ ((f \<star> g) \<star> h) (tab_of_ide ((f \<star> g) \<star> h)) (tab\<^sub>0 ((f \<star> g) \<star> h)) (tab\<^sub>1 ((f \<star> g) \<star> h))
	+ (f \<star> g \<star> h) (tab_of_ide (f \<star> g \<star> h)) (tab\<^sub>0 (f \<star> g \<star> h)) (tab\<^sub>1 (f \<star> g \<star> h))
	+ \<a>[f, g, h]"
	+ using fg gh by (unfold_locales, auto)
	+ thus "arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ (dom (\<alpha> (f, g, h))) (tab_of_ide (dom (\<alpha> (f, g, h))))
	+ (tab\<^sub>0 (dom (\<alpha> (f, g, h)))) (tab\<^sub>1 (dom (\<alpha> (f, g, h))))
	+ (cod (\<alpha> (f, g, h))) (tab_of_ide (cod (\<alpha> (f, g, h))))
	+ (tab\<^sub>0 (cod (\<alpha> (f, g, h)))) (tab\<^sub>1 (cod (\<alpha> (f, g, h))))
	+ (\<alpha> (f, g, h))"
	+ using fg gh \<alpha>_def by auto
	+ qed
	+
	+ interpretation SPN_f: arrow_of_spans Maps.comp \<open>SPN f\<close>
	+ using SPN_in_hom Span.arr_char [of "SPN f"] by simp
	+ interpretation SPN_g: arrow_of_spans Maps.comp \<open>SPN g\<close>
	+ using SPN_in_hom Span.arr_char [of "SPN g"] by simp
	+ interpretation SPN_h: arrow_of_spans Maps.comp \<open>SPN h\<close>
	+ using SPN_in_hom Span.arr_char [of "SPN h"] by simp
	+ interpretation SPN_fgh: three_composable_identity_arrows_of_spans Maps.comp
	+ Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 \<open>SPN f\<close> \<open>SPN g\<close> \<open>SPN h\<close>
	+ using fg gh Span.arr_char SPN_in_hom SPN.preserves_ide Span.ide_char
	+ apply unfold_locales by auto
	+
	+ text \<open>
	+ The following relates the projections associated with the composite span \<open>SPN_fgh\<close>
	+ with tabulations in the underlying bicategory.
	+ \<close>
	+
	+ lemma prj_char:
	+ shows "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ and "SPN_fgh.Prj\<^sub>0\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ and "SPN_fgh.Prj\<^sub>0 = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ and "SPN_fgh.Prj\<^sub>1 = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ and "SPN_fgh.Prj\<^sub>1\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ and "SPN_fgh.Prj\<^sub>0\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ proof -
	+ show "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "ide (Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
	+ by (metis TTfgh.composable TTfgh.leg1_simps(2) Tfg.\<rho>\<sigma>.T0.antipar(2)
	+ Tfg.\<rho>\<sigma>.T0.ide_right Tfg_Hfg.u_simps(3) f.T0.antipar(2) f.T0.ide_right
	+ f.u_simps(3) fg g.ide_leg1 g.leg1_simps(4) h.ide_leg1 h.leg1_simps(4)
	+ ide_hcomp hseqE hcomp_simps(1) tab\<^sub>1_simps(1))
	+ thus ?thesis
	+ using fg gh Tfg.\<rho>\<sigma>.prj_char TTfgh.prj_char isomorphic_reflexive
	+ Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
	+ Maps.comp_CLS [of Tfg.\<rho>\<sigma>.p\<^sub>1 TTfgh.p\<^sub>1 "Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1"]
	+ by (simp add: TTfgh.composable Tfg.\<rho>\<sigma>.T0.antipar(2))
	+ qed
	+ show "SPN_fgh.Prj\<^sub>0\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "ide (Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
	+ by (metis TTfgh.leg1_simps(2) bicategory_of_spans.tab\<^sub>0_simps(1)
	+ bicategory_of_spans.tab\<^sub>1_simps(1) bicategory_of_spans_axioms
	+ Tfg.\<rho>\<sigma>.T0.antipar(2) Tfg.\<rho>\<sigma>.T0.ide_right Tfg.composable f.T0.antipar(2)
	+ f.T0.ide_right f.u_simps(3) g.ide_leg1 g.leg1_simps(4)
	+ Tfg.u_simps(3) THfgh.composable h.ide_leg1 h.leg1_simps(4)
	+ ide_hcomp hseqE hcomp_simps(1) tab\<^sub>1_simps(3))
	+ thus ?thesis
	+ using fg gh Tfg.\<rho>\<sigma>.prj_char TTfgh.prj_char isomorphic_reflexive
	+ Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
	+ Maps.comp_CLS [of Tfg.\<rho>\<sigma>.p\<^sub>0 TTfgh.p\<^sub>1 "Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1"]
	+ by (simp add: Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable)
	+ qed
	+ show "SPN_fgh.Prj\<^sub>0 = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using isomorphic_reflexive TTfgh.prj_char Tfg.\<rho>\<sigma>.prj_char
	+ Maps.comp_CLS [of "tab\<^sub>0 g" Tfg.\<rho>\<sigma>.p\<^sub>0 "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
	+ by (simp add: Tfg.composable)
	+ show "SPN_fgh.Prj\<^sub>1 = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ using Tgh.\<rho>\<sigma>.prj_char isomorphic_reflexive Tgh.composable
	+ Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
	+ TfTgh.prj_char
	+ by simp
	+ show "SPN_fgh.Prj\<^sub>1\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char isomorphic_reflexive
	+ Maps.comp_CLS [of "tab\<^sub>1 g" "prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)" "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
	+ Maps.comp_CLS [of Tgh.\<rho>\<sigma>.p\<^sub>1 TfTgh.p\<^sub>0 "Tgh.\<rho>\<sigma>.p\<^sub>1 \<star> TfTgh.p\<^sub>0"]
	+ by simp
	+ show "SPN_fgh.Prj\<^sub>0\<^sub>0 = \<lbrakk>\<lbrakk>Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char isomorphic_reflexive
	+ Maps.comp_CLS [of "tab\<^sub>1 g" "Tgh.\<rho>\<sigma>.p\<^sub>1" "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
	+ Maps.comp_CLS [of Tgh.\<rho>\<sigma>.p\<^sub>0 TfTgh.p\<^sub>0 "Tgh.\<rho>\<sigma>.p\<^sub>0 \<star> TfTgh.p\<^sub>0"]
	+ by simp
	+ qed
	+
	+ interpretation \<Phi>: transformation_by_components VV.comp Span.vcomp
	+ HoSPN_SPN.map SPNoH.map \<open>\<lambda>rs. CMP (fst rs) (snd rs)\<close>
	+ using compositor_is_natural_transformation by simp
	+ interpretation \<Phi>: natural_isomorphism VV.comp Span.vcomp
	+ HoSPN_SPN.map SPNoH.map \<Phi>.map
	+ using compositor_is_natural_isomorphism by simp
	+
	+ (*
	+ * TODO: Figure out how this subcategory gets introduced.
	+ * The simps in the locale are used in the subsequent proofs.
	+ *)
	+ interpretation VVV': subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> arr (fst (snd \<tau>\<mu>\<nu>)) \<and> arr (snd (snd \<tau>\<mu>\<nu>)) \<and>
	+ src (fst (snd \<tau>\<mu>\<nu>)) = trg (snd (snd \<tau>\<mu>\<nu>)) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using fg gh VVV.arr_char VV.arr_char VVV.subcategory_axioms by simp
	+
	+ text \<open>
	+ We define abbreviations for the left and right-hand sides of the equation for
	+ associativity coherence.
	+ \<close>
	+ (*
	+ * TODO: \<Phi> doesn't really belong in this locale. Replace it with CMP and rearrange
	+ * material so that this locale comes first and the definition of \<Phi> comes later
	+ * in bicategory_of_spans.
	+ *)
	+ abbreviation LHS
	+ where "LHS \<equiv> SPN \<a>[f, g, h] \<bullet> \<Phi>.map (f \<star> g, h) \<bullet> (\<Phi>.map (f, g) \<circ> SPN h)"
	+
	+ abbreviation RHS
	+ where "RHS \<equiv> \<Phi>.map (f, g \<star> h) \<bullet> (SPN f \<circ> \<Phi>.map (g, h)) \<bullet>
	+ Span.assoc (SPN f) (SPN g) (SPN h)"
	+
	+ lemma arr_LHS:
	+ shows "Span.arr LHS"
	+ using fg gh VVV.arr_char VVV.ide_char VV.arr_char VV.ide_char Span.hseqI'
	+ HoHV_def compositor_in_hom \<alpha>_def
	+ apply (intro Span.seqI)
	+ apply simp_all
	+ using SPN.FF_def
	+ apply simp
	+ proof -
	+ have "SPN ((f \<star> g) \<star> h) = Span.cod (CMP (f \<star> g) h)"
	+ using fg gh compositor_in_hom by simp
	+ also have "... = Span.cod (CMP (f \<star> g) h \<bullet> (CMP f g \<circ> SPN h))"
	+ proof -
	+ have "Span.seq (CMP (f \<star> g) h) (CMP f g \<circ> SPN h)"
	+ proof (intro Span.seqI Span.hseqI)
	+ show 1: "Span.in_hhom (SPN h) (SPN.map\<^sub>0 (src h)) (SPN.map\<^sub>0 (trg h))"
	+ using SPN.preserves_src SPN.preserves_trg by simp
	+ show 2: "Span.in_hhom (CMP f g) (SPN.map\<^sub>0 (trg h)) (SPN.map\<^sub>0 (trg f))"
	+ using compositor_in_hom SPN_fgh.\<nu>\<pi>.composable fg by auto
	+ show 3: "Span.arr (CMP (f \<star> g) h)"
	+ using TTfgh.composable Tfg.\<rho>\<sigma>.ide_base compositor_simps(1) h.is_ide by auto
	+ show "Span.dom (CMP (f \<star> g) h) = Span.cod (CMP f g \<circ> SPN h)"
	+ using 1 2 3 fg gh compositor_in_hom SPN_fgh.\<nu>\<pi>.composable SPN_in_hom SPN.FF_def
	+ by auto
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ finally show "SPN ((f \<star> g) \<star> h) = Span.cod (CMP (f \<star> g) h \<bullet> (CMP f g \<circ> SPN h))"
	+ by blast
	+ qed
	+
	+ lemma arr_RHS:
	+ shows "Span.arr RHS"
	+ using fg gh VV.ide_char VV.arr_char \<Phi>.map_simp_ide SPN.FF_def Span.hseqI'
	+ by (intro Span.seqI, simp_all)
	+
	+ lemma par_LHS_RHS:
	+ shows "Span.par LHS RHS"
	+ proof (intro conjI)
	+ show "Span.arr LHS"
	+ using arr_LHS by simp
	+ show "Span.arr RHS"
	+ using arr_RHS by simp
	+ show "Span.dom LHS = Span.dom RHS"
	+ proof -
	+ have "Span.dom LHS = Span.dom (\<Phi>.map (f, g) \<circ> SPN h)"
	+ using arr_LHS by auto
	+ also have "... = Span.dom (\<Phi>.map (f, g)) \<circ> Span.dom (SPN h)"
	+ using arr_LHS Span.dom_hcomp [of "SPN h" "\<Phi>.map (f, g)"] by blast
	+ also have "... = (SPN f \<circ> SPN g) \<circ> SPN h"
	+ using fg \<Phi>.map_simp_ide VV.ide_char VV.arr_char SPN.FF_def by simp
	+ also have "... = Span.dom (Span.assoc (SPN f) (SPN g) (SPN h))"
	+ using fg gh VVV.arr_char VVV.ide_char VV.arr_char VV.ide_char by simp
	+ also have "... = Span.dom RHS"
	+ using \<open>Span.arr RHS\<close> by auto
	+ finally show ?thesis by blast
	+ qed
	+ show "Span.cod LHS = Span.cod RHS"
	+ proof -
	+ have "Span.cod LHS = Span.cod (SPN \<a>[f, g, h])"
	+ using arr_LHS by simp
	+ also have "... = SPN (f \<star> g \<star> h)"
	+ unfolding \<alpha>_def
	+ using fg gh VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char HoVH_def
	+ by simp
	+ also have "... = Span.cod RHS"
	+ using arr_RHS fg gh \<Phi>.map_simp_ide VV.ide_char VV.arr_char SPN.FF_def
	+ compositor_in_hom
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+
	+ lemma Chn_LHS_eq:
	+ shows "Chn LHS =
	+ \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "Chn LHS = \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot>
	+ Span.chine_hcomp (CMP f g) (SPN h)"
	+ proof -
	+ have "Chn LHS = Chn (SPN \<a>[f, g, h]) \<odot> Chn (CMP (f \<star> g) h) \<odot>
	+ Chn (CMP f g \<circ> SPN h)"
	+ using fg gh arr_LHS \<Phi>.map_simp_ide VV.ide_char VV.arr_char Span.Chn_vcomp
	+ by auto
	+ moreover have "Chn (SPN \<a>[f, g, h]) = Maps.CLS HHfgh_HfHgh.chine"
	+ using fg gh SPN_def VVV.arr_char VV.arr_char spn_def \<alpha>_def by simp
	+ moreover have "Chn (CMP (f \<star> g) h) = Maps.CLS THfgh_HHfgh.chine"
	+ using fg gh CMP_def THfgh.cmp_def by simp
	+ moreover have "Chn (CMP f g \<circ> SPN h) = Span.chine_hcomp (CMP f g) (SPN h)"
	+ using fg gh Span.hcomp_def by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ moreover have "Span.chine_hcomp (CMP f g) (SPN h) = \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "Span.chine_hcomp (CMP f g) (SPN h) =
	+ Maps.tuple
	+ (\<lbrakk>\<lbrakk>Tfg.cmp\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
	+ (\<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)"
	+ proof -
	+ have "\<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using fg isomorphic_reflexive
	+ Maps.comp_CLS [of "tab\<^sub>0 g" "Tfg.\<rho>\<sigma>.p\<^sub>0" "tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0"]
	+ by simp
	+ moreover have "span_in_category.apex Maps.comp \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 h\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>\<rparr> =
	+ \<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk>"
	+ proof -
	+ interpret h: span_in_category Maps.comp \<open>\<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 h\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>\<rparr>\<close>
	+ using h.determines_span by simp
	+ interpret dom_h: identity_arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom h\<close> \<open>tab_of_ide (dom h)\<close> \<open>tab\<^sub>0 (dom h)\<close> \<open>tab\<^sub>1 (dom h)\<close>
	+ \<open>cod h\<close> \<open>tab_of_ide (cod h)\<close> \<open>tab\<^sub>0 (cod h)\<close> \<open>tab\<^sub>1 (cod h)\<close>
	+ h
	+ by (simp add: h.is_arrow_of_tabulations_in_maps
	+ identity_arrow_of_tabulations_in_maps.intro
	+ identity_arrow_of_tabulations_in_maps_axioms.intro)
	+ have "Maps.arr h.leg0"
	+ using h.leg_simps(1) by simp
	+ hence "Maps.dom h.leg0 = \<lbrakk>\<lbrakk>dom_h.chine\<rbrakk>\<rbrakk>"
	+ using Maps.dom_char Maps.CLS_in_hom
	+ apply simp
	+ proof -
	+ have "h.is_induced_map (src (tab\<^sub>0 h))"
	+ using h.is_induced_map_iff dom_h.\<Delta>_eq_\<rho> h.apex_is_induced_by_cell by force
	+ hence "src (tab\<^sub>0 h) \<cong> h.chine"
	+ using h.chine_is_induced_map h.induced_map_unique by simp
	+ thus "\<lbrakk>src (tab\<^sub>0 h)\<rbrakk> = \<lbrakk>h.chine\<rbrakk>"
	+ using iso_class_eqI by simp
	+ qed
	+ thus ?thesis
	+ using h.apex_def spn_def by simp
	+ qed
	+ ultimately show ?thesis
	+ unfolding Span.chine_hcomp_def
	+ using fg gh CMP_def Tfg.\<rho>\<sigma>.prj_char Span.hcomp_def by simp
	+ qed
	+ also have "... = \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "\<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk> =
	+ Maps.tuple \<lbrakk>\<lbrakk>Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
	+ \<lbrakk>\<lbrakk>h.chine \<star> TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using TTfgh_THfgh.CLS_chine by simp
	+ also have "... =
	+ Maps.tuple (\<lbrakk>\<lbrakk>Tfg_Hfg.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>)
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
	+ (\<lbrakk>\<lbrakk>h.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>)"
	+ proof -
	+ have "\<lbrakk>\<lbrakk>Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg_Hfg.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "is_left_adjoint TTfgh.p\<^sub>1"
	+ using Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable by simp
	+ moreover have "Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1 \<cong> Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1"
	+ using TTfgh_THfgh.prj_chine(2) isomorphic_reflexive isomorphic_implies_hpar(2)
	+ by blast
	+ ultimately show ?thesis
	+ using Tfg_Hfg.is_map
	+ Maps.comp_CLS [of Tfg_Hfg.chine TTfgh.p\<^sub>1 "Tfg_Hfg.chine \<star> TTfgh.p\<^sub>1"]
	+ by simp
	+ qed
	+ moreover have "\<lbrakk>\<lbrakk>h.chine \<star> TTfgh.p\<^sub>0\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>h.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "is_left_adjoint TTfgh.p\<^sub>0"
	+ by (simp add: Tfg.\<rho>\<sigma>.T0.antipar(2) THfgh.composable)
	+ moreover have "h.chine \<star> TTfgh.p\<^sub>0 \<cong> h.chine \<star> TTfgh.p\<^sub>0"
	+ using TTfgh_THfgh.prj_chine(1) isomorphic_reflexive isomorphic_implies_hpar(2)
	+ by blast
	+ ultimately show ?thesis
	+ using h.is_map Maps.comp_CLS [of h.chine TTfgh.p\<^sub>0 "h.chine \<star> TTfgh.p\<^sub>0"]
	+ by simp
	+ qed
	+ ultimately show ?thesis by argo
	+ qed
	+ also have "... =
	+ Maps.tuple (\<lbrakk>\<lbrakk>Tfg.cmp\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>1 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 (f \<star> g)\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>
	+ (\<lbrakk>\<lbrakk>spn h\<rbrakk>\<rbrakk> \<odot> Maps.PRJ\<^sub>0 \<lbrakk>\<lbrakk>tab\<^sub>0 g \<star> Tfg.\<rho>\<sigma>.p\<^sub>0\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>)"
	+ using Tfg.cmp_def spn_def TTfgh.prj_char by simp
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+
	+ abbreviation tuple_BC
	+ where "tuple_BC \<equiv> Maps.tuple SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 SPN_fgh.Prj\<^sub>0"
	+
	+ abbreviation tuple_ABC
	+ where "tuple_ABC \<equiv> Maps.tuple SPN_fgh.Prj\<^sub>1\<^sub>1
	+ SPN_fgh.\<mu>.leg0
	+ (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
	+ tuple_BC"
	+
	+ abbreviation tuple_BC'
	+ where "tuple_BC' \<equiv> Maps.tuple \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+
	+ abbreviation tuple_ABC'
	+ where "tuple_ABC' \<equiv> Maps.tuple \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>
	+ tuple_BC'"
	+
	+ lemma csq:
	+ shows "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
	+ SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
	+ and "Maps.commutative_square SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
	+ SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
	+ proof -
	+ show 1: "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
	+ SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
	+ proof
	+ show "Maps.cospan SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1"
	+ using SPN_fgh.\<nu>\<pi>.legs_form_cospan(1) by simp
	+ show "Maps.span SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
	+ using SPN_fgh.prj_simps(2-3,5-6) by presburger
	+ show "Maps.dom SPN_fgh.\<nu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>0\<^sub>1"
	+ using SPN_fgh.prj_simps(8) SPN_g.dom.is_span SPN_g.dom.leg_simps(2)
	+ by auto
	+ show "SPN_fgh.\<nu>.leg0 \<odot> SPN_fgh.Prj\<^sub>0\<^sub>1 = SPN_fgh.\<pi>.leg1 \<odot> SPN_fgh.Prj\<^sub>0"
	+ by (metis (no_types, lifting) Maps.cod_comp Maps.comp_assoc
	+ Maps.pullback_commutes' SPN_fgh.\<mu>\<nu>.dom.leg_simps(1)
	+ SPN_fgh.\<mu>\<nu>.leg0_composite SPN_fgh.cospan_\<nu>\<pi>)
	+ qed
	+ show "Maps.commutative_square
	+ SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
	+ SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
	+ proof
	+ show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
	+ using fg gh SPN_fgh.prj_simps(10) by blast
	+ show "Maps.span SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
	+ using fg gh 1 Maps.tuple_simps(1) Maps.tuple_simps(2) SPN_fgh.prj_simps(1)
	+ SPN_fgh.prj_simps(4) SPN_fgh.prj_simps(5)
	+ by presburger
	+ show "Maps.dom SPN_fgh.\<mu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>1\<^sub>1"
	+ using fg gh SPN_f.dom.leg_simps(2) SPN_fgh.prj_simps(7) by auto
	+ show "SPN_fgh.\<mu>.leg0 \<odot> SPN_fgh.Prj\<^sub>1\<^sub>1 = (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_BC"
	+ using 1 fg gh Maps.comp_assoc Maps.prj_tuple
	+ by (metis (no_types, lifting) Maps.pullback_commutes' SPN_fgh.cospan_\<mu>\<nu>)
	+ qed
	+ qed
	+
	+ lemma tuple_ABC_eq_ABC':
	+ shows "tuple_BC = tuple_BC'"
	+ and "tuple_ABC = tuple_ABC'"
	+ proof -
	+ have "SPN_fgh.Prj\<^sub>1\<^sub>1 = \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ using prj_char by simp
	+ moreover have "SPN_fgh.\<mu>.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk>"
	+ by simp
	+ moreover have "SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1 = \<lbrakk>\<lbrakk>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ using Tgh.\<rho>\<sigma>.prj_char isomorphic_reflexive Tgh.composable
	+ Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
	+ by (simp add: g.T0.antipar(2))
	+ moreover show "tuple_BC = tuple_BC'"
	+ using prj_char Tfg.\<rho>\<sigma>.prj_char by simp
	+ ultimately show "tuple_ABC = tuple_ABC'"
	+ by argo
	+ qed
	+
	+ lemma tuple_BC_in_hom:
	+ shows "Maps.in_hom tuple_BC (Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0))"
	+ proof
	+ show 1: "Maps.arr tuple_BC"
	+ using csq(1) by simp
	+ have 2: "Maps.commutative_square
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ by (metis Tfg.S\<^sub>0_def Tfg.span_legs_eq(3) Tgh.S\<^sub>1_def Tgh.span_legs_eq(4) csq(1)
	+ prj_char(2) prj_char(3))
	+ show "Maps.dom tuple_BC = Maps.MkIde (src TTfgh.p\<^sub>0)"
	+ proof -
	+ have "Maps.dom tuple_BC' = Maps.dom \<lbrakk>\<lbrakk>Tfg.\<rho>\<sigma>.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ using 2 Maps.tuple_simps by simp
	+ also have "... = Chn (Span.hcomp (Span.hcomp (SPN f) (SPN g)) (SPN h))"
	+ using Maps.dom_char
	+ by (metis SPN_fgh.prj_simps(5) prj_char(2))
	+ also have "... = Maps.MkIde (src TTfgh.p\<^sub>0)"
	+ using 1 fg gh Maps.dom_char csq(1) prj_char(3) tuple_ABC_eq_ABC'(1)
	+ Maps.Dom.simps(1) Maps.tuple_simps(2) SPN_fgh.prj_simps(3,5-6)
	+ by presburger
	+ finally have "Maps.dom tuple_BC' = Maps.MkIde (src TTfgh.p\<^sub>0)"
	+ by blast
	+ thus ?thesis
	+ using tuple_ABC_eq_ABC' by simp
	+ qed
	+ show "Maps.cod tuple_BC = Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0)"
	+ proof -
	+ have "Maps.cod tuple_BC' = Maps.pbdom \<lbrakk>\<lbrakk>tab\<^sub>0 g\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 h\<rbrakk>\<rbrakk>"
	+ using 1 2 fg gh Maps.tuple_in_hom by blast
	+ also have "... = Maps.MkIde (src Tgh.\<rho>\<sigma>.p\<^sub>0)"
	+ using 1 2 fg gh Maps.pbdom_def
	+ by (metis (no_types, lifting) SPN.preserves_ide SPN_fgh.\<nu>\<pi>.are_identities(2)
	+ SPN_fgh.\<nu>\<pi>.composable Span.chine_hcomp_ide_ide Tfg.S\<^sub>0_def Tfg.span_legs_eq(3)
	+ Tgh.S\<^sub>1_def Tgh.chine_hcomp_SPN_SPN Tgh.span_legs_eq(4) g.is_ide)
	+ finally show ?thesis
	+ using tuple_ABC_eq_ABC' by simp
	+ qed
	+ qed
	+
	+ lemma tuple_ABC_in_hom:
	+ shows "Maps.in_hom tuple_ABC (Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src TfTgh.p\<^sub>0))"
	+ proof
	+ show 1: "Maps.arr tuple_ABC"
	+ using SPN_fgh.chine_assoc_def SPN_fgh.chine_assoc_in_hom by auto
	+ show "Maps.dom tuple_ABC = Maps.MkIde (src TTfgh.p\<^sub>0)"
	+ proof -
	+ have "Maps.dom tuple_ABC = Maps.dom SPN_fgh.chine_assoc"
	+ by (simp add: SPN_fgh.chine_assoc_def)
	+ also have "... = Chn ((SPN f \<circ> SPN g) \<circ> SPN h)"
	+ using SPN_fgh.chine_assoc_in_hom by blast
	+ also have "... = Maps.MkIde (src TTfgh.p\<^sub>0)"
	+ by (metis (lifting) Maps.Dom.simps(1) Maps.dom_char SPN_fgh.prj_simps(3)
	+ SPN_fgh.prj_simps(6) prj_char(3))
	+ finally show ?thesis by blast
	+ qed
	+ show "Maps.cod tuple_ABC = Maps.MkIde (src TfTgh.p\<^sub>0)"
	+ proof -
	+ have "Maps.cod tuple_ABC = Maps.cod SPN_fgh.chine_assoc"
	+ by (simp add: SPN_fgh.chine_assoc_def)
	+ also have 1: "... = Chn (SPN f \<circ> SPN g \<circ> SPN h)"
	+ using SPN_fgh.chine_assoc_in_hom by blast
	+ also have "... = Maps.MkIde (src TfTgh.p\<^sub>0)"
	+ by (metis (lifting) Maps.Dom.simps(1) Maps.cod_char Maps.seq_char
	+ SPN_fgh.prj_chine_assoc(1) SPN_fgh.prj_simps(1) TfTgh.leg1_in_hom(1)
	+ TfTgh_TfTgh.u_in_hom 1 in_hhomE prj_char(4) src_hcomp')
	+ finally show ?thesis by argo
	+ qed
	+ qed
	+
	+ lemma Chn_RHS_eq:
	+ shows "Chn RHS = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> tuple_ABC'"
	+ proof -
	+ have "Chn RHS =
	+ Chn (\<Phi>.map (f, g \<star> h)) \<odot> Chn (SPN f \<circ> \<Phi>.map (g, h)) \<odot>
	+ Chn (Span.assoc (SPN f) (SPN g) (SPN h))"
	+ proof -
	+ have "Chn RHS = Chn (\<Phi>.map (f, g \<star> h)) \<odot>
	+ Chn ((SPN f \<circ> \<Phi>.map (g, h)) \<bullet> Span.assoc (SPN f) (SPN g) (SPN h))"
	+ using arr_RHS Span.vcomp_eq Span.Chn_vcomp by blast
	+ also have "... = Chn (\<Phi>.map (f, g \<star> h)) \<odot> Chn (SPN f \<circ> \<Phi>.map (g, h)) \<odot>
	+ Chn (Span.assoc (SPN f) (SPN g) (SPN h))"
	+ proof -
	+ have "Span.seq (SPN f \<circ> \<Phi>.map (g, h)) (Span.assoc (SPN f) (SPN g) (SPN h))"
	+ using arr_RHS by auto
	+ thus ?thesis
	+ using fg gh Span.vcomp_eq [of "SPN f \<circ> \<Phi>.map (g, h)"
	+ "Span.assoc (SPN f) (SPN g) (SPN h)"]
	+ by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "Chn (\<Phi>.map (f, g \<star> h)) = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk>"
	+ using arr_RHS fg gh \<Phi>.map_simp_ide VV.ide_char VV.arr_char CMP_def TfHgh.cmp_def
	+ by simp
	+ moreover have "Chn (SPN f \<circ> \<Phi>.map (g, h)) = Span.chine_hcomp (SPN f) (CMP g h)"
	+ using fg gh Span.hcomp_def \<Phi>.map_simp_ide VV.ide_char VV.arr_char SPN.FF_def
	+ by simp
	+ moreover have "Chn (Span.assoc (SPN f) (SPN g) (SPN h)) = tuple_ABC"
	+ using fg gh Span.\<alpha>_ide VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char
	+ SPN_fgh.chine_assoc_def Span.\<alpha>_def
	+ by simp
	+ moreover have "Span.chine_hcomp (SPN f) (CMP g h) = \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "Span.chine_hcomp (SPN f) (CMP g h) =
	+ Maps.tuple
	+ (\<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>)
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (g \<star> h)\<rbrakk>\<rbrakk>
	+ (\<lbrakk>\<lbrakk>Tgh_Hgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>)"
	+ proof -
	+ interpret f: span_in_category Maps.comp
	+ \<open>\<lparr>Leg0 = MkArr (src (tab\<^sub>0 f)) (trg g) \<lbrakk>tab\<^sub>0 f\<rbrakk>,
	+ Leg1 = MkArr (src (tab\<^sub>0 f)) (trg f) \<lbrakk>tab\<^sub>1 f\<rbrakk>\<rparr>\<close>
	+ using f.determines_span
	+ by (simp add: Tfg.composable)
	+ interpret f: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f f.tab \<open>tab\<^sub>0 f\<close> \<open>tab\<^sub>1 f\<close> f
	+ using f.is_arrow_of_tabulations_in_maps by simp
	+ have "f.apex = Maps.CLS f.chine"
	+ proof (intro Maps.arr_eqI)
	+ show "Maps.arr f.apex" by simp
	+ show "Maps.arr \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
	+ using Maps.CLS_in_hom f.is_map by blast
	+ show "Maps.Dom f.apex = Maps.Dom \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
	+ using f.apex_def Tfg.RS_simps(2) Tfg.R\<^sub>0_def Tfg.composable by auto
	+ show "Maps.Cod f.apex = Maps.Cod \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
	+ using f.apex_def Tfg.RS_simps(2) Tfg.R\<^sub>0_def Tfg.composable by auto
	+ show "Maps.Map f.apex = Maps.Map \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "Maps.Map f.apex = \<lbrakk>src (tab\<^sub>0 f)\<rbrakk>"
	+ using f.apex_def Maps.dom_char Tfg.RS_simps(2) Tfg.R\<^sub>0_def Tfg.composable
	+ by auto
	+ also have "... = \<lbrakk>f.chine\<rbrakk>"
	+ proof (intro iso_class_eqI)
	+ have "f.is_induced_map (src (tab\<^sub>0 f))"
	+ using f.apex_is_induced_by_cell comp_cod_arr by auto
	+ thus "src (tab\<^sub>0 f) \<cong> f.chine"
	+ using f.induced_map_unique f.chine_is_induced_map by simp
	+ qed
	+ also have "... = Maps.Map \<lbrakk>\<lbrakk>f.chine\<rbrakk>\<rbrakk>"
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ unfolding Span.chine_hcomp_def
	+ using fg gh CMP_def Tgh.\<rho>\<sigma>.prj_char Span.hcomp_def isomorphic_reflexive
	+ Maps.comp_CLS [of "tab\<^sub>1 g" Tgh.\<rho>\<sigma>.p\<^sub>1 "tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1"]
	+ Tgh.cmp_def TfTgh.prj_char
	+ by simp
	+ qed
	+ also have "... = Maps.tuple \<lbrakk>\<lbrakk>f.chine \<star> TfTgh.p\<^sub>1\<rbrakk>\<rbrakk>
	+ \<lbrakk>\<lbrakk>tab\<^sub>0 f\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>tab\<^sub>1 (g \<star> h)\<rbrakk>\<rbrakk>
	+ \<lbrakk>\<lbrakk>Tgh_Hgh.chine \<star> TfTgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using isomorphic_reflexive TfHgh.composable f.is_map TfHgh.composable Tgh_Hgh.is_map
	+ Maps.comp_CLS [of f.chine TfTgh.p\<^sub>1 "f.chine \<star> TfTgh.p\<^sub>1"]
	+ Maps.comp_CLS [of Tgh_Hgh.chine TfTgh.p\<^sub>0 "Tgh_Hgh.chine \<star> TfTgh.p\<^sub>0"]
	+ by auto
	+ also have "... = \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk>"
	+ using TfTgh_TfHgh.CLS_chine by simp
	+ finally show ?thesis by blast
	+ qed
	+ ultimately have "Chn RHS =\<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> tuple_ABC"
	+ by simp
	+ also have "... = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> tuple_ABC'"
	+ using tuple_ABC_eq_ABC' by simp
	+ finally show ?thesis by simp
	+ qed
	+
	+ interpretation g\<^sub>0h\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg \<open>tab\<^sub>1 h\<close> \<open>tab\<^sub>0 g\<close>
	+ using gh by (unfold_locales, auto)
	+ interpretation f\<^sub>0g\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg \<open>tab\<^sub>1 g\<close> \<open>tab\<^sub>0 f\<close>
	+ using fg by (unfold_locales, auto)
	+ interpretation f\<^sub>0gh\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg
	+ \<open>tab\<^sub>1 g \<star> Tgh.\<rho>\<sigma>.p\<^sub>1\<close> \<open>tab\<^sub>0 f\<close>
	+ using fg gh Tgh.\<rho>\<sigma>.leg1_is_map
	+ by (unfold_locales, auto)
	+ interpretation fg\<^sub>0h\<^sub>1: cospan_of_maps_in_bicategory_of_spans V H \<a> \<i> src trg
	+ \<open>tab\<^sub>1 h\<close> \<open>tab\<^sub>0 g \<star> Tfg.p\<^sub>0\<close>
	+ using TTfgh.r\<^sub>0s\<^sub>1_is_cospan by simp
	+
	+ lemma src_tab_eq:
	+ shows "(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ TfTgh.composite_cell TTfgh_TfTgh.chine TTfgh_TfTgh.the_\<theta> \<cdot> TTfgh_TfTgh.the_\<nu> =
	+ TTfgh.tab"
	+ proof -
	+ have "TfTgh.composite_cell TTfgh_TfTgh.chine TTfgh_TfTgh.the_\<theta> \<cdot> TTfgh_TfTgh.the_\<nu> =
	+ (\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> TTfgh.tab"
	+ unfolding TTfgh.tab_def
	+ using TTfgh_TfTgh.chine_is_induced_map TTfgh.tab_def TTfgh_TfTgh.\<Delta>_simps(4)
	+ by auto
	+ moreover have "iso (\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0)"
	+ by (simp add: fg gh)
	+ moreover have "inv (\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) = \<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
	+ using fg gh by simp
	+ ultimately show ?thesis
	+ using invert_side_of_triangle(1)
	+ [of "TfTgh.composite_cell TTfgh_TfTgh.chine TTfgh_TfTgh.the_\<theta> \<cdot> TTfgh_TfTgh.the_\<nu>"
	+ "\<a>[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0" TTfgh.tab]
	+ TTfgh_TfTgh.\<Delta>_simps(1) (* TODO: Must go last? Why? *)
	+ by presburger
	+ qed
	+
	+ text \<open>
	+ We need to show that the associativity isomorphism (defined in terms of tupling) coincides
	+ with \<open>TTfgh_TfTgh.chine\<close> (defined in terms of tabulations). In order to do this,
	+ we need to know how the latter commutes with projections. That is the purpose of
	+ the following lemma. Unfortunately, it requires some lengthy calculations,
	+ which I haven't seen any way to avoid.
	+ \<close>
	+
	+ lemma prj_chine:
	+ shows "\<lbrakk>\<lbrakk>TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ and "\<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ and "\<lbrakk>\<lbrakk>Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ proof -
	+ have 1: "ide TfTgh.p\<^sub>1"
	+ by (simp add: TfTgh.composable)
	+ have 2: "ide TTfgh_TfTgh.chine"
	+ by simp
	+ have 3: "src TfTgh.p\<^sub>1 = trg TTfgh_TfTgh.chine"
	+ using TTfgh_TfTgh.chine_in_hom(1) by simp
	+ have 4: "src (tab\<^sub>1 f) = trg TfTgh.p\<^sub>1"
	+ using TfTgh.leg1_simps(2) by blast
	+ text \<open>
	+ The required isomorphisms will each be established via \<open>T2\<close>, using the equation
	+ \<open>src_tab_eq\<close> (associativities omitted from diagram):
	+$$
	+\begin{array}{l}
	+\xymatrix{
	+ && \xtwocell[dddd]{}\omit{^{\rm the\_}\nu}
	+ & \scriptstyle{{\rm TTfgh}.{\rm apex}} \ar[dd]^{{\rm chine}} \ar[dddlll]_{{\rm TfTgh}.p_1} \ar[dddrrr]^{{\rm TfTgh}.p_0}
	+ & \xtwocell[dddd]{}\omit{^{\rm the\_}\theta} \\
	+ &&&&& \\
	+ &&& \scriptstyle{{\rm TfTgh.apex}} \ar[ddll]_{{\rm TfTgh}.p_1} \ar[dr]^{{\rm TfTgh}.p_0} && \\
	+ \scriptstyle{f.{\rm apex}} \ar[dd]_{f.{\rm tab}_1}
	+ && \dtwocell\omit{^<-7>{f_0gh_1.\phi}}
	+ && \scriptstyle{{\rm Tgh.apex}} \ar[dl]_{{\rm Tgh}.p_1} \ar[dr]^{{\rm Tgh}.p_0} \ddtwocell\omit{^{g_0h_1.\phi}}
	+ && \scriptstyle{h.{\rm apex}} \ar[dd]^{h.{\rm tab}_0} \\
	+ & \scriptstyle{f.{\rm apex}} \ar[dl]_{f.{\rm tab}_1} \ar[dr]^{f.{\rm tab}_0} \dtwocell\omit{^f.{\rm tab}}
	+ && \scriptstyle{g.{\rm apex}} \ar[dl]_{g.{\rm tab}_1} \ar[dr]^{g.{\rm tab}_0} \dtwocell\omit{^g.{\rm tab}}
	+ && \scriptstyle{h.{\rm apex}} \ar[dl]_{h.{\rm tab}_1} \ar[dr]^{h.{\rm tab}_0} \dtwocell\omit{^h.{\rm tab}} \\
	+ \scriptstyle{{\rm trg}~f} && \scriptstyle{{\rm src}~f = {\rm trg}~g} \ar[ll]^{f}
	+ && \scriptstyle{{\rm src}~g = {\rm trg}~h} \ar[ll]^{g} && \scriptstyle{{\rm src}~h} \ar[ll]^{h}
	+}
	+\\
	+\\
	+\hspace{7cm}=
	+\\
	+\\
	+\xymatrix{
	+ &&& \scriptstyle{{\rm TTfgh.apex}} \ar[dl]_{{\rm TTfgh}.p_1} \ar[ddrr]^{{\rm TTfgh}.p_0} && \\
	+ && \scriptstyle{{\rm Tfg.apex}} \ar[dl]_{{\rm Tfg}.p_1} \ar[dr]^{{\rm Tfg}.p_0} \ddtwocell\omit{^{f_0g_1.\phi}}
	+ & \dtwocell\omit{^<-7>{fg_0h_1.\phi}} &&& \\
	+ & \scriptstyle{f.{\rm apex}} \ar[dl]_{f.{\rm tab}_1} \ar[dr]^{f.{\rm tab}_0} \dtwocell\omit{^f.{\rm tab}}
	+ && \scriptstyle{g.{\rm apex}} \ar[dl]_{g.{\rm tab}_1} \ar[dr]^{g.{\rm tab}_0} \dtwocell\omit{^g.{\rm tab}}
	+ && \scriptstyle{h.{\rm apex}} \ar[dl]_{h.{\rm tab}_1} \ar[dr]^{h.{\rm tab}_0} \dtwocell\omit{^h.{\rm tab}} \\
	+ \scriptstyle{{\rm trg}~f} && \scriptstyle{{\rm src}~f = {\rm trg}~g} \ar[ll]^{f}
	+ && \scriptstyle{{\rm src}~g = {\rm trg}~h} \ar[ll]^{g} && \scriptstyle{{\rm src}~h} \ar[ll]^{h}
	+}
	+\end{array}
	+$$
	+ There is a sequential dependence between the proofs, such as we have already
	+ seen for \<open>horizontal_composite_of_arrows_of_tabulations_in_maps.prj_chine\<close>.
	+ \<close>
	+ define u\<^sub>f where "u\<^sub>f = g \<star> h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
	+ define w\<^sub>f where "w\<^sub>f = Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1"
	+ define w\<^sub>f' where "w\<^sub>f' = TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"
	+ define \<theta>\<^sub>f
	+ where "\<theta>\<^sub>f = (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot> (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot> (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> (\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> (f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ define \<theta>\<^sub>f'
	+ where "\<theta>\<^sub>f' = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]"
	+ define \<beta>\<^sub>f
	+ where "\<beta>\<^sub>f = \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ have w\<^sub>f: "ide w\<^sub>f"
	+ using w\<^sub>f_def fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
	+ have w\<^sub>f_is_map: "is_left_adjoint w\<^sub>f"
	+ using w\<^sub>f_def fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
	+ by (simp add: left_adjoints_compose)
	+ have w\<^sub>f': "ide w\<^sub>f'"
	+ unfolding w\<^sub>f'_def by simp
	+ have w\<^sub>f'_is_map: "is_left_adjoint w\<^sub>f'"
	+ unfolding w\<^sub>f'_def
	+ using 3 TTfgh_TfTgh.is_map f\<^sub>0gh\<^sub>1.leg1_is_map
	+ by (simp add: left_adjoints_compose)
	+ have \<theta>\<^sub>f: "\<guillemotleft>\<theta>\<^sub>f : tab\<^sub>0 f \<star> w\<^sub>f \<Rightarrow> u\<^sub>f\<guillemotright>"
	+ proof (unfold \<theta>\<^sub>f_def w\<^sub>f_def u\<^sub>f_def, intro comp_in_homI)
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] :
	+ tab\<^sub>0 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using f\<^sub>0g\<^sub>1.leg1_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan by auto
	+ show "\<guillemotleft>f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1 :
	+ (tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using f\<^sub>0g\<^sub>1.\<phi>_in_hom(2) Tfg.\<rho>\<sigma>.T0.antipar(1)
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>(g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 :
	+ (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> ((g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using Tfg.\<rho>\<sigma>.T0.antipar(1)
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1 :
	+ ((g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (g \<star> tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] :
	+ (g \<star> tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> g \<star> (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
	+ show "\<guillemotleft>g \<star> fg\<^sub>0h\<^sub>1.\<phi> : g \<star> (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> g \<star> tab\<^sub>1 h \<star> TTfgh.p\<^sub>0\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.\<phi>_in_hom fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>g \<star> h.tab \<star> TTfgh.p\<^sub>0 : g \<star> tab\<^sub>1 h \<star> TTfgh.p\<^sub>0 \<Rightarrow> g \<star> (h \<star> tab\<^sub>0 h) \<star> TTfgh.p\<^sub>0\<guillemotright>"
	+ using gh fg\<^sub>0h\<^sub>1.\<phi>_in_hom fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] :
	+ g \<star> (h \<star> tab\<^sub>0 h) \<star> TTfgh.p\<^sub>0 \<Rightarrow> g \<star> h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<guillemotright>"
	+ using gh fg\<^sub>0h\<^sub>1.\<phi>_in_hom fg\<^sub>0h\<^sub>1.p\<^sub>1_simps
	+ by (intro hcomp_in_vhom, auto)
	+ qed
	+ have \<theta>\<^sub>f': "\<guillemotleft>\<theta>\<^sub>f' : tab\<^sub>0 f \<star> w\<^sub>f' \<Rightarrow> u\<^sub>f\<guillemotright>"
	+ proof (unfold \<theta>\<^sub>f'_def w\<^sub>f'_def u\<^sub>f_def, intro comp_in_homI)
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] :
	+ tab\<^sub>0 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine \<Rightarrow> (tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using "1" "2" "3" "4" assoc'_in_hom(2) f.ide_u f.leg1_simps(3) by auto
	+ show "\<guillemotleft>f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine :
	+ (tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine \<Rightarrow>
	+ ((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using f\<^sub>0gh\<^sub>1.\<phi>_in_hom(2)
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
	+ ((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> (((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>(\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
	+ (((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> ((g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
	+ ((g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> ((g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan g\<^sub>0h\<^sub>1.\<phi>_in_hom(2)
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine :
	+ ((g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> ((g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) :
	+ ((g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> g \<star> h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan by auto
	+ show "\<guillemotleft>g \<star> h \<star> TTfgh_TfTgh.the_\<theta> :
	+ g \<star> h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> g \<star> h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<guillemotright>"
	+ using f\<^sub>0gh\<^sub>1.cospan g\<^sub>0h\<^sub>1.cospan TTfgh_TfTgh.the_\<theta>_in_hom
	+ by (intro hcomp_in_vhom, auto)
	+ qed
	+ have \<beta>\<^sub>f: "\<guillemotleft>\<beta>\<^sub>f : tab\<^sub>1 f \<star> w\<^sub>f \<Rightarrow> tab\<^sub>1 f \<star> w\<^sub>f'\<guillemotright>"
	+ proof (unfold \<beta>\<^sub>f_def w\<^sub>f_def w\<^sub>f'_def, intro comp_in_homI)
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] :
	+ tab\<^sub>1 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using TTfgh.leg1_in_hom(2) assoc'_in_hom by auto
	+ show "\<guillemotleft>TTfgh_TfTgh.the_\<nu> :
	+ (tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using TTfgh_TfTgh.the_\<nu>_in_hom TTfgh_TfTgh.the_\<nu>_props by simp
	+ show "\<guillemotleft>\<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] :
	+ (tab\<^sub>1 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine \<Rightarrow> tab\<^sub>1 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using 1 2 3 4 by auto
	+ qed
	+ have iso_\<beta>\<^sub>f: "iso \<beta>\<^sub>f"
	+ unfolding \<beta>\<^sub>f_def
	+ using 1 2 3 4 \<beta>\<^sub>f \<beta>\<^sub>f_def isos_compose
	+ apply (intro isos_compose)
	+ apply (metis TTfgh.composable TTfgh.leg1_in_hom(2) Tfg.\<rho>\<sigma>.T0.antipar(2)
	+ Tfg.\<rho>\<sigma>.T0.ide_right Tfg.\<rho>\<sigma>.leg1_in_hom(2) Tfg_Hfg.u_simps(3)
	+ f.T0.antipar(2) f.T0.ide_right f.ide_leg1 f\<^sub>0g\<^sub>1.cospan g.ide_leg1
	+ h.ide_leg1 h.leg1_simps(4) hcomp_in_vhomE ide_hcomp
	+ iso_assoc' tab\<^sub>1_simps(1))
	+ using TTfgh_TfTgh.the_\<nu>_props(2) f.ide_leg1 iso_assoc by blast+
	+ have u\<^sub>f: "ide u\<^sub>f"
	+ using \<theta>\<^sub>f ide_cod by blast
	+ have w\<^sub>f_in_hhom: "in_hhom w\<^sub>f (src u\<^sub>f) (src (tab\<^sub>0 f))"
	+ using u\<^sub>f w\<^sub>f u\<^sub>f_def w\<^sub>f_def by simp
	+ have w\<^sub>f'_in_hhom: "in_hhom w\<^sub>f' (src u\<^sub>f) (src (tab\<^sub>0 f))"
	+ using u\<^sub>f w\<^sub>f' w\<^sub>f'_def u\<^sub>f_def by simp
	+ have 5: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>f \<Rightarrow> w\<^sub>f'\<guillemotright> \<and> \<beta>\<^sub>f = tab\<^sub>1 f \<star> \<gamma> \<and> \<theta>\<^sub>f = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>)"
	+ proof -
	+ have eq\<^sub>f: "f.composite_cell w\<^sub>f \<theta>\<^sub>f = f.composite_cell w\<^sub>f' \<theta>\<^sub>f' \<cdot> \<beta>\<^sub>f"
	+ proof -
	+ text \<open>
	+ I don't see any alternative here to just grinding out the calculation.
	+ The idea is to bring \<open>f.composite_cell w\<^sub>f \<theta>\<^sub>f\<close> into a form in which
	+ \<open>src_tab_eq\<close> can be applied to eliminate \<open>\<theta>\<^sub>f\<close> in favor of \<open>\<theta>\<^sub>f'\<close>.
	+ \<close>
	+ have "f.composite_cell w\<^sub>f \<theta>\<^sub>f =
	+ (f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ (f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
	+ unfolding w\<^sub>f_def \<theta>\<^sub>f_def
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps Tgh.composable hseqI' whisker_left comp_assoc
	+ by simp (* 20 sec *)
	+ also have "... =
	+ (\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])) \<cdot>
	+ (f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
	+ proof -
	+ have "(\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0]) \<cdot>
	+ (f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) =
	+ f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_cod_arr comp_assoc_assoc' by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (f \<star> g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])) \<cdot>
	+ (f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
	+ using comp_assoc by simp
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, (h \<star> tab\<^sub>0 h) \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (f \<star> g \<star> h.tab \<star> TTfgh.p\<^sub>0)) \<cdot>
	+ (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_assoc
	+ assoc'_naturality [of f g "\<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]"]
	+ by simp
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>1 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (f \<star> g \<star> fg\<^sub>0h\<^sub>1.\<phi>)) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_assoc
	+ assoc'_naturality [of f g "h.tab \<star> TTfgh.p\<^sub>0"]
	+ by simp
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1]) \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_assoc
	+ assoc'_naturality [of f g fg\<^sub>0h\<^sub>1.\<phi>]
	+ by simp
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
	+ proof -
	+ have "(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot> \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] =
	+ \<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "(f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot> \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1] =
	+ \<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ \<a>'_def \<alpha>_def
	+ by simp
	+ also have "... =
	+ \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ by (intro E.eval_eqI, simp_all)
	+ also have "... = \<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ \<a>'_def \<alpha>_def
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>[f, tab\<^sub>1 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
	+ proof -
	+ have "(f \<star> f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot> \<a>[f, tab\<^sub>0 f \<star> Tfg.p\<^sub>1, TTfgh.p\<^sub>1] =
	+ \<a>[f, tab\<^sub>1 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_in_hom hseqI'
	+ assoc_naturality [of f f\<^sub>0g\<^sub>1.\<phi> TTfgh.p\<^sub>1]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1)"
	+ proof -
	+ have "(f \<star> (g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> \<a>[f, tab\<^sub>1 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] =
	+ \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_in_hom hseqI'
	+ assoc_naturality [of f "g.tab \<star> Tfg.p\<^sub>0" TTfgh.p\<^sub>1]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps assoc'_naturality [of f.tab Tfg.p\<^sub>1 TTfgh.p\<^sub>1] comp_assoc
	+ by simp
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ ((((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "(((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) =
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_cod_arr whisker_right comp_assoc_assoc'
	+ whisker_left [of f "\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]" "\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]"]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ using comp_assoc by simp
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (((\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "((\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) =
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1"
	+ using fg fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_cod_arr comp_assoc_assoc'
	+ whisker_right
	+ [of TTfgh.p\<^sub>1 "\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0]" "\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0]"]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((f.tab \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ using comp_assoc by simp
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
	+ (f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1)
	+ \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ whisker_right comp_assoc
	+ by simp
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
	+ (f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1)
	+ \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[f, g, (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>[f, (g \<star> tab\<^sub>0 g) \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) =
	+ \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, (\<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>) \<^bold>\<cdot>
	+ (\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>)\<rbrace>"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ \<a>'_def \<alpha>_def
	+ by simp
	+ also have "... = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tfg.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh.p\<^sub>1\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ by (intro E.eval_eqI, auto)
	+ also have "... = \<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ \<a>'_def \<alpha>_def
	+ by simp
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
	+ (f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1)
	+ \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "(\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) =
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0])"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ comp_cod_arr comp_assoc_assoc'
	+ by simp
	+ thus ?thesis by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> g) \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g) \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f \<star> g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0] \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0]) \<cdot>
	+ (f \<star> (g.tab \<star> Tfg.p\<^sub>0)) \<cdot>
	+ (f \<star> f\<^sub>0g\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, Tfg.p\<^sub>1] \<cdot>
	+ (f.tab \<star> Tfg.p\<^sub>1)
	+ \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ using comp_assoc by simp
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ TTfgh.tab \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ using TTfgh.tab_def Tfg.\<rho>\<sigma>.tab_def by simp
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<cdot>
	+ (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<cdot>
	+ (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<cdot>
	+ (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1)
	+ \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1)
	+ \<star> TTfgh_TfTgh.chine) \<cdot>
	+ TTfgh_TfTgh.the_\<nu>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ using src_tab_eq TfTgh.tab_def Tgh.\<rho>\<sigma>.tab_def comp_assoc by simp
	+ text \<open>Now we have to make this look like \<open>f.composite_cell w\<^sub>f' \<theta>\<^sub>f' \<cdot> \<beta>\<^sub>f\<close>.\<close>
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>)) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1)
	+ \<star> TTfgh_TfTgh.chine) \<cdot>
	+ TTfgh_TfTgh.the_\<nu>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<cdot>
	+ (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<cdot>
	+ (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<cdot>
	+ (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1)
	+ \<star> TfTgh.p\<^sub>0 =
	+ (f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0)"
	+ using fg gh hseqI' whisker_right whisker_left by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1)
	+ \<star> TTfgh_TfTgh.chine =
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ have "arr (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1))"
	+ using fg gh hseqI'
	+ by (intro seqI' comp_in_homI, auto)
	+ (*
	+ * TODO: Find a way to generate the following consequences automatically
	+ * without having to list them.
	+ *)
	+ moreover
	+ have "arr ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1))"
	+ using calculation by blast
	+ moreover
	+ have "arr ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1))"
	+ using calculation by blast
	+ moreover
	+ have "arr ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1))"
	+ using calculation by blast
	+ moreover
	+ have "arr ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1))"
	+ using calculation by blast
	+ moreover
	+ have "arr ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1))"
	+ using calculation by blast
	+ moreover
	+ have "arr ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1))"
	+ using calculation by blast
	+ moreover
	+ have "arr ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1))"
	+ using calculation by blast
	+ moreover
	+ have "arr ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1))"
	+ using calculation by blast
	+ moreover
	+ have "arr (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1))"
	+ using calculation by blast
	+ ultimately show ?thesis
	+ using whisker_right by auto
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
	+ (f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ comp_arr_dom comp_assoc_assoc'
	+ by simp
	+ thus ?thesis by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ using comp_assoc by presburger
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "((f.tab \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ assoc'_naturality [of f.tab TfTgh.p\<^sub>1 TTfgh_TfTgh.chine]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine)) \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "(\<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) =
	+ f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ comp_cod_arr comp_assoc_assoc'
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ using comp_assoc by presburger
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
	+ proof -
	+ have "(\<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f \<star> tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] =
	+ \<lbrace>(\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using \<a>'_def \<alpha>_def by simp
	+ also have "... = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 f\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>])\<rbrace>"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ by (intro E.eval_eqI, auto)
	+ also have "... = \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
	+ using \<a>'_def \<alpha>_def by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ (*
	+ * This one can't be shortcut with a straight coherence-based proof,
	+ * due to the presence of f\<^sub>0gh\<^sub>1.\<phi>, g\<^sub>0h\<^sub>1.\<phi>, h.tab, with associativities that
	+ * do not respect their domain and codomain.
	+ *
	+ * I also tried to avoid distributing the "f \<star>" in advance, in order to
	+ * reduce the number of associativity proof steps, but it then becomes
	+ * less automatic to prove the necessary "arr" facts to do the proof.
	+ * So unfortunately the mindless grind seems to be the path of least
	+ * resistance.
	+ *)
	+ have "((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> f\<^sub>0gh\<^sub>1.\<phi>) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, tab\<^sub>0 f \<star> TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] =
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ assoc'_naturality [of f f\<^sub>0gh\<^sub>1.\<phi> TTfgh_TfTgh.chine] comp_assoc
	+ by simp
	+ also have "... =
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, ((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ have "((f \<star> (g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[f, ((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ assoc'_naturality [of f "(g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ have "((f \<star> \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, ((g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ assoc'_naturality
	+ [of f "\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ ((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ have "((f \<star> (g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ assoc'_naturality [of f "(g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ (((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ (f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ have "((f \<star> (g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ assoc'_naturality
	+ [of f "(g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0" TTfgh_TfTgh.chine]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ (* OK, we can perhaps shortcut the last few steps... *)
	+ have "((f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0]) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((f \<star> (g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
	+ \<lbrace>((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>])
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
	+ \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ \<a>'_def \<alpha>_def
	+ by simp
	+ also have "... =
	+ \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
	+ \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>])
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)\<rbrace>"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ apply (intro E.eval_eqI) by simp_all
	+ also have "... =
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using fg gh fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.p\<^sub>0_simps f\<^sub>0g\<^sub>1.p\<^sub>1_simps hseqI'
	+ \<a>'_def \<alpha>_def
	+ by simp
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ (\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>)) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "(f \<star> ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) =
	+ (f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
	+ proof -
	+ have "arr ((((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
	+ using fg gh hseqI'
	+ apply (intro seqI hseqI) by auto
	+ moreover
	+ have "arr ((((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
	+ using calculation by blast
	+ moreover
	+ have "arr (((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
	+ using calculation by blast
	+ moreover
	+ have "arr ((((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
	+ using calculation by blast
	+ moreover
	+ have "arr ((f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
	+ using calculation by blast
	+ ultimately show ?thesis
	+ using whisker_left by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ (f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (\<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)) \<cdot>
	+ (f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ \<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot>
	+ ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) =
	+ \<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (\<a>[f \<star> g, h, tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ (((f \<star> g) \<star> h) \<star> TTfgh_TfTgh.the_\<theta>)) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ have "(\<a>\<^sup>-\<^sup>1[f, g, h] \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> ((f \<star> g \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) =
	+ \<a>\<^sup>-\<^sup>1[f, g, h] \<star> TTfgh_TfTgh.the_\<theta>"
	+ using fg gh comp_arr_dom comp_cod_arr
	+ interchange [of "\<a>\<^sup>-\<^sup>1[f, g, h]" "f \<star> g \<star> h"
	+ "tab\<^sub>0 h \<star> TTfgh.p\<^sub>0" TTfgh_TfTgh.the_\<theta>]
	+ by simp
	+ also have "... = (((f \<star> g) \<star> h) \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using fg gh comp_arr_dom comp_cod_arr
	+ interchange [of "(f \<star> g) \<star> h" "\<a>\<^sup>-\<^sup>1[f, g, h]" TTfgh_TfTgh.the_\<theta>
	+ "((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine"]
	+ by simp
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ (\<a>[f, g, h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0] \<cdot>
	+ ((f \<star> g) \<star> h \<star> TTfgh_TfTgh.the_\<theta>)) \<cdot>
	+ \<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using fg gh assoc_naturality [of "f \<star> g" h TTfgh_TfTgh.the_\<theta>] comp_assoc
	+ by simp
	+ also have "... =
	+ (f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ \<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using fg gh hseqI' assoc_naturality [of f g "h \<star> TTfgh_TfTgh.the_\<theta>"] comp_assoc
	+ by simp
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ ((f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (f \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
	+ (f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "\<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) =
	+ f \<star> can
	+ (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ proof -
	+ have "\<a>[f, g, h \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[f \<star> g, h, ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, h] \<star> ((tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[f \<star> g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> h, (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, (g \<star> h) \<star> (tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f \<star> \<a>[g \<star> h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0] \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> (\<a>\<^sup>-\<^sup>1[g, h, tab\<^sub>0 h \<star> Tgh.p\<^sub>0] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f \<star> ((g \<star> \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0]) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) =
	+ \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>,
	+ \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>,
	+ ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>\<^bold>]
	+ \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
	+ \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>,
	+ (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>,
	+ \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star>
	+ \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)\<rbrace>"
	+ using \<a>'_def \<alpha>_def by simp
	+ also have "... =
	+ can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>))
	+ (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>))"
	+ using fg gh
	+ apply (unfold can_def)
	+ apply (intro E.eval_eqI)
	+ by simp_all
	+ also have "... =
	+ f \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ using fg gh whisker_can_left_0 by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... =
	+ (f \<star> (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[f, tab\<^sub>0 f, TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (f.tab \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ TTfgh_TfTgh.the_\<nu> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "((f \<star> g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (f \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
	+ (f \<star> (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])) =
	+ f \<star> (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine]"
	+ proof -
	+ have 1: "arr ((g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
	+ using fg gh hseqI'
	+ apply (intro seqI' comp_in_homI) by auto
	+ moreover
	+ have 2: "arr (can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine])"
	+ using calculation by blast
	+ ultimately show ?thesis
	+ using whisker_left 1 2 f.is_ide by simp (* 20 sec *)
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = f.composite_cell w\<^sub>f' \<theta>\<^sub>f' \<cdot> \<beta>\<^sub>f"
	+ unfolding w\<^sub>f'_def \<theta>\<^sub>f'_def \<beta>\<^sub>f_def
	+ using comp_assoc by simp
	+ finally show ?thesis by blast
	+ qed
	+ show ?thesis
	+ using w\<^sub>f w\<^sub>f' \<theta>\<^sub>f \<theta>\<^sub>f' \<beta>\<^sub>f f.T2 [of w\<^sub>f w\<^sub>f' \<theta>\<^sub>f u\<^sub>f \<theta>\<^sub>f' \<beta>\<^sub>f] eq\<^sub>f by fast
	+ qed
	+ obtain \<gamma>\<^sub>f where \<gamma>\<^sub>f: "\<guillemotleft>\<gamma>\<^sub>f : w\<^sub>f \<Rightarrow> w\<^sub>f'\<guillemotright> \<and> \<beta>\<^sub>f = tab\<^sub>1 f \<star> \<gamma>\<^sub>f \<and> \<theta>\<^sub>f = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>\<^sub>f)"
	+ using 5 by auto
	+ show "\<lbrakk>\<lbrakk>TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "iso \<gamma>\<^sub>f"
	+ using \<gamma>\<^sub>f BS3 w\<^sub>f_is_map w\<^sub>f'_is_map by blast
	+ hence "isomorphic w\<^sub>f w\<^sub>f'"
	+ using \<gamma>\<^sub>f isomorphic_def isomorphic_symmetric by auto
	+ thus ?thesis
	+ using w\<^sub>f w\<^sub>f_def w\<^sub>f'_def Maps.CLS_eqI isomorphic_symmetric by auto
	+ qed
	+ text \<open>
	+ On to the next equation:
	+ \[
	+ \<open>\<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>\<close>.
	+ \]
	+ We have to make use of the equation \<open>\<theta>\<^sub>f = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>\<^sub>f)\<close> in this part,
	+ similarly to how the equation \<open>src_tab_eq\<close> was used to replace
	+ \<open>TTfgh.tab\<close> in the first part.
	+ \<close>
	+ define u\<^sub>g where "u\<^sub>g = h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
	+ define w\<^sub>g where "w\<^sub>g = Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1"
	+ define w\<^sub>g' where "w\<^sub>g' = Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
	+ define \<theta>\<^sub>g
	+ where "\<theta>\<^sub>g = \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ define \<theta>\<^sub>g'
	+ where "\<theta>\<^sub>g' = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
	+ define \<beta>\<^sub>g
	+ where "\<beta>\<^sub>g = \<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot> \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ have u\<^sub>g: "ide u\<^sub>g"
	+ unfolding u\<^sub>g_def by simp
	+ have w\<^sub>g: "ide w\<^sub>g"
	+ unfolding w\<^sub>g_def using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
	+ have w\<^sub>g_is_map: "is_left_adjoint w\<^sub>g"
	+ unfolding w\<^sub>g_def
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps left_adjoints_compose by simp
	+ have w\<^sub>g': "ide w\<^sub>g'"
	+ unfolding w\<^sub>g'_def by simp
	+ have w\<^sub>g'_is_map: "is_left_adjoint w\<^sub>g'"
	+ unfolding w\<^sub>g'_def
	+ using TTfgh_TfTgh.is_map left_adjoints_compose by simp
	+ have \<theta>\<^sub>g: "\<guillemotleft>\<theta>\<^sub>g : tab\<^sub>0 g \<star> w\<^sub>g \<Rightarrow> u\<^sub>g\<guillemotright>"
	+ unfolding w\<^sub>g_def u\<^sub>g_def \<theta>\<^sub>g_def
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps fg\<^sub>0h\<^sub>1.\<phi>_in_hom
	+ apply (intro comp_in_homI) by auto
	+ have \<theta>\<^sub>g': "\<guillemotleft>\<theta>\<^sub>g' : tab\<^sub>0 g \<star> w\<^sub>g' \<Rightarrow> u\<^sub>g\<guillemotright>"
	+ unfolding w\<^sub>g'_def u\<^sub>g_def \<theta>\<^sub>g'_def
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>0_simps
	+ apply (intro comp_in_homI)
	+ apply auto
	+ apply auto
	+ by fastforce+
	+ have w\<^sub>g_in_hhom: "in_hhom w\<^sub>g (src u\<^sub>g) (src (tab\<^sub>0 g))"
	+ unfolding w\<^sub>g_def u\<^sub>g_def by auto
	+ have w\<^sub>g'_in_hhom: "in_hhom w\<^sub>g' (src u\<^sub>g) (src (tab\<^sub>0 g))"
	+ unfolding w\<^sub>g'_def u\<^sub>g_def by auto
	+ have \<beta>\<^sub>g: "\<guillemotleft>\<beta>\<^sub>g : tab\<^sub>1 g \<star> w\<^sub>g \<Rightarrow> tab\<^sub>1 g \<star> w\<^sub>g'\<guillemotright>"
	+ proof (unfold \<beta>\<^sub>g_def w\<^sub>g_def, intro comp_in_homI)
	+ (* auto can solve this, but it's too slow *)
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] :
	+ tab\<^sub>1 g \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
	+ show "\<guillemotleft>inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1 :
	+ (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> (tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_in_hom f\<^sub>0g\<^sub>1.\<phi>_uniqueness(2) by auto
	+ show "\<guillemotleft>\<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] :
	+ (tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps \<gamma>\<^sub>f w\<^sub>f_def w\<^sub>f'_def by auto
	+ show "\<guillemotleft>tab\<^sub>0 f \<star> \<gamma>\<^sub>f : tab\<^sub>0 f \<star> Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps \<gamma>\<^sub>f w\<^sub>f_def w\<^sub>f'_def by auto
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] :
	+ tab\<^sub>0 f \<star> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine \<Rightarrow> (tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ by auto
	+ show "\<guillemotleft>f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine :
	+ (tab\<^sub>0 f \<star> TfTgh.p\<^sub>1) \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> ((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using f\<^sub>0gh\<^sub>1.\<phi>_in_hom by auto
	+ show "\<guillemotleft>\<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] :
	+ ((tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ by auto
	+ show "\<guillemotleft>\<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] :
	+ (tab\<^sub>1 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine \<Rightarrow> tab\<^sub>1 g \<star> w\<^sub>g'\<guillemotright>"
	+ using w\<^sub>g'_def by auto
	+ qed
	+ have eq\<^sub>g: "g.composite_cell w\<^sub>g \<theta>\<^sub>g = g.composite_cell w\<^sub>g' \<theta>\<^sub>g' \<cdot> \<beta>\<^sub>g"
	+ proof -
	+ have "g.composite_cell w\<^sub>g \<theta>\<^sub>g =
	+ (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot>
	+ (h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ fg\<^sub>0h\<^sub>1.\<phi> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
	+ unfolding w\<^sub>g_def \<theta>\<^sub>g_def by simp
	+ also have "... =
	+ (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ ((g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1]) \<cdot>
	+ (g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
	+ using fg gh f\<^sub>0g\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' whisker_left
	+ comp_assoc
	+ by simp
	+ also have "... =
	+ (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ (\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]))) \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1] \<cdot>
	+ (g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
	+ proof -
	+ have "(\<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) =
	+ g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_cod_arr hseqI' comp_assoc_assoc' by simp
	+ thus ?thesis
	+ by (simp add: comp_assoc)
	+ qed
	+ also have "... =
	+ (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1]) \<cdot>
	+ (g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1)"
	+ using comp_assoc by simp
	+ also have "... =
	+ (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (g.tab \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1))"
	+ using fg gh f\<^sub>0g\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>0_simps fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_assoc
	+ fg\<^sub>0h\<^sub>1.p\<^sub>1_simps pentagon' iso_inv_iso
	+ invert_opposite_sides_of_square
	+ [of "\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1"
	+ "(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1])"
	+ "\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]" "\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1]"]
	+ by simp
	+ also have "... =
	+ (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps assoc'_naturality [of g.tab Tfg.p\<^sub>0 TTfgh.p\<^sub>1] by simp
	+ also have "... =
	+ (g \<star> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]) \<cdot>
	+ (g \<star> h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ (g \<star> fg\<^sub>0h\<^sub>1.\<phi>) \<cdot>
	+ \<a>[g, tab\<^sub>0 g \<star> Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ (\<a>[g, tab\<^sub>0 g, Tfg.p\<^sub>0] \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((g.tab \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "(f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] =
	+ ((f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1]) \<cdot>
	+ (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ using comp_assoc by simp
	+ also have "... = ((f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ ((tab\<^sub>0 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps whisker_right comp_assoc_assoc' by simp
	+ also have "... = ((f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0g\<^sub>1.\<phi>_uniqueness hseqI' comp_cod_arr by simp
	+ also have "... = ((tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "(f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot> (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) =
	+ f\<^sub>0g\<^sub>1.\<phi> \<cdot> inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1"
	+ using f\<^sub>0g\<^sub>1.\<phi>_uniqueness whisker_right by simp
	+ also have "... = (tab\<^sub>1 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1"
	+ using f\<^sub>0g\<^sub>1.\<phi>_uniqueness comp_arr_inv' by simp
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps comp_cod_arr by simp
	+ finally have "(f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot> (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] = \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<theta>\<^sub>f \<cdot>
	+ \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ unfolding \<theta>\<^sub>f_def using comp_assoc by simp
	+ also have "... = \<theta>\<^sub>f' \<cdot> (tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot>
	+ \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ using \<gamma>\<^sub>f comp_assoc by simp
	+ also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot>
	+ \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ unfolding \<theta>\<^sub>f'_def using comp_assoc by simp
	+ also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 f, TfTgh.p\<^sub>1, TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 f \<star> \<gamma>\<^sub>f) \<cdot>
	+ \<a>[tab\<^sub>0 f, Tfg.p\<^sub>1, TTfgh.p\<^sub>1] \<cdot>
	+ (inv f\<^sub>0g\<^sub>1.\<phi> \<star> TTfgh.p\<^sub>1) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]"
	+ proof -
	+ have "(\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ (f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine) =
	+ f\<^sub>0gh\<^sub>1.\<phi> \<star> TTfgh_TfTgh.chine"
	+ using f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' comp_cod_arr comp_arr_dom comp_assoc_assoc' by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<beta>\<^sub>g"
	+ unfolding \<beta>\<^sub>g_def using comp_assoc by presburger
	+ also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ \<beta>\<^sub>g"
	+ proof -
	+ have "(((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ ((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
	+ using f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
	+ assoc'_naturality [of "(g.tab \<star> Tgh.p\<^sub>1)" TfTgh.p\<^sub>0 TTfgh_TfTgh.chine]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<beta>\<^sub>g"
	+ proof -
	+ have "((g.tab \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>1 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
	+ using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
	+ assoc'_naturality [of g.tab Tgh.p\<^sub>1 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
	+ \<beta>\<^sub>g"
	+ proof -
	+ have "(\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) =
	+ g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
	+ using hseqI' comp_cod_arr comp_assoc_assoc' by simp
	+ thus ?thesis
	+ using comp_assoc g\<^sub>0h\<^sub>1.\<phi>_in_hom by simp
	+ qed
	+ also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
	+ \<beta>\<^sub>g"
	+ proof -
	+ have "(\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) =
	+ (\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ ((g \<star> (tab\<^sub>0 g \<star> Tgh.p\<^sub>1)) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' comp_assoc comp_assoc_assoc' by simp
	+ also have "... = (\<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' comp_cod_arr comp_assoc_assoc' by simp
	+ also have "... = (((g \<star> (tab\<^sub>0 g \<star> Tgh.p\<^sub>1)) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine)"
	+ using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' whisker_right comp_assoc_assoc' by simp
	+ also have "... = (\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine"
	+ using g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' comp_cod_arr by simp
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ ((((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
	+ \<beta>\<^sub>g"
	+ using comp_assoc by presburger
	+ also have "... = (g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<beta>\<^sub>g"
	+ proof -
	+ have "(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ have "(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
	+ using comp_assoc by simp
	+ also have "... = ((((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine]) \<cdot>
	+ ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
	+ proof -
	+ have "(((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
	+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
	+ assoc'_naturality [of "g \<star> g\<^sub>0h\<^sub>1.\<phi>" TfTgh.p\<^sub>0 TTfgh_TfTgh.chine]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ ((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
	+ proof -
	+ have "(((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ ((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
	+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
	+ assoc'_naturality [of "g \<star> h.tab \<star> Tgh.p\<^sub>0" TfTgh.p\<^sub>0 TTfgh_TfTgh.chine]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ (((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ have "((g \<star> g\<^sub>0h\<^sub>1.\<phi>) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
	+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
	+ assoc'_naturality [of g g\<^sub>0h\<^sub>1.\<phi> "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
	+ proof -
	+ have "((g \<star> h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>1 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
	+ \<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)"
	+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
	+ assoc'_naturality [of g "h.tab \<star> Tgh.p\<^sub>0" "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (g \<star> can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
	+ (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])) \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<beta>\<^sub>g"
	+ proof -
	+ have "can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
	+ g \<star> can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
	+ can (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[g \<star> (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] =
	+ \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' canI_associator_0 \<a>'_def \<alpha>_def by simp
	+ also have "... = can (((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ unfolding can_def
	+ using gh
	+ apply (intro E.eval_eqI) by simp_all
	+ finally show ?thesis by blast
	+ qed
	+ moreover
	+ have "\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
	+ can ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[g, (h \<star> tab\<^sub>0 h) \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
	+ \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' canI_associator_0 \<a>'_def \<alpha>_def by simp
	+ also have "... = can ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ unfolding can_def
	+ using gh
	+ apply (intro E.eval_eqI) by simp_all
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis
	+ using gh whisker_can_left_0 by simp
	+ qed
	+ moreover have "\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
	+ g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
	+ proof -
	+ have "\<a>[g, tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[g \<star> tab\<^sub>0 g \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ ((\<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1] \<star> TfTgh.p\<^sub>0) \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[(g \<star> tab\<^sub>0 g) \<star> Tgh.p\<^sub>1, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g \<star> tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] =
	+ \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ ((\<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[(\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using gh g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' \<a>'_def \<alpha>_def by simp
	+ also have "... = \<lbrace>\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 g\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>1\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ apply (intro E.eval_eqI) by simp_all
	+ also have "... = g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
	+ using gh g\<^sub>0h\<^sub>1.p\<^sub>1_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI' \<a>'_def \<alpha>_def by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (g \<star>
	+ (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>)
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>
	+ \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
	+ ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[g, tab\<^sub>0 g, Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g.tab \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<beta>\<^sub>g"
	+ proof -
	+ have "arr ((h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
	+ ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])"
	+ using gh f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
	+ apply (intro seqI) by auto
	+ moreover
	+ have "arr ((can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
	+ ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])"
	+ using calculation by blast
	+ moreover
	+ have "arr (((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])"
	+ using calculation by blast
	+ moreover
	+ have "arr ((g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])"
	+ using calculation by blast
	+ ultimately
	+ have "(g \<star> h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (g \<star> can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
	+ (g \<star> (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g \<star> g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g \<star> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) =
	+ g \<star>
	+ (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
	+ ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
	+ using whisker_left by simp (* 20 sec *)
	+ thus ?thesis by simp
	+ qed
	+ also have "... = g.composite_cell w\<^sub>g' \<theta>\<^sub>g' \<cdot> \<beta>\<^sub>g"
	+ unfolding w\<^sub>g'_def \<theta>\<^sub>g'_def
	+ using comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ have 6: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>g \<Rightarrow> w\<^sub>g'\<guillemotright> \<and> \<beta>\<^sub>g = tab\<^sub>1 g \<star> \<gamma> \<and> \<theta>\<^sub>g = \<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>)"
	+ using w\<^sub>g w\<^sub>g' \<theta>\<^sub>g \<theta>\<^sub>g' \<beta>\<^sub>g eq\<^sub>g g.T2 [of w\<^sub>g w\<^sub>g' \<theta>\<^sub>g u\<^sub>g \<theta>\<^sub>g' \<beta>\<^sub>g] by blast
	+ obtain \<gamma>\<^sub>g where \<gamma>\<^sub>g: "\<guillemotleft>\<gamma>\<^sub>g : w\<^sub>g \<Rightarrow> w\<^sub>g'\<guillemotright> \<and> \<beta>\<^sub>g = tab\<^sub>1 g \<star> \<gamma>\<^sub>g \<and> \<theta>\<^sub>g = \<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g)"
	+ using 6 by auto
	+ show "\<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "iso \<gamma>\<^sub>g"
	+ using \<gamma>\<^sub>g BS3 w\<^sub>g_is_map w\<^sub>g'_is_map by blast
	+ hence "isomorphic w\<^sub>g w\<^sub>g'"
	+ using \<gamma>\<^sub>g isomorphic_def isomorphic_symmetric by auto
	+ thus ?thesis
	+ using w\<^sub>g w\<^sub>g' w\<^sub>g_def w\<^sub>g'_def Maps.CLS_eqI by auto
	+ qed
	+
	+ text \<open>Now the last equation: similar, but somewhat simpler.\<close>
	+ define u\<^sub>h where "u\<^sub>h = tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
	+ define w\<^sub>h where "w\<^sub>h = TTfgh.p\<^sub>0"
	+ define w\<^sub>h' where "w\<^sub>h' = Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
	+ define \<theta>\<^sub>h
	+ where "\<theta>\<^sub>h = tab\<^sub>0 h \<star> TTfgh.p\<^sub>0"
	+ define \<theta>\<^sub>h'
	+ where "\<theta>\<^sub>h' = TTfgh_TfTgh.the_\<theta> \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
	+ define \<beta>\<^sub>h
	+ where "\<beta>\<^sub>h = \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ have u\<^sub>h: "ide u\<^sub>h"
	+ unfolding u\<^sub>h_def by simp
	+ have w\<^sub>h: "ide w\<^sub>h"
	+ unfolding w\<^sub>h_def by simp
	+ have w\<^sub>h_is_map: "is_left_adjoint w\<^sub>h"
	+ unfolding w\<^sub>h_def by simp
	+ have w\<^sub>h': "ide w\<^sub>h'"
	+ unfolding w\<^sub>h'_def by simp
	+ have w\<^sub>h'_is_map: "is_left_adjoint w\<^sub>h'"
	+ unfolding w\<^sub>h'_def
	+ using g\<^sub>0h\<^sub>1.p\<^sub>0_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps TTfgh_TfTgh.is_map left_adjoints_compose by simp
	+ have \<theta>\<^sub>h: "\<guillemotleft>\<theta>\<^sub>h : tab\<^sub>0 h \<star> w\<^sub>h \<Rightarrow> u\<^sub>h\<guillemotright>"
	+ unfolding \<theta>\<^sub>h_def w\<^sub>h_def u\<^sub>h_def by auto
	+ have \<theta>\<^sub>h': "\<guillemotleft>\<theta>\<^sub>h' : tab\<^sub>0 h \<star> w\<^sub>h' \<Rightarrow> u\<^sub>h\<guillemotright>"
	+ unfolding \<theta>\<^sub>h'_def w\<^sub>h'_def u\<^sub>h_def
	+ using g\<^sub>0h\<^sub>1.p\<^sub>0_simps f\<^sub>0gh\<^sub>1.p\<^sub>0_simps hseqI'
	+ by (intro comp_in_homI, auto)
	+ have \<beta>\<^sub>h: "\<guillemotleft>\<beta>\<^sub>h : tab\<^sub>1 h \<star> w\<^sub>h \<Rightarrow> tab\<^sub>1 h \<star> w\<^sub>h'\<guillemotright>"
	+ proof (unfold \<beta>\<^sub>h_def w\<^sub>h_def w\<^sub>h'_def, intro comp_in_homI)
	+ (* auto can solve this, but it's too slow *)
	+ show "\<guillemotleft>inv fg\<^sub>0h\<^sub>1.\<phi> : tab\<^sub>1 h \<star> TTfgh.p\<^sub>0 \<Rightarrow> (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.\<phi>_uniqueness by blast
	+ show "\<guillemotleft>\<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] :
	+ (tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 g \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
	+ show "\<guillemotleft>tab\<^sub>0 g \<star> \<gamma>\<^sub>g :
	+ tab\<^sub>0 g \<star> Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1 \<Rightarrow> tab\<^sub>0 g \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using \<gamma>\<^sub>g w\<^sub>g_def w\<^sub>g'_def fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
	+ show "\<guillemotleft>\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] :
	+ tab\<^sub>0 g \<star> Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> (tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
	+ show "\<guillemotleft>g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine :
	+ (tab\<^sub>0 g \<star> Tgh.p\<^sub>1) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> (tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by force
	+ show "\<guillemotleft>\<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] :
	+ (tab\<^sub>1 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine
	+ \<Rightarrow> tab\<^sub>1 h \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<guillemotright>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps by auto
	+ qed
	+ have eq\<^sub>h: "h.composite_cell w\<^sub>h \<theta>\<^sub>h = h.composite_cell w\<^sub>h' \<theta>\<^sub>h' \<cdot> \<beta>\<^sub>h"
	+ proof -
	+ text \<open>
	+ Once again, the strategy is to form the subexpression
	+ \[
	+ \<open>\<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]\<close>
	+ \]
	+ which is equal to \<open>\<theta>\<^sub>g\<close>, so that we can make use of the equation \<open>\<theta>\<^sub>g = \<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g)\<close>.
	+ \<close>
	+ have "h.composite_cell w\<^sub>h \<theta>\<^sub>h =
	+ (h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0)"
	+ unfolding w\<^sub>h_def \<theta>\<^sub>h_def by simp
	+ also have "... = \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0)"
	+ proof -
	+ have "(h \<star> tab\<^sub>0 h \<star> TTfgh.p\<^sub>0) \<cdot> \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] = \<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0]"
	+ using comp_cod_arr by simp
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = (\<a>[h, tab\<^sub>0 h, TTfgh.p\<^sub>0] \<cdot> (h.tab \<star> TTfgh.p\<^sub>0) \<cdot>
	+ fg\<^sub>0h\<^sub>1.\<phi> \<cdot> \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ proof -
	+ have "(h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> (\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi> =
	+ (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> ((tab\<^sub>0 g \<star> Tfg.p\<^sub>0) \<star> TTfgh.p\<^sub>1) \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' comp_assoc_assoc' by simp
	+ also have "... = (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ using fg\<^sub>0h\<^sub>1.p\<^sub>1_simps hseqI' fg\<^sub>0h\<^sub>1.\<phi>_uniqueness comp_cod_arr by simp
	+ also have "... = (h.tab \<star> TTfgh.p\<^sub>0) \<cdot> (tab\<^sub>1 h \<star> TTfgh.p\<^sub>0)"
	+ using comp_arr_inv' fg\<^sub>0h\<^sub>1.\<phi>_uniqueness by simp
	+ also have "... = h.tab \<star> TTfgh.p\<^sub>0"
	+ using comp_arr_dom fg\<^sub>0h\<^sub>1.p\<^sub>0_simps hseqI' by simp
	+ finally have "(h.tab \<star> TTfgh.p\<^sub>0) \<cdot> fg\<^sub>0h\<^sub>1.\<phi> \<cdot> (\<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1]) \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi> =
	+ h.tab \<star> TTfgh.p\<^sub>0"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<theta>\<^sub>g \<cdot> \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ unfolding \<theta>\<^sub>g_def by simp
	+ also have "... = (\<theta>\<^sub>g' \<cdot> (tab\<^sub>0 g \<star> \<gamma>\<^sub>g)) \<cdot> \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot> inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ using \<gamma>\<^sub>g by simp
	+ also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ unfolding \<theta>\<^sub>g'_def
	+ using comp_assoc by simp
	+ also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ proof -
	+ have "(\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) =
	+ (h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
	+ using comp_cod_arr hseqI' comp_assoc_assoc' by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (\<a>[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ ((h.tab \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ using comp_assoc by presburger
	+ also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ using assoc_naturality [of h.tab Tgh.p\<^sub>0 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"] comp_assoc
	+ by simp
	+ also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ ((\<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine)) \<cdot>
	+ \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ proof -
	+ have "(\<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) =
	+ h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
	+ using comp_cod_arr hseqI' comp_assoc_assoc' by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine])) \<cdot>
	+ \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ using comp_assoc by presburger
	+ also have "... = ((h \<star> TTfgh_TfTgh.the_\<theta>) \<cdot>
	+ (h \<star> can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>))) \<cdot>
	+ \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ proof -
	+ have "can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) =
	+ can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using \<a>'_def \<alpha>_def by simp
	+ also have "... = can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ can (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ proof -
	+ have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace> =
	+ can (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ unfolding can_def
	+ apply (intro E.eval_eqI) by simp_all
	+ thus ?thesis by simp
	+ qed
	+ also have "... = can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ by simp
	+ also have "... = h \<star> can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ using whisker_can_left_0 by simp
	+ finally have "can (\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (((\<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[h \<star> tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) =
	+ h \<star> can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (h \<star> TTfgh_TfTgh.the_\<theta> \<cdot>
	+ can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)) \<cdot>
	+ \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ using whisker_left [of h] comp_assoc by simp
	+ also have "... = (h \<star> TTfgh_TfTgh.the_\<theta> \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]) \<cdot>
	+ \<a>[h, tab\<^sub>0 h, Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (h.tab \<star> Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>[tab\<^sub>1 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (g\<^sub>0h\<^sub>1.\<phi> \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 g, Tgh.p\<^sub>1, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine] \<cdot>
	+ (tab\<^sub>0 g \<star> \<gamma>\<^sub>g) \<cdot>
	+ \<a>[tab\<^sub>0 g, Tfg.p\<^sub>0, TTfgh.p\<^sub>1] \<cdot>
	+ inv fg\<^sub>0h\<^sub>1.\<phi>"
	+ proof -
	+ have "can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) =
	+ \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle>, \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>, \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ unfolding can_def
	+ apply (intro E.eval_eqI) by auto
	+ also have "... = \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
	+ using \<a>'_def \<alpha>_def by simp
	+ finally have "can (((\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>)
	+ (\<^bold>\<langle>tab\<^sub>0 h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>Tgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TfTgh.p\<^sub>0\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>TTfgh_TfTgh.chine\<^bold>\<rangle>) =
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h \<star> Tgh.p\<^sub>0, TfTgh.p\<^sub>0, TTfgh_TfTgh.chine] \<cdot>
	+ \<a>\<^sup>-\<^sup>1[tab\<^sub>0 h, Tgh.p\<^sub>0, TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine]"
	+ by simp
	+ thus ?thesis by simp
	+ qed
	+ also have "... = h.composite_cell w\<^sub>h' \<theta>\<^sub>h' \<cdot> \<beta>\<^sub>h"
	+ unfolding w\<^sub>h'_def \<theta>\<^sub>h'_def \<beta>\<^sub>h_def
	+ using comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ have 7: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>h \<Rightarrow> w\<^sub>h'\<guillemotright> \<and> \<beta>\<^sub>h = tab\<^sub>1 h \<star> \<gamma> \<and> \<theta>\<^sub>h = \<theta>\<^sub>h' \<cdot> (tab\<^sub>0 h \<star> \<gamma>)"
	+ using w\<^sub>h w\<^sub>h' \<theta>\<^sub>h \<theta>\<^sub>h' \<beta>\<^sub>h eq\<^sub>h h.T2 [of w\<^sub>h w\<^sub>h' \<theta>\<^sub>h u\<^sub>h \<theta>\<^sub>h' \<beta>\<^sub>h] by blast
	+ obtain \<gamma>\<^sub>h where \<gamma>\<^sub>h: "\<guillemotleft>\<gamma>\<^sub>h : w\<^sub>h \<Rightarrow> w\<^sub>h'\<guillemotright> \<and> \<beta>\<^sub>h = tab\<^sub>1 h \<star> \<gamma>\<^sub>h \<and> \<theta>\<^sub>h = \<theta>\<^sub>h' \<cdot> (tab\<^sub>0 h \<star> \<gamma>\<^sub>h)"
	+ using 7 by auto
	+ show "\<lbrakk>\<lbrakk>Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "iso \<gamma>\<^sub>h"
	+ using \<gamma>\<^sub>h BS3 w\<^sub>h_is_map w\<^sub>h'_is_map by blast
	+ hence "isomorphic w\<^sub>h w\<^sub>h'"
	+ using \<gamma>\<^sub>h isomorphic_def isomorphic_symmetric by auto
	+ thus ?thesis
	+ using w\<^sub>h w\<^sub>h' w\<^sub>h_def w\<^sub>h'_def Maps.CLS_eqI [of w\<^sub>h w\<^sub>h'] by simp
	+ qed
	+ qed
	+
	+ text \<open>
	+ Finally, we can show that @{term TTfgh_TfTgh.chine} is given by tupling.
	+ \<close>
	+
	+ lemma CLS_chine:
	+ shows "\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = tuple_ABC"
	+ proof -
	+ have "tuple_ABC = SPN_fgh.chine_assoc"
	+ using SPN_fgh.chine_assoc_def by simp
	+ also have "... = \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof (intro Maps.arr_eqI)
	+ show "Maps.arr SPN_fgh.chine_assoc"
	+ using SPN_fgh.chine_assoc_in_hom by auto
	+ show "Maps.arr \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using Maps.CLS_in_hom TTfgh_TfTgh.is_map by blast
	+ show "Maps.Dom SPN_fgh.chine_assoc = Maps.Dom \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using SPN_fgh.chine_assoc_def Maps.dom_char tuple_ABC_in_hom TTfgh_TfTgh.chine_in_hom
	+ by fastforce
	+ show "Maps.Cod SPN_fgh.chine_assoc = Maps.Cod \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "Maps.Cod SPN_fgh.chine_assoc = Maps.Cod tuple_ABC"
	+ using SPN_fgh.chine_assoc_def by simp
	+ also have "... = src (prj\<^sub>0 (tab\<^sub>1 g \<star> prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)) (tab\<^sub>0 f))"
	+ by (metis (lifting) Maps.Dom.simps(1) Maps.seq_char SPN_fgh.prj_chine_assoc(1)
	+ SPN_fgh.prj_simps(1) calculation f\<^sub>0gh\<^sub>1.leg1_simps(3) prj_char(4))
	+ also have "... = Maps.Cod \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using Maps.cod_char TTfgh_TfTgh.chine_in_hom by simp
	+ finally show ?thesis by blast
	+ qed
	+ show "Maps.Map SPN_fgh.chine_assoc = Maps.Map \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have 0: "Chn (Span.hcomp (SPN f) (Span.hcomp (SPN g) (SPN h))) =
	+ Maps.MkIde (src TfTgh.p\<^sub>0)"
	+ using fg gh
	+ by (metis (mono_tags, lifting) Maps.in_homE Maps.seqE SPN_fgh.prj_chine_assoc(1)
	+ SPN_fgh.prj_simps(1) SPN_fgh.prj_simps(13) calculation tuple_ABC_in_hom)
	+ have "tuple_ABC = \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof (intro Maps.prj_joint_monic
	+ [of SPN_fgh.\<mu>.leg0 "SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1"
	+ tuple_ABC "\<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"])
	+ show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
	+ using SPN_fgh.\<nu>\<pi>.dom.is_span SPN_fgh.\<nu>\<pi>.leg1_composite SPN_fgh.cospan_\<mu>\<nu>
	+ by auto
	+ show "Maps.seq SPN_fgh.Prj\<^sub>1 tuple_ABC"
	+ using 0 tuple_ABC_in_hom SPN_fgh.prj_in_hom(4) by auto
	+ show "Maps.seq SPN_fgh.Prj\<^sub>1 \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof
	+ show "Maps.in_hom \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>src TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
	+ \<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using fg gh TTfgh_TfTgh.chine_in_hom Maps.CLS_in_hom TTfgh_TfTgh.is_map
	+ by blast
	+ show "Maps.in_hom SPN_fgh.Prj\<^sub>1 \<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> SPN_fgh.\<mu>.apex"
	+ proof
	+ show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
	+ using SPN_fgh.prj_in_hom(4) by blast
	+ show "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
	+ Maps.pbdom SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
	+ proof -
	+ have "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = Maps.MkIde (src TfTgh.p\<^sub>0)"
	+ by simp
	+ also have "... = Maps.pbdom SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
	+ using 0 Maps.pbdom_def SPN_fgh.chine_composite(2) by presburger
	+ finally show ?thesis by blast
	+ qed
	+ show "SPN_fgh.\<mu>.apex = Maps.dom SPN_fgh.\<mu>.leg0"
	+ using SPN_f.dom.apex_def by blast
	+ qed
	+ qed
	+ have 2: "Maps.commutative_square SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1
	+ SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
	+ proof
	+ show "Maps.cospan SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1"
	+ using SPN_fgh.\<nu>\<pi>.legs_form_cospan(1) by simp
	+ show "Maps.span SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0"
	+ using SPN_fgh.prj_simps(2-3,5-6) by presburger
	+ show "Maps.dom SPN_fgh.\<nu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>0\<^sub>1"
	+ using SPN_fgh.prj_simps(8) SPN_g.dom.is_span SPN_g.dom.leg_simps(2)
	+ by auto
	+ show "SPN_fgh.\<nu>.leg0 \<odot> SPN_fgh.Prj\<^sub>0\<^sub>1 = SPN_fgh.\<pi>.leg1 \<odot> SPN_fgh.Prj\<^sub>0"
	+ by (metis (no_types, lifting) Maps.cod_comp Maps.comp_assoc
	+ Maps.pullback_commutes' SPN_fgh.\<mu>\<nu>.dom.leg_simps(1)
	+ SPN_fgh.\<mu>\<nu>.leg0_composite SPN_fgh.cospan_\<nu>\<pi>)
	+ qed
	+ have 1: "Maps.commutative_square
	+ SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1)
	+ SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
	+ proof
	+ show "Maps.cospan SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
	+ using fg gh SPN_fgh.prj_simps(10) by blast
	+ show "Maps.span SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC"
	+ using fg gh csq(2) by blast
	+ show "Maps.dom SPN_fgh.\<mu>.leg0 = Maps.cod SPN_fgh.Prj\<^sub>1\<^sub>1"
	+ using fg gh SPN_f.dom.leg_simps(2) SPN_fgh.prj_simps(7) by auto
	+ show "SPN_fgh.\<mu>.leg0 \<odot> SPN_fgh.Prj\<^sub>1\<^sub>1 =
	+ (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_BC"
	+ using 2 fg gh Maps.comp_assoc csq(2)
	+ Maps.prj_tuple [of SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 SPN_fgh.Prj\<^sub>0\<^sub>1 SPN_fgh.Prj\<^sub>0]
	+ by blast
	+ qed
	+ show "SPN_fgh.Prj\<^sub>1 \<odot> tuple_ABC = SPN_fgh.Prj\<^sub>1 \<odot> Maps.CLS TTfgh_TfTgh.chine"
	+ proof -
	+ have "SPN_fgh.Prj\<^sub>1 \<odot> tuple_ABC = SPN_fgh.Prj\<^sub>1\<^sub>1"
	+ using csq(2) by simp
	+ also have "... = \<lbrakk>\<lbrakk>Tfg.p\<^sub>1 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ using prj_char by simp
	+ also have "... = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using prj_chine(1) by simp
	+ also have "... = \<lbrakk>\<lbrakk>TfTgh.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "is_left_adjoint TfTgh.p\<^sub>1"
	+ by (simp add: fg)
	+ moreover have "is_left_adjoint TTfgh_TfTgh.chine"
	+ using TTfgh_TfTgh.is_map by simp
	+ moreover have "TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine \<cong> TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"
	+ using fg gh isomorphic_reflexive by simp
	+ ultimately show ?thesis
	+ using Maps.comp_CLS
	+ [of TfTgh.p\<^sub>1 TTfgh_TfTgh.chine "TfTgh.p\<^sub>1 \<star> TTfgh_TfTgh.chine"]
	+ by simp
	+ qed
	+ finally show ?thesis
	+ using prj_char by simp
	+ qed
	+ show
	+ "Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_ABC =
	+ Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have
	+ "Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot> tuple_ABC =
	+ tuple_BC"
	+ using csq(2)
	+ Maps.prj_tuple [of SPN_fgh.\<mu>.leg0 "SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1"
	+ SPN_fgh.Prj\<^sub>1\<^sub>1 tuple_BC]
	+ by simp
	+ also have "... =
	+ Maps.comp
	+ (Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (Maps.comp SPN_fgh.\<nu>.leg1 SPN_fgh.\<nu>\<pi>.prj\<^sub>1))
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof (intro Maps.prj_joint_monic
	+ [of SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 tuple_BC
	+ "Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"])
	+ show "Maps.cospan SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1"
	+ using SPN_fgh.\<nu>\<pi>.legs_form_cospan(1) by simp
	+ show "Maps.seq SPN_fgh.\<nu>\<pi>.prj\<^sub>1 tuple_BC"
	+ proof
	+ show "Maps.in_hom tuple_BC
	+ (Maps.MkIde (src TTfgh.p\<^sub>0)) (Maps.MkIde (src Tgh.p\<^sub>0))"
	+ using tuple_BC_in_hom by simp
	+ show "Maps.in_hom SPN_fgh.\<nu>\<pi>.prj\<^sub>1 (Maps.MkIde (src Tgh.p\<^sub>0)) SPN_fgh.\<nu>.apex"
	+ proof -
	+ have "Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 = Maps.MkIde (src Tgh.p\<^sub>0)"
	+ using fg gh Maps.pbdom_def
	+ by (metis (no_types, lifting) SPN.preserves_ide SPN_fgh.\<nu>\<pi>.are_identities(2)
	+ SPN_fgh.\<nu>\<pi>.composable Span.chine_hcomp_ide_ide Tgh.chine_hcomp_SPN_SPN
	+ g.is_ide)
	+ thus ?thesis
	+ using SPN_fgh.\<nu>\<pi>.prj_in_hom(1) by simp
	+ qed
	+ qed
	+ show "Maps.seq SPN_fgh.\<nu>\<pi>.prj\<^sub>1
	+ (Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>)"
	+ proof
	+ show "Maps.in_hom SPN_fgh.\<nu>\<pi>.prj\<^sub>1
	+ (Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1) SPN_fgh.\<nu>.apex"
	+ using SPN_fgh.\<nu>\<pi>.prj_in_hom(1) by simp
	+ show "Maps.in_hom
	+ (Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>)
	+ \<lbrakk>\<lbrakk>src TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
	+ (Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1)"
	+ proof
	+ show "Maps.in_hom \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> \<lbrakk>\<lbrakk>src TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
	+ \<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using fg gh TTfgh_TfTgh.chine_in_hom Maps.CLS_in_hom TTfgh_TfTgh.is_map
	+ by blast
	+ show "Maps.in_hom
	+ (Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1))
	+ \<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>
	+ (Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1)"
	+ proof
	+ show "Maps.cospan SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
	+ using SPN_fgh.prj_in_hom(4) by blast
	+ show "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
	+ Maps.pbdom SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
	+ proof -
	+ have "\<lbrakk>\<lbrakk>trg TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> = Maps.MkIde (src TfTgh.p\<^sub>0)"
	+ by simp
	+ also have "... = Maps.pbdom SPN_fgh.\<mu>.leg0
	+ (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
	+ using 0 Maps.pbdom_def SPN_fgh.chine_composite(2) by presburger
	+ finally show ?thesis by blast
	+ qed
	+ show "Maps.pbdom SPN_fgh.\<nu>.leg0 SPN_fgh.\<pi>.leg1 =
	+ Maps.dom (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1)"
	+ using fg gh Maps.pbdom_def SPN_fgh.\<nu>\<pi>.apex_composite
	+ SPN_fgh.\<nu>\<pi>.dom.apex_def SPN_fgh.\<nu>\<pi>.dom.is_span
	+ SPN_fgh.\<nu>\<pi>.leg1_composite
	+ by presburger
	+ qed
	+ qed
	+ qed
	+ show "SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot> tuple_BC =
	+ SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot>
	+ Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot> tuple_BC = SPN_fgh.Prj\<^sub>0"
	+ using csq(1) by simp
	+ also have "... = SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot>
	+ Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "SPN_fgh.\<nu>\<pi>.prj\<^sub>0 \<odot>
	+ Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
	+ \<lbrakk>\<lbrakk>Tgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char(1) isomorphic_reflexive
	+ Maps.comp_CLS [of "tab\<^sub>1 g" "prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)" "tab\<^sub>1 g \<star> Tgh.p\<^sub>1"]
	+ by simp
	+ also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using fg gh TTfgh_TfTgh.is_map isomorphic_reflexive
	+ Maps.comp_CLS
	+ [of TfTgh.p\<^sub>0 TTfgh_TfTgh.chine "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
	+ by simp
	+ also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using fg gh TTfgh_TfTgh.is_map left_adjoints_compose isomorphic_reflexive
	+ Maps.comp_CLS [of Tgh.p\<^sub>0 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
	+ "Tgh.p\<^sub>0 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
	+ by simp
	+ also have "... = \<lbrakk>\<lbrakk>TTfgh.p\<^sub>0\<rbrakk>\<rbrakk>"
	+ using prj_chine(3) by simp
	+ also have "... = SPN_fgh.Prj\<^sub>0"
	+ using prj_char by simp
	+ finally show ?thesis by argo
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ show "SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot> tuple_BC =
	+ SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot>
	+ Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot> tuple_BC = SPN_fgh.Prj\<^sub>0\<^sub>1"
	+ using csq(1) by simp
	+ also have "... = SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot>
	+ Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "SPN_fgh.\<nu>\<pi>.prj\<^sub>1 \<odot>
	+ Maps.PRJ\<^sub>0 SPN_fgh.\<mu>.leg0 (SPN_fgh.\<nu>.leg1 \<odot> SPN_fgh.\<nu>\<pi>.prj\<^sub>1) \<odot>
	+ \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk> =
	+ \<lbrakk>\<lbrakk>Tgh.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using fg gh Tgh.\<rho>\<sigma>.prj_char TfTgh.prj_char(1) isomorphic_reflexive
	+ Maps.comp_CLS [of "tab\<^sub>1 g" "prj\<^sub>1 (tab\<^sub>1 h) (tab\<^sub>0 g)" "tab\<^sub>1 g \<star> Tgh.p\<^sub>1"]
	+ by simp
	+ also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using fg gh TTfgh_TfTgh.is_map isomorphic_reflexive
	+ Maps.comp_CLS
	+ [of TfTgh.p\<^sub>0 TTfgh_TfTgh.chine "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
	+ by simp
	+ also have "... = \<lbrakk>\<lbrakk>Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using fg gh TTfgh_TfTgh.is_map left_adjoints_compose isomorphic_reflexive
	+ Maps.comp_CLS [of Tgh.p\<^sub>1 "TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"
	+ "Tgh.p\<^sub>1 \<star> TfTgh.p\<^sub>0 \<star> TTfgh_TfTgh.chine"]
	+ by simp
	+ also have "... = \<lbrakk>\<lbrakk>Tfg.p\<^sub>0 \<star> TTfgh.p\<^sub>1\<rbrakk>\<rbrakk>"
	+ using prj_chine(2) by simp
	+ also have "... = SPN_fgh.Prj\<^sub>0\<^sub>1"
	+ using prj_char by simp
	+ finally show ?thesis by argo
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using SPN_fgh.chine_assoc_def by simp
	+ qed
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ text \<open>
	+ At long last, we can show associativity coherence for \<open>SPN\<close>.
	+ \<close>
	+
	+ lemma assoc_coherence:
	+ shows "LHS = RHS"
	+ proof (intro Span.arr_eqI)
	+ show "Span.par LHS RHS"
	+ using par_LHS_RHS by blast
	+ show "Chn LHS = Chn RHS"
	+ proof -
	+ have "Chn LHS = \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
	+ using Chn_LHS_eq by simp
	+ also have "... = \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "\<lbrakk>\<lbrakk>THfgh_HHfgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_THfgh.chine\<rbrakk>\<rbrakk> =
	+ \<lbrakk>\<lbrakk>THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
	+ using fg gh isomorphic_reflexive HHfgh_HfHgh.is_map THfgh_HHfgh.is_map
	+ TTfgh_THfgh.is_map left_adjoints_compose
	+ Maps.comp_CLS
	+ [of THfgh_HHfgh.chine TTfgh_THfgh.chine "THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"]
	+ by simp
	+ moreover
	+ have "\<lbrakk>\<lbrakk>HHfgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk> =
	+ \<lbrakk>\<lbrakk>HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "ide (HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine)"
	+ proof -
	+ have "ide (THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine)"
	+ using fg gh HHfgh_HfHgh.is_map THfgh_HHfgh.is_map TTfgh_THfgh.is_map
	+ left_adjoint_is_ide left_adjoints_compose
	+ by auto
	+ moreover have "src HHfgh_HfHgh.chine = trg (THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine)"
	+ using fg gh HHfgh_HfHgh.chine_in_hom \<alpha>_def by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using fg gh isomorphic_reflexive HHfgh_HfHgh.is_map THfgh_HHfgh.is_map
	+ TTfgh_THfgh.is_map left_adjoints_compose
	+ Maps.comp_CLS
	+ [of HHfgh_HfHgh.chine "THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"
	+ "HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"]
	+ by auto
	+ qed
	+ ultimately show ?thesis by argo
	+ qed
	+ also have "... = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ proof -
	+ interpret A: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
	+ \<open>f \<star> g \<star> h\<close> TfTgh.tab \<open>(tab\<^sub>0 h \<star> Tgh.p\<^sub>0) \<star> TfTgh.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfTgh.p\<^sub>1\<close>
	+ \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>\<a>[f, g, h]\<close> \<open>f \<star> g \<star> h\<close>
	+ ..
	+ interpret B: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
	+ \<open>f \<star> g \<star> h\<close> TfHgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 (g \<star> h) \<star> TfHgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 f \<star> TfHgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>f \<star> g \<star> h\<close> HfHgh.tab \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
	+ \<open>\<a>[f, g, h]\<close> \<open>f \<star> g \<star> h\<close>
	+ using fg gh by (unfold_locales, auto)
	+ interpret C: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>(f \<star> g) \<star> h\<close> HHfgh.tab \<open>tab\<^sub>0 ((f \<star> g) \<star> h)\<close> \<open>tab\<^sub>1 ((f \<star> g) \<star> h)\<close>
	+ \<open>f \<star> g \<star> h\<close> HfHgh.tab \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
	+ \<open>(f \<star> g) \<star> h\<close> \<open>\<a>[f, g, h]\<close>
	+ using fg gh by (unfold_locales, auto)
	+ interpret D: vertical_composite_of_arrows_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>(f \<star> g) \<star> h\<close> TTfgh.tab \<open>tab\<^sub>0 h \<star> TTfgh.p\<^sub>0\<close> \<open>(tab\<^sub>1 f \<star> Tfg.p\<^sub>1) \<star> TTfgh.p\<^sub>1\<close>
	+ \<open>(f \<star> g) \<star> h\<close> THfgh.\<rho>\<sigma>.tab \<open>tab\<^sub>0 h \<star> THfgh.\<rho>\<sigma>.p\<^sub>0\<close> \<open>tab\<^sub>1 (f \<star> g) \<star> THfgh.\<rho>\<sigma>.p\<^sub>1\<close>
	+ \<open>f \<star> g \<star> h\<close> HfHgh.tab \<open>tab\<^sub>0 (f \<star> g \<star> h)\<close> \<open>tab\<^sub>1 (f \<star> g \<star> h)\<close>
	+ \<open>(f \<star> g) \<star> h\<close> \<open>\<a>[f, g, h]\<close>
	+ using fg gh by (unfold_locales, auto)
	+ have "HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine \<cong> D.chine"
	+ proof -
	+ have "D.chine \<cong> D.\<pi>.chine \<star> TTfgh_THfgh.chine"
	+ using D.chine_char by simp
	+ also have "... \<cong> C.chine \<star> TTfgh_THfgh.chine"
	+ using fg gh comp_arr_dom isomorphic_reflexive by simp
	+ also have "... \<cong> (C.\<pi>.chine \<star> THfgh_HHfgh.chine) \<star> TTfgh_THfgh.chine"
	+ using C.chine_char hcomp_isomorphic_ide by simp
	+ also have "... \<cong> (HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine) \<star> TTfgh_THfgh.chine"
	+ proof -
	+ have "C.\<pi>.chine = HHfgh_HfHgh.chine"
	+ using fg gh comp_arr_dom comp_cod_arr \<alpha>_def by simp
	+ hence "isomorphic C.\<pi>.chine HHfgh_HfHgh.chine"
	+ using isomorphic_reflexive by simp
	+ thus ?thesis
	+ using hcomp_isomorphic_ide by simp
	+ qed
	+ also have "... \<cong> HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine"
	+ proof -
	+ have "ide HHfgh_HfHgh.chine \<and> ide THfgh_HHfgh.chine \<and> ide TTfgh_THfgh.chine"
	+ by simp
	+ moreover have "src HHfgh_HfHgh.chine = trg THfgh_HHfgh.chine \<and>
	+ src THfgh_HHfgh.chine = trg TTfgh_THfgh.chine"
	+ using fg gh HHfgh_HfHgh.chine_in_hom THfgh_HHfgh.chine_in_hom
	+ TTfgh_THfgh.chine_in_hom \<alpha>_def
	+ by auto
	+ ultimately show ?thesis
	+ using fg gh iso_assoc isomorphic_def
	+ assoc_in_hom [of HHfgh_HfHgh.chine THfgh_HHfgh.chine TTfgh_THfgh.chine]
	+ by auto
	+ qed
	+ finally show ?thesis
	+ using isomorphic_symmetric by blast
	+ qed
	+ also have "... \<cong> B.chine"
	+ proof -
	+ have "D.chine = B.chine"
	+ using fg gh comp_arr_dom comp_cod_arr by simp
	+ thus ?thesis
	+ using isomorphic_reflexive by simp
	+ qed
	+ also have "... \<cong> TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
	+ proof -
	+ have "B.chine \<cong> TfHgh_HfHgh.chine \<star> B.\<mu>.chine"
	+ using B.chine_char by simp
	+ also have "... \<cong> TfHgh_HfHgh.chine \<star> A.chine"
	+ using fg gh comp_cod_arr isomorphic_reflexive by simp
	+ also have "... \<cong> TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
	+ using A.chine_char hcomp_ide_isomorphic by simp
	+ finally show ?thesis by blast
	+ qed
	+ finally have "HHfgh_HfHgh.chine \<star> THfgh_HHfgh.chine \<star> TTfgh_THfgh.chine \<cong>
	+ TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
	+ by blast
	+ thus ?thesis
	+ using fg gh Maps.CLS_eqI isomorphic_implies_hpar(1) by blast
	+ qed
	+ also have "... = \<lbrakk>\<lbrakk>TfHgh_HfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TfTgh_TfHgh.chine\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>TTfgh_TfTgh.chine\<rbrakk>\<rbrakk>"
	+ using fg gh isomorphic_reflexive TfTgh_TfHgh.is_map TfHgh_HfHgh.is_map TTfgh_TfTgh.is_map
	+ left_adjoints_compose
	+ Maps.comp_CLS
	+ [of TfTgh_TfHgh.chine TTfgh_TfTgh.chine "TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"]
	+ Maps.comp_CLS
	+ [of TfHgh_HfHgh.chine "TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"
	+ "TfHgh_HfHgh.chine \<star> TfTgh_TfHgh.chine \<star> TTfgh_TfTgh.chine"]
	+ by simp
	+ also have "... = Chn RHS"
	+ using Chn_RHS_eq CLS_chine tuple_ABC_eq_ABC'(2) by simp
	+ finally show ?thesis
	+ by blast
	+ qed
	+ qed
	+
	+ end
	+
	+ subsubsection "SPN is an Equivalence Pseudofunctor"
	+
	+ context bicategory_of_spans
	+ begin
	+
	+ interpretation Maps: maps_category V H \<a> \<i> src trg ..
	+ interpretation Span: span_bicategory Maps.comp Maps.PRJ\<^sub>0 Maps.PRJ\<^sub>1 ..
	+
	+ no_notation Fun.comp (infixl "\<circ>" 55)
	+ notation Span.vcomp (infixr "\<bullet>" 55)
	+ notation Span.hcomp (infixr "\<circ>" 53)
	+ notation Maps.comp (infixr "\<odot>" 55)
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ interpretation SPN: "functor" V Span.vcomp SPN
	+ using SPN_is_functor by simp
	+ interpretation SPN: weak_arrow_of_homs V src trg Span.vcomp Span.src Span.trg SPN
	+ using SPN_is_weak_arrow_of_homs by simp
	+ interpretation SPN_SPN: "functor" VV.comp Span.VV.comp SPN.FF
	+ using SPN.functor_FF by auto
	+ interpretation HoSPN_SPN: composite_functor VV.comp Span.VV.comp Span.vcomp
	+ SPN.FF \<open>\<lambda>\<mu>\<nu>. Span.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
	+ ..
	+ interpretation SPNoH: composite_functor VV.comp V Span.vcomp
	+ \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> SPN
	+ ..
	+
	+ interpretation \<Phi>: transformation_by_components VV.comp Span.vcomp
	+ HoSPN_SPN.map SPNoH.map \<open>\<lambda>rs. CMP (fst rs) (snd rs)\<close>
	+ using compositor_is_natural_transformation by simp
	+ interpretation \<Phi>: natural_isomorphism VV.comp Span.vcomp
	+ HoSPN_SPN.map SPNoH.map \<Phi>.map
	+ using compositor_is_natural_isomorphism by simp
	+
	+ abbreviation \<Phi>
	+ where "\<Phi> \<equiv> \<Phi>.map"
	+
	+ interpretation SPN: pseudofunctor V H \<a> \<i> src trg
	+ Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>
	+ proof
	+ show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow>
	+ SPN \<a>[f, g, h] \<bullet> \<Phi> (f \<star> g, h) \<bullet> (\<Phi> (f, g) \<circ> SPN h) =
	+ \<Phi> (f, g \<star> h) \<bullet> (SPN f \<circ> \<Phi> (g, h)) \<bullet> Span.assoc (SPN f) (SPN g) (SPN h)"
	+ proof -
	+ fix f g h
	+ assume f: "ide f" and g: "ide g" and h: "ide h"
	+ assume fg: "src f = trg g" and gh: "src g = trg h"
	+ interpret fgh: three_composable_identities_in_bicategory_of_spans V H \<a> \<i> src trg f g h
	+ using f g h fg gh
	+ by (unfold_locales, simp)
	+ show "fgh.LHS = fgh.RHS"
	+ using fgh.assoc_coherence by simp
	+ qed
	+ qed
	+
	+ lemma SPN_is_pseudofunctor:
	+ shows "pseudofunctor V H \<a> \<i> src trg
	+ Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>"
	+ ..
	+
	+ interpretation SPN: equivalence_pseudofunctor V H \<a> \<i> src trg
	+ Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>
	+ proof
	+ show "\<And>\<mu> \<mu>'. \<lbrakk>par \<mu> \<mu>'; SPN \<mu> = SPN \<mu>'\<rbrakk> \<Longrightarrow> \<mu> = \<mu>'"
	+ proof -
	+ fix \<mu> \<mu>'
	+ assume par: "par \<mu> \<mu>'"
	+ assume eq: "SPN \<mu> = SPN \<mu>'"
	+ interpret dom_\<mu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close>
	+ using par apply unfold_locales by auto
	+ interpret cod_\<mu>: identity_in_bicategory_of_spans V H \<a> \<i> src trg \<open>cod \<mu>\<close>
	+ using par apply unfold_locales by auto
	+ interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom \<mu>\<close> \<open>tab_of_ide (dom \<mu>)\<close> \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
	+ \<open>cod \<mu>\<close> \<open>tab_of_ide (cod \<mu>)\<close> \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
	+ \<mu>
	+ using par apply unfold_locales by auto
	+ interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>
	+ using par apply unfold_locales by auto
	+ interpret \<mu>': arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ \<open>dom \<mu>\<close> \<open>tab_of_ide (dom \<mu>)\<close> \<open>tab\<^sub>0 (dom \<mu>)\<close> \<open>tab\<^sub>1 (dom \<mu>)\<close>
	+ \<open>cod \<mu>\<close> \<open>tab_of_ide (cod \<mu>)\<close> \<open>tab\<^sub>0 (cod \<mu>)\<close> \<open>tab\<^sub>1 (cod \<mu>)\<close>
	+ \<mu>'
	+ using par apply unfold_locales by auto
	+ interpret \<mu>': arrow_in_bicategory_of_spans V H \<a> \<i> src trg \<open>dom \<mu>\<close> \<open>cod \<mu>\<close> \<mu>'
	+ using par apply unfold_locales by auto
	+ have "\<mu>.chine \<cong> \<mu>'.chine"
	+ using par eq SPN_def spn_def Maps.CLS_eqI \<mu>.is_ide by auto
	+ hence "\<mu>.\<Delta> = \<mu>'.\<Delta>"
	+ using \<mu>.\<Delta>_naturality \<mu>'.\<Delta>_naturality
	+ by (metis \<mu>.\<Delta>_simps(4) \<mu>'.\<Delta>_simps(4) \<mu>.chine_is_induced_map \<mu>'.chine_is_induced_map
	+ \<mu>.induced_map_preserved_by_iso)
	+ thus "\<mu> = \<mu>'"
	+ using par \<mu>.\<mu>_in_terms_of_\<Delta> \<mu>'.\<mu>_in_terms_of_\<Delta> by metis
	+ qed
	+ show "\<And>a'. Span.obj a' \<Longrightarrow> \<exists>a. obj a \<and> Span.equivalent_objects (SPN.map\<^sub>0 a) a'"
	+ proof -
	+ fix a'
	+ assume a': "Span.obj a'"
	+ let ?a = "Maps.Dom (Chn a')"
	+ have a: "obj ?a"
	+ using a' Span.obj_char Span.ide_char Maps.ide_char by blast
	+ moreover have "Span.equivalent_objects (SPN.map\<^sub>0 ?a) a'"
	+ proof -
	+ have "SPN.map\<^sub>0 ?a = a'"
	+ proof (intro Span.arr_eqI)
	+ have "Chn (SPN.map\<^sub>0 ?a) = Chn (Span.src (SPN ?a))"
	+ using a a' by auto
	+ also have "... = Maps.MkIde (Maps.Dom (Chn a'))"
	+ proof -
	+ have "Maps.arr \<lbrakk>\<lbrakk>tab\<^sub>0 (dom (Maps.Dom (Chn a')))\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "is_left_adjoint (tab\<^sub>0 (dom (Maps.Dom (Chn a'))))"
	+ using a by auto
	+ thus ?thesis
	+ using Maps.CLS_in_hom by auto
	+ qed
	+ moreover have "arr (Maps.Dom (Chn a'))"
	+ using a by auto
	+ moreover have "Span.arr (SPN (Maps.Dom (Chn a')))"
	+ using a a' SPN_in_hom by auto
	+ ultimately show ?thesis
	+ using a a' SPN_def Span.src_def Maps.cod_char by simp
	+ qed
	+ also have "... = Chn a'"
	+ using a' Maps.MkIde_Dom Span.obj_char Span.ide_char by simp
	+ finally show "Chn (SPN.map\<^sub>0 ?a) = Chn a'" by simp
	+ show "Span.par (SPN.map\<^sub>0 (Maps.Dom (Chn a'))) a'"
	+ using a a' Span.obj_char
	+ apply (intro conjI)
	+ using SPN.map\<^sub>0_simps(1) Span.obj_def
	+ apply blast
	+ apply simp
	+ apply (metis (no_types, lifting) SPN.map\<^sub>0_def SPN.preserves_arr Span.obj_src
	+ \<open>Chn (SPN.map\<^sub>0 (Maps.Dom (Chn a'))) = Chn a'\<close> obj_def)
	+ by (metis (no_types, lifting) SPN.map\<^sub>0_def SPN.preserves_arr Span.obj_src
	+ \<open>Chn (SPN.map\<^sub>0 (Maps.Dom (Chn a'))) = Chn a'\<close> obj_def)
	+ qed
	+ thus ?thesis
	+ using Span.equivalent_objects_reflexive
	+ by (simp add: a')
	+ qed
	+ ultimately show "\<exists>a. obj a \<and> Span.equivalent_objects (SPN.map\<^sub>0 a) a'"
	+ by auto
	+ qed
	+ show "\<And>a b g. \<lbrakk>obj a; obj b; Span.in_hhom g (SPN.map\<^sub>0 a) (SPN.map\<^sub>0 b); Span.ide g\<rbrakk>
	+ \<Longrightarrow> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> Span.isomorphic (SPN f) g"
	+ proof -
	+ fix a b g
	+ assume a: "obj a" and b: "obj b"
	+ and g_in_hhom: "Span.in_hhom g (SPN.map\<^sub>0 a) (SPN.map\<^sub>0 b)"
	+ and ide_g: "Span.ide g"
	+ have arr_a: "arr a"
	+ using a by auto
	+ have arr_b: "arr b"
	+ using b by auto
	+ show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> Span.isomorphic (SPN f) g"
	+ proof -
	+ interpret g: arrow_of_spans Maps.comp g
	+ using ide_g Span.ide_char by blast
	+ interpret g: identity_arrow_of_spans Maps.comp g
	+ using ide_g Span.ide_char
	+ by (unfold_locales, auto)
	+ interpret REP_leg0: map_in_bicategory V H \<a> \<i> src trg \<open>Maps.REP g.leg0\<close>
	+ using Maps.REP_in_Map [of g.leg0]
	+ by (unfold_locales, auto)
	+ have 0: "\<guillemotleft>Maps.REP g.leg0 : src (Maps.REP g.apex) \<rightarrow> Maps.Cod g.leg0\<guillemotright>"
	+ using g.dom.leg_in_hom Maps.REP_in_hhom by force
	+ have 1: "\<guillemotleft>Maps.REP g.leg1 : src (Maps.REP g.apex) \<rightarrow> Maps.Cod g.leg1\<guillemotright>"
	+ using g.dom.leg_in_hom Maps.REP_in_hhom by force
	+ let ?f = "Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*"
	+ have f_in_hhom: "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>Maps.REP g.leg1 : src (Maps.REP g.apex) \<rightarrow> b\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>Maps.REP g.leg1 : src (Maps.REP g.apex) \<rightarrow> Maps.Cod g.leg1\<guillemotright>"
	+ using 1 by simp
	+ moreover have "Maps.Cod g.leg1 = b"
	+ proof -
	+ have "src (Maps.REP g.dtrg) = src (Maps.REP (Leg0 (Dom (SPN.map\<^sub>0 b))))"
	+ using g_in_hhom Span.trg_def [of g] by auto
	+ also have "... = src (Maps.REP (Maps.cod \<lbrakk>\<lbrakk>tab\<^sub>0 b\<rbrakk>\<rbrakk>))"
	+ using b arr_b SPN.map\<^sub>0_def Span.src_def SPN_in_hom by auto
	+ also have "... = src (Maps.REP \<lbrakk>\<lbrakk>trg (tab\<^sub>0 b)\<rbrakk>\<rbrakk>)"
	+ using b Maps.CLS_in_hom [of "tab\<^sub>0 b"] by force
	+ also have "... = src (Maps.REP \<lbrakk>\<lbrakk>b\<rbrakk>\<rbrakk>)"
	+ using b by fastforce
	+ also have "... = b"
	+ using b by auto
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis by argo
	+ qed
	+ show "\<guillemotleft>(Maps.REP g.leg0)\<^sup>* : a \<rightarrow> src (Maps.REP g.apex)\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>Maps.REP g.leg0 : src (Maps.REP g.apex) \<rightarrow> a\<guillemotright>"
	+ proof -
	+ have "src (Maps.REP g.dsrc) = src (Maps.REP (Leg0 (Dom (SPN.map\<^sub>0 a))))"
	+ using g_in_hhom Span.src_def [of g] by auto
	+ also have "... = src (Maps.REP (Maps.cod \<lbrakk>\<lbrakk>tab\<^sub>0 a\<rbrakk>\<rbrakk>))"
	+ using a arr_a SPN.map\<^sub>0_def Span.src_def SPN_in_hom by auto
	+ also have "... = src (Maps.REP \<lbrakk>\<lbrakk>trg (tab\<^sub>0 a)\<rbrakk>\<rbrakk>)"
	+ using a Maps.CLS_in_hom [of "tab\<^sub>0 a"] by force
	+ also have "... = src (Maps.REP \<lbrakk>\<lbrakk>a\<rbrakk>\<rbrakk>)"
	+ using a by fastforce
	+ also have "... = a"
	+ using a by auto
	+ finally show ?thesis by fast
	+ qed
	+ thus ?thesis
	+ using REP_leg0.antipar REP_leg0.ide_right
	+ apply (intro in_hhomI) by auto
	+ qed
	+ qed
	+ moreover have ide_f: "ide ?f"
	+ using REP_leg0.antipar f_in_hhom by fastforce
	+ moreover have "Span.isomorphic (SPN ?f) g"
	+ proof -
	+ have SPN_f_eq: "SPN ?f = \<lparr>Chn = \<lbrakk>\<lbrakk>spn ?f\<rbrakk>\<rbrakk>,
	+ Dom = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 ?f\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 ?f\<rbrakk>\<rbrakk>\<rparr>,
	+ Cod = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 ?f\<rbrakk>\<rbrakk>, Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 ?f\<rbrakk>\<rbrakk>\<rparr>\<rparr>"
	+ using calculation(1) SPN_def [of ?f] REP_leg0.antipar hseqI' by auto
	+ text \<open>
	+ We need an invertible arrow of spans from \<open>SPN f\<close> to \<open>g\<close>.
	+ There exists a tabulation \<open>(REP g.leg0, \<rho>, REP g.leg1)\<close> of \<open>f\<close>.
	+ There is also a tabulation \<open>(tab\<^sub>0 f, \<rho>', tab\<^sub>1 f) of f\<close>.
	+ As these are tabulations of the same arrow, they are equivalent.
	+ This yields an equivalence map which is an arrow of spans from
	+ \<open>(tab\<^sub>0 f, tab\<^sub>1 f)\<close> to \<open>(REP g.leg0, \<rho>, REP g.leg1)\<close>.
	+ Its isomorphism class is an invertible arrow of spans in maps
	+ from \<open>(CLS (tab\<^sub>0 f), CLS (tab\<^sub>1 f))\<close> to \<open>(g.leg0, g.leg1)\<close>.
	+ \<close>
	+ interpret f: identity_in_bicategory_of_spans V H \<a> \<i> src trg ?f
	+ using ide_f apply unfold_locales by auto
	+ interpret f: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ ?f f.tab \<open>tab\<^sub>0 ?f\<close> \<open>tab\<^sub>1 ?f\<close> ?f f.tab \<open>tab\<^sub>0 ?f\<close> \<open>tab\<^sub>1 ?f\<close> ?f
	+ using f.is_arrow_of_tabulations_in_maps by simp
	+ interpret g: span_of_maps V H \<a> \<i> src trg \<open>Maps.REP g.leg0\<close> \<open>Maps.REP g.leg1\<close>
	+ using Span.arr_char
	+ by (unfold_locales, blast+)
	+
	+ have 2: "src (Maps.REP g.leg0) = src (Maps.REP g.leg1)"
	+ using 0 1 by fastforce
	+ hence "\<exists>\<rho>. tabulation (\<cdot>) (\<star>) \<a> \<i> src trg ?f \<rho> (Maps.REP g.leg0) (Maps.REP g.leg1)"
	+ using BS2' [of "Maps.REP g.leg0" "Maps.REP g.leg1" ?f] isomorphic_reflexive
	+ Span.arr_char
	+ by auto
	+ hence "tabulation V H \<a> \<i> src trg ?f
	+ (REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f) (Maps.REP g.leg0) (Maps.REP g.leg1)"
	+ using 2 REP_leg0.canonical_tabulation [of "Maps.REP g.leg1"] by auto
	+ hence 3: "\<exists>w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'.
	+ equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg w' w \<psi> \<phi> \<and>
	+ \<guillemotleft>w : src (tab\<^sub>0 ?f) \<rightarrow> src (Maps.REP g.leg0)\<guillemotright> \<and>
	+ \<guillemotleft>w' : src (Maps.REP g.leg0) \<rightarrow> src (tab\<^sub>0 ?f)\<guillemotright> \<and>
	+ \<guillemotleft>\<theta> : Maps.REP g.leg0 \<star> w \<Rightarrow> tab\<^sub>0 ?f\<guillemotright> \<and>
	+ \<guillemotleft>\<nu> : tab\<^sub>1 ?f \<Rightarrow> Maps.REP g.leg1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ f.tab = (?f \<star> \<theta>) \<cdot> \<a>[?f, Maps.REP g.leg0, w] \<cdot>
	+ (REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f \<star> w) \<cdot> \<nu> \<and>
	+ \<guillemotleft>\<theta>' : tab\<^sub>0 ?f \<star> w' \<Rightarrow> Maps.REP g.leg0\<guillemotright> \<and>
	+ \<guillemotleft>\<nu>' : Maps.REP g.leg1 \<Rightarrow> tab\<^sub>1 ?f \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
	+ REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f =
	+ (?f \<star> \<theta>') \<cdot> \<a>[?f, tab\<^sub>0 ?f, w'] \<cdot> (f.tab \<star> w') \<cdot> \<nu>'"
	+ using f.apex_unique_up_to_equivalence
	+ [of "REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f"
	+ "Maps.REP g.leg0" "Maps.REP g.leg1"]
	+ by simp
	+ obtain w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'
	+ where 4: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg w' w \<psi> \<phi> \<and>
	+ \<guillemotleft>w : src (tab\<^sub>0 ?f) \<rightarrow> src (Maps.REP g.leg0)\<guillemotright> \<and>
	+ \<guillemotleft>w' : src (Maps.REP g.leg0) \<rightarrow> src (tab\<^sub>0 ?f)\<guillemotright> \<and>
	+ \<guillemotleft>\<theta> : Maps.REP g.leg0 \<star> w \<Rightarrow> tab\<^sub>0 ?f\<guillemotright> \<and>
	+ \<guillemotleft>\<nu> : tab\<^sub>1 ?f \<Rightarrow> Maps.REP g.leg1 \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ f.tab = (?f \<star> \<theta>) \<cdot> \<a>[?f, Maps.REP g.leg0, w] \<cdot>
	+ (REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f \<star> w) \<cdot> \<nu> \<and>
	+ \<guillemotleft>\<theta>' : tab\<^sub>0 ?f \<star> w' \<Rightarrow> Maps.REP g.leg0\<guillemotright> \<and>
	+ \<guillemotleft>\<nu>' : Maps.REP g.leg1 \<Rightarrow> tab\<^sub>1 ?f \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
	+ REP_leg0.trnr\<^sub>\<eta> (Maps.REP g.leg1) ?f =
	+ (?f \<star> \<theta>') \<cdot> \<a>[?f, tab\<^sub>0 ?f, w'] \<cdot> (f.tab \<star> w') \<cdot> \<nu>'"
	+ using 3 by meson
	+ hence w\<theta>\<nu>: "equivalence_map w \<and> \<guillemotleft>w : src (tab\<^sub>0 ?f) \<rightarrow> src (Maps.REP g.leg0)\<guillemotright> \<and>
	+ \<guillemotleft>\<theta> : Maps.REP g.leg0 \<star> w \<Rightarrow> tab\<^sub>0 ?f\<guillemotright> \<and>
	+ \<guillemotleft>\<nu> : tab\<^sub>1 ?f \<Rightarrow> Maps.REP g.leg1 \<star> w\<guillemotright> \<and> iso \<nu>"
	+ using equivalence_map_def equivalence_pair_def equivalence_pair_symmetric
	+ by meson
	+ let ?W = "\<lparr>Chn = \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>, Dom = Dom (SPN ?f), Cod = Dom g\<rparr>"
	+ have W_in_hom: "Span.in_hom ?W (SPN ?f) g"
	+ proof
	+ have "arrow_of_spans Maps.comp ?W"
	+ proof
	+ interpret Dom_W: span_in_category Maps.comp \<open>Dom ?W\<close>
	+ proof (unfold_locales, intro conjI)
	+ show "Maps.arr (Leg0 (Dom ?W))"
	+ apply (intro Maps.arrI)
	+ apply auto
	+ by (metis f.base_simps(2) f.satisfies_T0 f.u_in_hom src_hcomp')
	+ show "Maps.arr (Leg1 (Dom ?W))"
	+ using 1
	+ apply (intro Maps.arrI)
	+ apply auto
	+ proof -
	+ let ?f = "tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)"
	+ assume 1: "\<guillemotleft>Maps.REP g.leg1 : Maps.Dom g.apex \<rightarrow> Maps.Cod g.leg1\<guillemotright>"
	+ have "\<guillemotleft>?f : src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))
	+ \<rightarrow> Maps.Cod g.leg1\<guillemotright> \<and>
	+ is_left_adjoint ?f \<and> \<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk> = \<lbrakk>?f\<rbrakk>"
	+ using 1 by simp
	+ thus "\<exists>f. \<guillemotleft>f : src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))
	+ \<rightarrow> Maps.Cod g.leg1\<guillemotright> \<and>
	+ is_left_adjoint f \<and>
	+ \<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk> = \<lbrakk>f\<rbrakk>"
	+ by blast
	+ qed
	+ show "Maps.dom (Leg0 (Dom ?W)) = Maps.dom (Leg1 (Dom ?W))"
	+ proof -
	+ have "Maps.dom (Leg0 (Dom ?W)) =
	+ Maps.MkIde (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))"
	+ using Maps.dom_char
	+ apply simp
	+ by (metis (no_types, lifting) Maps.CLS_in_hom Maps.in_homE f.base_simps(2)
	+ f.satisfies_T0 f.u_simps(3) hcomp_simps(1))
	+ also have "... = Maps.dom (Leg1 (Dom ?W))"
	+ using Maps.dom_char Maps.CLS_in_hom f.leg1_is_map f_in_hhom
	+ apply simp
	+ by (metis (no_types, lifting) Maps.in_homE Maps.REP_simps(3) f.base_simps(2)
	+ f.leg1_is_map f.leg1_simps(3) f.leg1_simps(4) g.dom.leg_simps(3)
	+ trg_hcomp')
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ show "Maps.span (Leg0 (Dom ?W)) (Leg1 (Dom ?W))"
	+ using Dom_W.span_in_category_axioms Dom_W.is_span by blast
	+ interpret Cod_W: span_in_category Maps.comp \<open>Cod ?W\<close>
	+ apply unfold_locales by fastforce
	+ show "Maps.span (Leg0 (Cod ?W)) (Leg1 (Cod ?W))"
	+ by fastforce
	+ show "Maps.in_hom (Chn ?W) Dom_W.apex Cod_W.apex"
	+ proof
	+ show 1: "Maps.arr (Chn ?W)"
	+ using w\<theta>\<nu> Maps.CLS_in_hom [of w] equivalence_is_adjoint by auto
	+ show "Maps.dom (Chn ?W) = Dom_W.apex"
	+ proof -
	+ have "Maps.dom (Chn ?W) = Maps.MkIde (src w)"
	+ using 1 w\<theta>\<nu> Maps.dom_char by simp
	+ also have "... = Dom_W.apex"
	+ proof -
	+ have "src w = src (tab\<^sub>0 ?f)"
	+ using w\<theta>\<nu> by blast
	+ thus ?thesis
	+ using Dom_W.apex_def Maps.arr_char Maps.dom_char
	+ apply simp
	+ by (metis (no_types, lifting) f.base_simps(2) f.satisfies_T0
	+ f.u_in_hom hcomp_simps(1))
	+ qed
	+ finally show ?thesis by fastforce
	+ qed
	+ show "Maps.cod (Chn ?W) = Cod_W.apex"
	+ proof -
	+ have "Maps.cod (Chn ?W) = Maps.MkIde (trg w)"
	+ using 1 w\<theta>\<nu> Maps.cod_char by simp
	+ also have "... = Cod_W.apex"
	+ proof -
	+ have "trg w = src (Maps.REP g.leg0)"
	+ using w\<theta>\<nu> by blast
	+ thus ?thesis
	+ using Cod_W.apex_def Maps.arr_char Maps.cod_char
	+ apply simp
	+ using g.dom.apex_def Maps.dom_char Maps.REP_simps(2) g.dom.is_span
	+ by presburger
	+ qed
	+ finally show ?thesis by fastforce
	+ qed
	+ qed
	+ show "Cod_W.leg0 \<odot> Chn ?W = Dom_W.leg0"
	+ proof -
	+ have "Cod_W.leg0 \<odot> Chn ?W = g.leg0 \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
	+ by simp
	+ also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
	+ using g.dom.leg_simps(1) Maps.CLS_REP [of g.leg0]
	+ by simp
	+ also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg0 \<star> w\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "is_left_adjoint (Maps.REP g.leg0)"
	+ by fast
	+ moreover have "is_left_adjoint w"
	+ using w\<theta>\<nu> equivalence_is_adjoint by simp
	+ moreover have "Maps.REP g.leg0 \<star> w \<cong> Maps.REP g.leg0 \<star> w"
	+ using w\<theta>\<nu> isomorphic_reflexive Maps.REP_in_hhom hseqI'
	+ by (metis (no_types, lifting) REP_leg0.ide_left adjoint_pair_antipar(1)
	+ calculation(2) ide_hcomp in_hhomE)
	+ ultimately show ?thesis
	+ using w\<theta>\<nu> Maps.comp_CLS isomorphic_reflexive equivalence_is_adjoint
	+ by blast
	+ qed
	+ also have "... = \<lbrakk>\<lbrakk>tab\<^sub>0 ?f\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "iso \<theta>"
	+ proof -
	+ have "is_left_adjoint (Maps.REP g.leg0 \<star> w)"
	+ using w\<theta>\<nu> equivalence_is_adjoint Maps.REP_in_hhom hseqI'
	+ by (simp add: g.leg0_is_map in_hhom_def left_adjoints_compose)
	+ moreover have "is_left_adjoint (tab\<^sub>0 ?f)"
	+ by simp
	+ ultimately show ?thesis
	+ using w\<theta>\<nu> BS3 by blast
	+ qed
	+ thus ?thesis
	+ using w\<theta>\<nu> Maps.CLS_eqI equivalence_is_adjoint hseqI'
	+ by (meson isomorphic_def isomorphic_implies_hpar(1))
	+ qed
	+ finally show ?thesis by fastforce
	+ qed
	+ show "Cod_W.leg1 \<odot> Chn ?W = Dom_W.leg1"
	+ proof -
	+ have "Cod_W.leg1 \<odot> Chn ?W = g.leg1 \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
	+ by simp
	+ also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
	+ using g.dom.leg_simps(3) Maps.CLS_REP by presburger
	+ also have "... = \<lbrakk>\<lbrakk>Maps.REP g.leg1 \<star> w\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "is_left_adjoint (Maps.REP g.leg1)"
	+ by fast
	+ moreover have "is_left_adjoint w"
	+ using w\<theta>\<nu> equivalence_is_adjoint by simp
	+ moreover have "Maps.REP g.leg1 \<star> w \<cong> Maps.REP g.leg1 \<star> w"
	+ using w\<theta>\<nu> isomorphic_reflexive Maps.REP_in_hhom hseqI'
	+ by (metis (no_types, lifting) "2" calculation(2) g.dom.is_span
	+ hcomp_ide_isomorphic Maps.ide_REP in_hhomE
	+ right_adjoint_determines_left_up_to_iso)
	+ ultimately show ?thesis
	+ using w\<theta>\<nu> Maps.comp_CLS isomorphic_reflexive equivalence_is_adjoint
	+ by blast
	+ qed
	+ also have "... = \<lbrakk>\<lbrakk>tab\<^sub>1 ?f\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "ide (Maps.REP g.leg1 \<star> w)"
	+ using 2 w\<theta>\<nu> equivalence_map_is_ide by auto
	+ moreover have "Maps.REP g.leg1 \<star> w \<cong>
	+ tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)"
	+ using w\<theta>\<nu> equivalence_is_adjoint hseqI' f.leg1_is_map
	+ right_adjoint_determines_left_up_to_iso adjoint_pair_preserved_by_iso
	+ by (meson adjoint_pair_antipar(2) ide_in_hom(2) ide_is_iso)
	+ ultimately show ?thesis
	+ using Maps.CLS_eqI by blast
	+ qed
	+ finally show ?thesis by fastforce
	+ qed
	+ qed
	+ thus W: "Span.arr ?W"
	+ using Span.arr_char by blast
	+ interpret Dom_W: span_in_category Maps.comp
	+ \<open>\<lparr>Leg0 = MkArr (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))
	+ (src (Maps.REP g.leg0)\<^sup>*)
	+ (iso_class
	+ (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*))),
	+ Leg1 = MkArr (src (tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))
	+ (Maps.Cod g.leg1)
	+ (iso_class
	+ (tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)))\<rparr>\<close>
	+ using W Span.arr_char
	+ by (simp add: arrow_of_spans_def)
	+ interpret Cod_W: span_in_category Maps.comp \<open>Cod ?W\<close>
	+ using W Span.arr_char
	+ by (simp add: arrow_of_spans_def)
	+ show "Span.dom ?W = SPN ?f"
	+ proof -
	+ have "Span.dom ?W =
	+ \<lparr>Chn = Dom_W.apex,
	+ Dom = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>,
	+ Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>\<rparr>,
	+ Cod = \<lparr>Leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>,
	+ Leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 (Maps.REP g.leg1 \<star> (Maps.REP g.leg0)\<^sup>*)\<rbrakk>\<rbrakk>\<rparr>\<rparr>"
	+ using 0 W Span.dom_char by simp
	+ also have "... = SPN ?f"
	+ using SPN_def Dom_W.apex_def Maps.dom_char Dom_W.is_span iso_class_eqI
	+ spn_ide
	+ apply simp
	+ using ide_f by blast
	+ finally show ?thesis by blast
	+ qed
	+ show "Span.cod ?W = g"
	+ using 0 W Span.cod_char Cod_W.apex_def by simp
	+ qed
	+ moreover have "Span.iso ?W"
	+ proof -
	+ have "Maps.iso \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
	+ proof -
	+ have "Maps.arr \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk> \<and> w \<in> Maps.Map \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk> \<and> equivalence_map w"
	+ proof (intro conjI)
	+ show 1: "Maps.arr \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
	+ using w\<theta>\<nu> Maps.CLS_in_hom equivalence_is_adjoint by blast
	+ show "equivalence_map w"
	+ using w\<theta>\<nu> by blast
	+ show "w \<in> Maps.Map \<lbrakk>\<lbrakk>w\<rbrakk>\<rbrakk>"
	+ using 1 w\<theta>\<nu> equivalence_is_adjoint Maps.arr_char
	+ by (simp add: equivalence_map_is_ide ide_in_iso_class)
	+ qed
	+ thus ?thesis
	+ using Maps.iso_char' by blast
	+ qed
	+ thus ?thesis
	+ using w\<theta>\<nu> W_in_hom Span.iso_char by auto
	+ qed
	+ ultimately show ?thesis
	+ using Span.isomorphic_def by blast
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ show "\<And>r s \<tau>. \<lbrakk>ide r; ide s; src r = src s; trg r = trg s; Span.in_hom \<tau> (SPN r) (SPN s)\<rbrakk>
	+ \<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright> \<and> SPN \<mu> = \<tau>"
	+ proof -
	+ fix r s \<tau>
	+ assume r: "ide r" and s: "ide s"
	+ assume src_eq: "src r = src s" and trg_eq: "trg r = trg s"
	+ assume \<tau>: "Span.in_hom \<tau> (SPN r) (SPN s)"
	+ interpret \<tau>: arrow_of_spans Maps.comp \<tau>
	+ using \<tau> Span.arr_char by auto
	+ interpret r: identity_in_bicategory_of_spans V H \<a> \<i> src trg r
	+ using r by (unfold_locales, auto)
	+ interpret s: identity_in_bicategory_of_spans V H \<a> \<i> src trg s
	+ using s by (unfold_locales, auto)
	+ interpret s: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close> s
	+ using s.is_arrow_of_tabulations_in_maps by simp
	+ have \<tau>_dom_leg0_eq: "\<tau>.dom.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 r\<rbrakk>\<rbrakk>"
	+ using \<tau> Span.dom_char SPN_def [of r] by auto
	+ have \<tau>_dom_leg1_eq: "\<tau>.dom.leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 r\<rbrakk>\<rbrakk>"
	+ using \<tau> Span.dom_char SPN_def [of r] by auto
	+ have \<tau>_cod_leg0_eq: "\<tau>.cod.leg0 = \<lbrakk>\<lbrakk>tab\<^sub>0 s\<rbrakk>\<rbrakk>"
	+ using \<tau> Span.cod_char SPN_def [of s] by auto
	+ have \<tau>_cod_leg1_eq: "\<tau>.cod.leg1 = \<lbrakk>\<lbrakk>tab\<^sub>1 s\<rbrakk>\<rbrakk>"
	+ using \<tau> Span.cod_char SPN_def [of s] by auto
	+
	+ have 1: "tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<cong> tab\<^sub>0 r"
	+ proof -
	+ have "tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<cong> Maps.REP \<tau>.cod.leg0 \<star> Maps.REP \<tau>.chine"
	+ proof -
	+ have "Maps.REP \<tau>.cod.leg0 \<cong> tab\<^sub>0 s"
	+ using \<tau>_cod_leg0_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS s.satisfies_T0
	+ by presburger
	+ thus ?thesis
	+ using hcomp_isomorphic_ide [of "Maps.REP \<tau>.cod.leg0" "tab\<^sub>0 s" "Maps.REP \<tau>.chine"]
	+ isomorphic_symmetric Maps.seq_char
	+ by fastforce
	+ qed
	+ also have "... \<cong> Maps.REP \<tau>.dom.leg0"
	+ proof -
	+ have "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg0\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg0\<rbrakk>\<rbrakk>"
	+ using \<tau>.leg0_commutes Maps.CLS_REP \<tau>.chine_simps(1)
	+ \<tau>.cod.leg_simps(1) \<tau>.dom.leg_simps(1)
	+ by presburger
	+ hence "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg0 \<star> Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg0\<rbrakk>\<rbrakk>"
	+ using Maps.comp_CLS [of "Maps.REP \<tau>.cod.leg0" "Maps.REP \<tau>.chine"
	+ "Maps.REP \<tau>.cod.leg0 \<star> Maps.REP \<tau>.chine"]
	+ isomorphic_reflexive
	+ by (metis (no_types, lifting) Maps.seq_char Maps.REP_in_hhom(2) Maps.REP_simps(2-3)
	+ \<tau>.chine_in_hom \<tau>.cod.leg_in_hom(1) \<tau>.dom.leg_simps(1) \<tau>.leg0_commutes
	+ ide_hcomp Maps.ide_REP)
	+ thus ?thesis
	+ using Maps.CLS_eqI Maps.seq_char Maps.ide_REP
	+ by (meson calculation isomorphic_implies_ide(2))
	+ qed
	+ also have "... \<cong> tab\<^sub>0 r"
	+ using \<tau>_dom_leg0_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS r.satisfies_T0
	+ by presburger
	+ finally show ?thesis by blast
	+ qed
	+ obtain \<theta> where \<theta>: "\<guillemotleft>\<theta> : tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<Rightarrow> tab\<^sub>0 r\<guillemotright> \<and> iso \<theta>"
	+ using 1 by blast
	+ have 2: "tab\<^sub>1 s \<star> Maps.REP \<tau>.chine \<cong> tab\<^sub>1 r"
	+ proof -
	+ have "tab\<^sub>1 s \<star> Maps.REP \<tau>.chine \<cong> Maps.REP \<tau>.cod.leg1 \<star> Maps.REP \<tau>.chine"
	+ proof -
	+ have "Maps.REP \<tau>.cod.leg1 \<cong> tab\<^sub>1 s"
	+ using \<tau>_cod_leg1_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS s.leg1_is_map
	+ by presburger
	+ thus ?thesis
	+ using hcomp_isomorphic_ide [of "Maps.REP \<tau>.cod.leg1" "tab\<^sub>1 s" "Maps.REP \<tau>.chine"]
	+ isomorphic_symmetric Maps.seq_char
	+ by fastforce
	+ qed
	+ also have "... \<cong> Maps.REP \<tau>.dom.leg1"
	+ proof -
	+ have "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg1\<rbrakk>\<rbrakk> \<odot> \<lbrakk>\<lbrakk>Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg1\<rbrakk>\<rbrakk>"
	+ using \<tau>.leg1_commutes Maps.CLS_REP \<tau>.chine_simps(1)
	+ \<tau>.cod.leg_simps(3) \<tau>.dom.leg_simps(3)
	+ by presburger
	+ hence "\<lbrakk>\<lbrakk>Maps.REP \<tau>.cod.leg1 \<star> Maps.REP \<tau>.chine\<rbrakk>\<rbrakk> = \<lbrakk>\<lbrakk>Maps.REP \<tau>.dom.leg1\<rbrakk>\<rbrakk>"
	+ using Maps.comp_CLS [of "Maps.REP \<tau>.cod.leg1" "Maps.REP \<tau>.chine"
	+ "Maps.REP \<tau>.cod.leg1 \<star> Maps.REP \<tau>.chine"]
	+ isomorphic_reflexive
	+ by (metis (no_types, lifting) Maps.seq_char Maps.REP_in_hhom(2)
	+ Maps.REP_simps(2) Maps.REP_simps(3) \<tau>.chine_in_hom \<tau>.cod.leg_in_hom(2)
	+ \<tau>.dom.leg_simps(3) \<tau>.leg1_commutes ide_hcomp Maps.ide_REP)
	+ thus ?thesis
	+ using Maps.CLS_eqI Maps.seq_char Maps.ide_REP
	+ by (meson calculation isomorphic_implies_ide(2))
	+ qed
	+ also have "... \<cong> tab\<^sub>1 r"
	+ using \<tau>_dom_leg1_eq Maps.CLS_REP Maps.CLS_eqI Maps.REP_CLS r.leg1_is_map
	+ by presburger
	+ finally show ?thesis by blast
	+ qed
	+ obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 s \<star> Maps.REP \<tau>.chine\<guillemotright> \<and> iso \<nu>"
	+ using 2 isomorphic_symmetric by blast
	+
	+ define \<Delta>
	+ where "\<Delta> \<equiv> (s \<star> \<theta>) \<cdot> \<a>[s, tab\<^sub>0 s, Maps.REP \<tau>.chine] \<cdot> (s.tab \<star> Maps.REP \<tau>.chine) \<cdot> \<nu>"
	+ have \<Delta>: "\<guillemotleft>\<Delta> : tab\<^sub>1 r \<Rightarrow> s \<star> tab\<^sub>0 r\<guillemotright>"
	+ proof (unfold \<Delta>_def, intro comp_in_homI)
	+ show "\<guillemotleft>\<nu> : tab\<^sub>1 r \<Rightarrow> tab\<^sub>1 s \<star> Maps.REP \<tau>.chine\<guillemotright>"
	+ using \<nu> by simp
	+ show 3: "\<guillemotleft>s.tab \<star> Maps.REP \<tau>.chine :
	+ tab\<^sub>1 s \<star> Maps.REP \<tau>.chine \<Rightarrow> (s \<star> tab\<^sub>0 s) \<star> Maps.REP \<tau>.chine\<guillemotright>"
	+ apply (intro hcomp_in_vhom)
	+ apply auto
	+ using "1" by fastforce
	+ show "\<guillemotleft>\<a>[s, tab\<^sub>0 s, Maps.REP \<tau>.chine] :
	+ (s \<star> tab\<^sub>0 s) \<star> Maps.REP \<tau>.chine \<Rightarrow> s \<star> tab\<^sub>0 s \<star> Maps.REP \<tau>.chine\<guillemotright>"
	+ using s hseqI' assoc_in_hom [of s "tab\<^sub>0 s" "Maps.REP \<tau>.chine"]
	+ by (metis (no_types, lifting) Maps.ide_REP 3 \<tau>.chine_simps(1) hcomp_in_vhomE
	+ ideD(2) ideD(3) s.ide_u s.tab_simps(2) s.u_simps(3))
	+ show "\<guillemotleft>s \<star> \<theta> : s \<star> tab\<^sub>0 s \<star> Maps.REP \<tau>.chine \<Rightarrow> s \<star> tab\<^sub>0 r\<guillemotright>"
	+ using 1 s \<theta> isomorphic_implies_hpar(4) src_eq by auto
	+ qed
	+ define \<mu> where "\<mu> \<equiv> r.T0.trnr\<^sub>\<epsilon> s \<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab)"
	+ have \<mu>: "\<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright>"
	+ proof (unfold \<mu>_def, intro comp_in_homI)
	+ show "\<guillemotleft>inv (r.T0.trnr\<^sub>\<epsilon> r r.tab) : r \<Rightarrow> tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*\<guillemotright>"
	+ using r.yields_isomorphic_representation by fastforce
	+ show "\<guillemotleft>r.T0.trnr\<^sub>\<epsilon> s \<Delta> : tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>* \<Rightarrow> s\<guillemotright>"
	+ using s \<Delta> src_eq r.T0.adjoint_transpose_right(2) [of s "tab\<^sub>1 r"] by auto
	+ qed
	+ interpret \<mu>: arrow_in_bicategory_of_spans V H \<a> \<i> src trg r s \<mu>
	+ using \<mu> by (unfold_locales, auto)
	+ interpret \<mu>: arrow_of_tabulations_in_maps V H \<a> \<i> src trg
	+ r r.tab \<open>tab\<^sub>0 r\<close> \<open>tab\<^sub>1 r\<close> s s.tab \<open>tab\<^sub>0 s\<close> \<open>tab\<^sub>1 s\<close> \<mu>
	+ using \<mu>.is_arrow_of_tabulations_in_maps by simp
	+ have \<Delta>_eq: "\<Delta> = \<mu>.\<Delta>"
	+ proof -
	+ have "r.T0.trnr\<^sub>\<epsilon> s \<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab) =
	+ r.T0.trnr\<^sub>\<epsilon> s \<mu>.\<Delta> \<cdot> inv (r.T0.trnr\<^sub>\<epsilon> r r.tab)"
	+ using \<mu> \<mu>_def \<mu>.\<mu>_in_terms_of_\<Delta> by auto
	+ hence "r.T0.trnr\<^sub>\<epsilon> s \<Delta> = r.T0.trnr\<^sub>\<epsilon> s \<mu>.\<Delta>"
	+ using r s \<Delta> r.T0.adjoint_transpose_right(2) r.yields_isomorphic_representation
	+ iso_inv_iso iso_is_retraction retraction_is_epi epiE
	+ by (metis \<mu>.in_hom \<mu>_def arrI)
	+ thus ?thesis
	+ using \<Delta> \<mu>.\<Delta>_in_hom(2) src_eq r.T0.adjoint_transpose_right(6)
	+ bij_betw_imp_inj_on
	+ [of "r.T0.trnr\<^sub>\<epsilon> s" "hom (tab\<^sub>1 r) (s \<star> tab\<^sub>0 r)" "hom (tab\<^sub>1 r \<star> (tab\<^sub>0 r)\<^sup>*) s"]
	+ inj_on_def [of "r.T0.trnr\<^sub>\<epsilon> s" "hom (tab\<^sub>1 r) (s \<star> tab\<^sub>0 r)"]
	+ by simp
	+ qed
	+ have "\<mu>.is_induced_map (Maps.REP \<tau>.chine)"
	+ using \<theta> \<nu> \<Delta>_eq \<Delta>_def \<mu>.is_induced_map_iff \<tau>.chine_simps(1) Maps.ide_REP by blast
	+ hence 3: "Maps.REP \<tau>.chine \<cong> \<mu>.chine"
	+ using \<mu>.chine_is_induced_map \<mu>.induced_map_unique by simp
	+ have "SPN \<mu> = \<tau>"
	+ proof (intro Span.arr_eqI)
	+ show "Span.par (SPN \<mu>) \<tau>"
	+ using \<mu> \<tau> SPN_in_hom
	+ by (metis (no_types, lifting) SPN.preserves_cod SPN.preserves_dom Span.in_homE
	+ in_homE)
	+ show "Chn (SPN \<mu>) = \<tau>.chine"
	+ proof -
	+ have "Chn (SPN \<mu>) = \<lbrakk>\<lbrakk>spn \<mu>\<rbrakk>\<rbrakk>"
	+ using \<mu> SPN_def spn_def by auto
	+ also have "... = \<lbrakk>\<lbrakk>\<mu>.chine\<rbrakk>\<rbrakk>"
	+ using \<mu> spn_def by fastforce
	+ also have "... = \<lbrakk>\<lbrakk>Maps.REP \<tau>.chine\<rbrakk>\<rbrakk>"
	+ using 3 isomorphic_symmetric Maps.CLS_eqI iso_class_eqI isomorphic_implies_hpar(3)
	+ isomorphic_implies_hpar(4)
	+ by auto
	+ also have "... = \<tau>.chine"
	+ using Maps.CLS_REP \<tau>.chine_simps(1) by blast
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ thus "\<exists>\<mu>. \<guillemotleft>\<mu> : r \<Rightarrow> s\<guillemotright> \<and> SPN \<mu> = \<tau>"
	+ using \<mu> by auto
	+ qed
	+ qed
	+
	+ theorem SPN_is_equivalence_pseudofunctor:
	+ shows "equivalence_pseudofunctor V H \<a> \<i> src trg
	+ Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg SPN \<Phi>"
	+ ..
	+
	+ text \<open>
	+ We have completed the proof of the second half of the main result (CKS Theorem 4):
	+ \<open>B\<close> is biequivalent (via \<open>SPN\<close>) to \<open>Span(Maps(B))\<close>.
	+ \<close>
	+
	+ corollary
	+ shows "equivalent_bicategories V H \<a> \<i> src trg
	+ Span.vcomp Span.hcomp Span.assoc Span.unit Span.src Span.trg"
	+ using SPN_is_equivalence_pseudofunctor equivalent_bicategories_def by blast
	+
	+ end
	+
	+end
	diff --git a/thys/Bicategory/CanonicalIsos.thy b/thys/Bicategory/CanonicalIsos.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/CanonicalIsos.thy
	@@ -0,0 +1,693 @@
	+(* Title: CanonicalIsomorphisms
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Canonical Isomorphisms"
	+
	+text \<open>
	+ In this section we develop some technology for working with canonical isomorphisms in a bicategory,
	+ which permits them to be specified simply by giving syntactic terms that evaluate to the
	+ domain and codomain, rather than often-cumbersome formulas expressed in terms of unitors and
	+ associators.
	+\<close>
	+
	+theory CanonicalIsos
	+imports Coherence
	+begin
	+
	+ context bicategory
	+ begin
	+
	+ interpretation bicategorical_language ..
	+ interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ text \<open>
	+ The next definition defines \<open>can u t\<close>, which denotes the unique canonical isomorphism
	+ from \<open>\<lbrace>t\<rbrace>\<close> to \<open>\<lbrace>u\<rbrace>\<close>. The ordering of the arguments of \<open>can\<close> has been chosen to be the
	+ opposite of what was used for \<open>hom\<close>. Having the arguments to \<open>can\<close> this way makes it easier
	+ to see at a glance when canonical isomorphisms are composable. It could probably be argued
	+ that \<open>hom\<close> should have been defined this way as well, but that choice is somewhat
	+ well-entrenched by now and the argument for \<open>can\<close> is stronger, as it denotes an arrow and
	+ therefore appears in expressions composed with other arrows, rather than just as a hypothesis
	+ or conclusion.
	+ \<close>
	+
	+ definition can
	+ where "can u t \<equiv> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>"
	+
	+ subsection "Basic Properties"
	+
	+ text \<open>
	+ The following develop basic properties of \<open>can\<close>.
	+ \<close>
	+
	+ lemma can_in_hom [intro]:
	+ assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ shows "\<guillemotleft>can u t : \<lbrace>t\<rbrace> \<Rightarrow> \<lbrace>u\<rbrace>\<guillemotright>"
	+ proof -
	+ let ?v = "Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>"
	+ have 1: "Can ?v \<and> Dom ?v = t \<and> Cod ?v = u"
	+ using assms red_in_Hom Can_red Inv_in_Hom Can_Inv(1) by simp
	+ show "\<guillemotleft>can u t : \<lbrace>t\<rbrace> \<Rightarrow> \<lbrace>u\<rbrace>\<guillemotright>"
	+ unfolding can_def using 1 E.eval_in_hom Can_implies_Arr
	+ by (metis (no_types, lifting))
	+ qed
	+
	+ lemma can_simps [simp]:
	+ assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ shows "arr (can u t)" and "dom (can u t) = \<lbrace>t\<rbrace>" and "cod (can u t) = \<lbrace>u\<rbrace>"
	+ using assms can_in_hom by auto
	+
	+ lemma inverse_arrows_can:
	+ assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ shows "iso (can u t)" and "inverse_arrows (can u t) (can t u)"
	+ proof -
	+ let ?v = "Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>"
	+ have 1: "Can ?v \<and> Dom ?v = t \<and> Cod ?v = u"
	+ using assms red_in_Hom Can_red Inv_in_Hom Can_Inv(1) by simp
	+ show "iso (can u t)"
	+ unfolding can_def using 1 E.iso_eval_Can by blast
	+ show "inverse_arrows (can u t) (can t u)"
	+ proof (unfold can_def)
	+ show "inverse_arrows \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace>"
	+ proof
	+ show "ide (\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace>)"
	+ proof -
	+ have "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<cdot> (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)\<rbrace>"
	+ by simp
	+ also have "... = \<lbrace>u\<rbrace>"
	+ proof (intro E.eval_eqI)
	+ show 2: "VPar ((Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<cdot> Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) u"
	+ using assms 1 red_in_Hom Inv_in_Hom Ide_implies_Can Can_Inv Can_implies_Arr
	+ Can_red(1)
	+ by (simp add: Dom_Ide Cod_Ide)
	+ show "\<^bold>\<lfloor>(Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<cdot> Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ proof -
	+ have 3: "Can (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)"
	+ using Arr.simps(4) Can.simps(4) Can_Inv(1) Can_red(1) 2 assms(1) assms(2)
	+ by presburger
	+ have "VSeq (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)"
	+ using 2 Arr.simps(4) by blast
	+ hence "Can (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<and> Can (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<and>
	+ Dom (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) = Cod (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)"
	+ using 3 1 by metis
	+ thus ?thesis
	+ by (metis (no_types) 2 Can.simps(4) Nmlize_Dom Dom_Ide Ide_Nmlize_Can
	+ assms(2))
	+ qed
	+ qed
	+ finally have "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> = \<lbrace>u\<rbrace>"
	+ by blast
	+ moreover have "ide \<lbrace>u\<rbrace>"
	+ using assms E.ide_eval_Ide by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ show "ide (\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>)"
	+ proof -
	+ have "\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)\<rbrace>"
	+ by simp
	+ also have "... = \<lbrace>t\<rbrace>"
	+ proof (intro E.eval_eqI)
	+ show 2: "VPar ((Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) t"
	+ using assms 1 red_in_Hom Inv_in_Hom Ide_implies_Can Can_Inv Can_implies_Arr
	+ Can_red(1)
	+ by (simp add: Dom_Ide Cod_Ide)
	+ show "\<^bold>\<lfloor>(Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms 1 2
	+ by (metis (full_types) Arr.simps(4) Can.simps(4) Can_Inv(1) Can_red(1)
	+ Nml_Nmlize(4) Dom_Ide Ide_Nmlize_Can)
	+ qed
	+ finally have "\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>t\<rbrace>"
	+ by blast
	+ moreover have "ide \<lbrace>t\<rbrace>"
	+ using assms E.ide_eval_Ide by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+ qed
	+
	+ lemma inv_can [simp]:
	+ assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ shows "inv (can u t) = can t u"
	+ using assms inverse_arrows_can by (simp add: inverse_unique)
	+
	+ lemma vcomp_can [simp]:
	+ assumes "Ide t" and "Ide u" and "Ide v" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "\<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>v\<^bold>\<rfloor>"
	+ shows "can v u \<cdot> can u t = can v t"
	+ proof (unfold can_def)
	+ have "\<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)\<rbrace>"
	+ using assms by simp
	+ also have "... = \<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>"
	+ proof (intro E.eval_eqI)
	+ show "VPar ((Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) (Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)"
	+ using assms red_in_Hom Inv_in_Hom Ide_implies_Can
	+ by (simp add: Can_red(1))
	+ show "\<^bold>\<lfloor>(Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor>"
	+ using assms Can_red(1) Nml_Nmlize(1) Nmlize_Inv Ide_Nmlize_Can
	+ Ide_implies_Can \<open>VPar ((Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) (Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)\<close>
	+ apply simp
	+ by (metis red_simps(4) Nmlize_red Dom_Cod VcompNml_Nml_Dom)
	+ qed
	+ finally show "\<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>"
	+ by blast
	+ qed
	+
	+ lemma hcomp_can [simp]:
	+ assumes "Ide t" and "Ide u" and "Ide v" and "Ide w" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "\<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>w\<^bold>\<rfloor>"
	+ and "Src t = Trg v" and "Src u = Trg w"
	+ shows "can u t \<star> can w v = can (u \<^bold>\<star> w) (t \<^bold>\<star> v)"
	+ proof (unfold can_def)
	+ have "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<star> (Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>)\<rbrace>"
	+ using assms by simp
	+ also have "... = \<lbrace>Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>\<rbrace>"
	+ proof (intro E.eval_eqI)
	+ show "VPar (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>) (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
	+ proof -
	+ have "Arr (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
	+ proof -
	+ have "Ide (u \<^bold>\<star> w)"
	+ using assms by simp
	+ hence "Can ((u \<^bold>\<star> w)\<^bold>\<down>)"
	+ using assms Can_red by blast
	+ thus ?thesis
	+ using assms Can.simps(4) Can_Inv(1) Dom_Inv Can_implies_Arr Can_red(1)
	+ red_simps(4) Nmlize.simps(3) Ide.simps(3)
	+ by presburger
	+ qed
	+ moreover have "Arr (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>)"
	+ using assms red_in_Hom Inv_in_Hom Ide_implies_Can
	+ by (simp add: Can_red(1))
	+ moreover have "Dom (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>) =
	+ Dom (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
	+ using assms red_in_Hom Inv_in_Hom Ide_implies_Can
	+ by (metis (no_types, lifting) Nml_HcompD(3-4) Dom.simps(3-4) red.simps(3)
	+ red_Nml)
	+ moreover have "Cod (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>) =
	+ Cod (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
	+ using assms red_in_Hom Inv_in_Hom Ide_implies_Can red_Nml
	+ by (simp add: Can_red(1) Cod_Ide)
	+ ultimately show ?thesis by simp
	+ qed
	+ show "\<^bold>\<lfloor>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>\<^bold>\<rfloor>"
	+ using assms Inv_in_Hom Ide_implies_Can Nmlize_Inv Ide_Nmlize_Can Can_red
	+ red2_Nml
	+ apply auto
	+ using VcompNml_HcompNml [of u w u w]
	+ apply (metis red_simps(4) Nml_HcompD(3-4) Nmlize_Nml red_simps(3) red_Nml)
	+ apply (metis Nml_HcompD(3-4) Nmlize.simps(3) Nmlize_Nml
	+ red_simps(3) Ide.simps(3) VcompNml_Nml_Dom red_Nml)
	+ apply (metis Can_red2(1) red_simps(4) Nml_HcompD(3-4) Nmlize.simps(3)
	+ Nmlize_Nml VcompNml_Cod_Nml red_Nml)
	+ using red2_Nml Nmlize_red2 Can_red2(1) Nmlize_Hcomp Dom_Ide Ide_implies_Arr
	+ VcompNml_Nml_Dom Nml_Nmlize(1) Nml_Nmlize(2) Nml_Nmlize(3)
	+ Nmlize.simps(3)
	+ by metis
	+ qed
	+ finally show "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>\<rbrace> = \<lbrace>Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>\<rbrace>"
	+ by blast
	+ qed
	+
	+ subsection "Introduction Rules"
	+
	+ text \<open>
	+ To make the \<open>can\<close> notation useful, we need a way to introduce it.
	+ This is a bit tedious, because in general there can multiple \<open>can\<close>
	+ notations for the same isomorphism, and we have to use the right ones in the
	+ right contexts, otherwise we won't be able to compose them properly.
	+ Thankfully, we don't need the inverse versions of the theorems below,
	+ as they are easily provable from the non-inverse versions using \<open>inv_can\<close>.
	+ \<close>
	+
	+ lemma canI_unitor_0:
	+ assumes "ide f"
	+ shows "\<l>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
	+ and "\<r>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
	+ proof -
	+ have "can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) = \<lbrace>\<^bold>\<l>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus 1: "\<l>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
	+ using assms by (simp add: \<ll>_ide_simp)
	+ have "can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<r>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus "\<r>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
	+ using assms by (simp add: \<rr>_ide_simp)
	+ qed
	+
	+ lemma canI_unitor_1:
	+ assumes "obj a"
	+ shows "\<l>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
	+ and "\<r>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
	+ proof -
	+ have "can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<l>\<^bold>[\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus 1: "\<l>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
	+ using assms by (auto simp add: \<ll>_ide_simp)
	+ have "can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<r>\<^bold>[\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus "\<r>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
	+ using assms by (auto simp add: \<rr>_ide_simp)
	+ qed
	+
	+ lemma canI_associator_0:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "\<a>[f, g, h] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)"
	+ proof -
	+ have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus "\<a>[f, g, h] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)"
	+ using assms by (simp add: \<alpha>_def)
	+ qed
	+
	+ lemma canI_associator_1:
	+ assumes "ide f" and "ide g" and "src f = trg g"
	+ shows "\<a>[trg f, f, g] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
	+ and "\<a>[f, src f, g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
	+ and "\<a>[f, g, src g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0)"
	+ proof -
	+ show "\<a>[trg f, f, g] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
	+ proof -
	+ have "can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus ?thesis
	+ using assms \<alpha>_def by simp
	+ qed
	+ show "\<a>[f, src f, g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
	+ proof -
	+ have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>g\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus ?thesis
	+ using assms \<alpha>_def by simp
	+ qed
	+ show "\<a>[f, g, src g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0)"
	+ proof -
	+ have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus ?thesis
	+ using assms \<alpha>_def by simp
	+ qed
	+ qed
	+
	+ lemma canI_associator_2:
	+ assumes "ide f"
	+ shows "\<a>[trg f, trg f, f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
	+ and "\<a>[trg f, f, src f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
	+ and "\<a>[f, src f, src f] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
	+ proof -
	+ show "\<a>[trg f, trg f, f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
	+ proof -
	+ have "can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus ?thesis
	+ using assms \<alpha>_def by simp
	+ qed
	+ show "\<a>[trg f, f, src f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
	+ proof -
	+ have "can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus ?thesis
	+ using assms \<alpha>_def by simp
	+ qed
	+ show "\<a>[f, src f, src f] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
	+ proof -
	+ have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) =
	+ \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus ?thesis
	+ using assms \<alpha>_def by simp
	+ qed
	+ qed
	+
	+ lemma canI_associator_3:
	+ assumes "obj a"
	+ shows "\<a>[a, a, a] = can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
	+ proof -
	+ have "can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
	+ unfolding can_def using assms by (intro E.eval_eqI, simp_all)
	+ thus ?thesis
	+ using assms \<alpha>_def by auto
	+ qed
	+
	+ lemma canI_associator_hcomp:
	+ assumes "ide f" and "ide g" and "ide h" and "ide k"
	+ and "src f = trg g" and "src g = trg h" and "src h = trg k"
	+ shows "\<a>[f \<star> g, h, k] = can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) (((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
	+ and "\<a>[f, g \<star> h, k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
	+ and "\<a>[f, g, h \<star> k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
	+ proof -
	+ show "\<a>[f \<star> g, h, k] = can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) (((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
	+ proof -
	+ have "can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) (((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) =
	+ (((f \<star> g) \<star> h \<star> k) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, h \<star> k] \<cdot> (f \<star> g \<star> h \<star> k)) \<cdot> (f \<star> g \<star> h \<star> k)) \<cdot>
	+ ((f \<star> g \<star> h \<star> k) \<cdot> (f \<star> (g \<star> h \<star> k) \<cdot> (g \<star> h \<star> k) \<cdot> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k]) \<cdot>
	+ (((f \<star> g \<star> h) \<cdot> (f \<star> g \<star> h) \<cdot> \<a>[f, g, h]) \<cdot> ((f \<star> g) \<star> h) \<star> k)"
	+ unfolding can_def using assms \<alpha>_def \<a>'_def \<alpha>'.map_ide_simp by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[f, g, h \<star> k] \<cdot> (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)"
	+ using assms comp_arr_dom comp_cod_arr comp_assoc hseqI' by simp
	+ also have "... = \<a>[f \<star> g, h, k]"
	+ using assms pentagon [of f g h k] invert_side_of_triangle(1) \<alpha>_def \<alpha>'.map_ide_simp
	+ assoc_simps(1) assoc_simps(4) assoc_simps(5) ideD(1) iso_assoc preserves_ide seqI
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "\<a>[f, g \<star> h, k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
	+ proof -
	+ have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) =
	+ ((f \<star> ((g \<star> h) \<star> k) \<cdot> (\<a>\<^sup>-\<^sup>1[g, h, k] \<cdot> (g \<star> h \<star> k)) \<cdot> (g \<star> h \<star> k)) \<cdot> (f \<star> g \<star> h \<star> k)) \<cdot>
	+ ((f \<star> g \<star> h \<star> k) \<cdot> (f \<star> (g \<star> h \<star> k) \<cdot> (g \<star> h \<star> k) \<cdot> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k]) \<cdot>
	+ ((f \<star> g \<star> h) \<star> k)"
	+ unfolding can_def using assms \<alpha>_def \<alpha>'.map_ide_simp \<a>'_def by simp
	+ also have "... = ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, k]) \<cdot> (f \<star> \<a>[g, h, k])) \<cdot> \<a>[f, g \<star> h, k]"
	+ using assms comp_arr_dom comp_cod_arr comp_assoc hseqI' by simp
	+ also have "... = \<a>[f, g \<star> h, k]"
	+ using assms comp_cod_arr whisker_left [of f "\<a>\<^sup>-\<^sup>1[g, h, k]" "\<a>[g, h, k]"]
	+ comp_assoc_assoc'
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "\<a>[f, g, h \<star> k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
	+ proof -
	+ have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) =
	+ (f \<star> g \<star> h \<star> k) \<cdot> ((f \<star> g \<star> h \<star> k) \<cdot> (f \<star> g \<star> h \<star> k) \<cdot> \<a>[f, g, h \<star> k]) \<cdot> ((f \<star> g) \<star> h \<star> k)"
	+ unfolding can_def using assms \<alpha>_def \<alpha>'.map_ide_simp by simp
	+ also have "... = \<a>[f, g, h \<star> k]"
	+ using assms comp_arr_dom comp_cod_arr by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ subsection "Rules for Eliminating `can'"
	+
	+ text \<open>
	+ The following rules are used for replacing \<open>can\<close> in an expression by terms expressed
	+ using unit and associativity isomorphisms. They are not really expressed in the form
	+ of elimination rules, so the names are perhaps a bit misleading. They are typically
	+ applied as simplifications.
	+ \<close>
	+
	+ lemma canE_unitor:
	+ assumes "Ide f"
	+ shows "can f (f \<^bold>\<star> Src f) = \<r>[\<lbrace>f\<rbrace>]"
	+ and "can f (Trg f \<^bold>\<star> f) = \<l>[\<lbrace>f\<rbrace>]"
	+ and "can (f \<^bold>\<star> Src f) f = \<r>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
	+ and "can (Trg f \<^bold>\<star> f) f = \<l>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
	+ proof -
	+ show 1: "can f (f \<^bold>\<star> Src f) = \<r>[\<lbrace>f\<rbrace>]"
	+ proof -
	+ have f: "\<not>Nml (f \<^bold>\<star> Src f)"
	+ using assms Nml_HcompD(5) is_Prim0_Src by blast
	+ have "can f (f \<^bold>\<star> Src f) = \<lbrace>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)\<rbrace>"
	+ using assms f can_def by simp
	+ also have "... = \<lbrace>\<^bold>\<r>\<^bold>[f\<^bold>]\<rbrace>"
	+ proof (intro E.eval_eqI)
	+ show "VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)) \<^bold>\<r>\<^bold>[f\<^bold>]"
	+ using assms Nmlize_in_Hom red_in_Hom red2_in_Hom Inv_in_Hom Can_red Can_implies_Arr
	+ Nml_Nmlize(1) Ide_implies_Can Nml_Src Nml_implies_Arr
	+ HcompNml_Nml_Src Ide_Cod
	+ apply (simp add: Dom_Ide Cod_Ide)
	+ apply (intro conjI)
	+ proof -
	+ assume f: "Ide f"
	+ have 1: "Nml (Src f)"
	+ proof -
	+ have "Ide (Src f)"
	+ using f by simp
	+ thus ?thesis
	+ using f Obj_Src Nml_Nmlize(1) Nmlize_Src(2) Ide_implies_Arr
	+ by metis
	+ qed
	+ show "Arr (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>)"
	+ using f 1 Can_red2 Ide_Nmlize_Ide Nml_Nmlize by simp
	+ show "Dom (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) = \<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>"
	+ using f 1 Nml_Nmlize red2_in_Hom Ide_Nmlize_Ide by auto
	+ show "\<^bold>\<lfloor>f\<^bold>\<rfloor> = Cod (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>)"
	+ proof -
	+ have "Src \<^bold>\<lfloor>f\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>Src f\<^bold>\<rfloor>"
	+ using f Nml_Nmlize by simp
	+ moreover have "\<^bold>\<lfloor>\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
	+ using f 1 Nml_Nmlize Nmlize_Src HcompNml_Nml_Src Nml_Src
	+ by (auto simp add: HcompNml_Nml_Obj)
	+ thus ?thesis
	+ using f 1 Obj_Src red2_in_Hom [of "\<^bold>\<lfloor>f\<^bold>\<rfloor>" "\<^bold>\<lfloor>Src f\<^bold>\<rfloor>"] HcompNml_Nml_Src
	+ Nml_Nmlize Ide_Nmlize_Ide
	+ by auto
	+ qed
	+ qed
	+ show "\<^bold>\<lfloor>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<r>\<^bold>[f\<^bold>]\<^bold>\<rfloor>"
	+ using assms f HcompNml_Nml_Src Nml_Nmlize Can_red Nmlize_Hcomp
	+ Nmlize_Inv Nmlize_Src(1) Nmlize_red Nmlize_red2
	+ Ide_Nmlize_Can VcompNml_Nml_Ide red_Src
	+ apply (simp add: HcompNml_Nml_Obj)
	+ proof -
	+ assume f: "Ide f"
	+ have "\<^bold>\<lfloor>\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> Src f\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
	+ proof -
	+ have "Obj (Src f)"
	+ using f Obj_Src by simp
	+ thus ?thesis
	+ using f apply (cases "Src f")
	+ by (simp_all add: Nml_Nmlize(1) Nml_Nmlize(2) Ide_Nmlize_Ide)
	+ qed
	+ thus "\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> Src f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
	+ by (metis Cod_Inv Can_red(1) Cod.simps(4) Nmlize.simps(4)
	+ Nmlize.simps(7) Nmlize_Vcomp_Cod_Arr red_simps(3)
	+ \<open>VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)) \<^bold>\<r>\<^bold>[f\<^bold>]\<close> f)
	+ qed
	+ qed
	+ also have "... = \<r>[\<lbrace>f\<rbrace>]"
	+ using assms E.eval_Runit_Ide by blast
	+ finally show ?thesis by simp
	+ qed
	+ show 2: "can f (Trg f \<^bold>\<star> f) = \<l>[\<lbrace>f\<rbrace>]"
	+ proof -
	+ have f: "\<not>Nml (Trg f \<^bold>\<star> f)"
	+ using assms by (metis Nml.simps(4) Nml_HcompD(6))
	+ have "can f (Trg f \<^bold>\<star> f) = \<lbrace>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)\<rbrace>"
	+ using assms f can_def by simp
	+ also have "... = \<lbrace>\<^bold>\<l>\<^bold>[f\<^bold>]\<rbrace>"
	+ proof (intro E.eval_eqI)
	+ show "VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)) \<^bold>\<l>\<^bold>[f\<^bold>]"
	+ using assms Nmlize_in_Hom red_in_Hom red2_in_Hom Inv_in_Hom Can_red Can_implies_Arr
	+ Nml_Nmlize(1) Ide_implies_Can Nml_Trg Nml_implies_Arr
	+ HcompNml_Trg_Nml Ide_Cod Nmlize_Trg(1)
	+ apply (simp add: Dom_Ide Cod_Ide)
	+ apply (intro conjI)
	+ proof -
	+ assume f: "Ide f"
	+ have 1: "Nml (Trg f)"
	+ proof -
	+ have "Ide (Trg f)"
	+ using f by simp
	+ thus ?thesis
	+ using f Obj_Trg Nml_Nmlize(1) Nmlize_Trg(2) Ide_implies_Arr
	+ by metis
	+ qed
	+ show "Arr (Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>)"
	+ using f 1 Can_red2 Ide_Nmlize_Ide Nml_Nmlize(1,3) by simp
	+ show "Dom (Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) = Trg f \<^bold>\<star> \<^bold>\<lfloor>f\<^bold>\<rfloor>"
	+ using f Obj_Trg 1 Nml_Nmlize(1,3) red2_in_Hom Ide_Nmlize_Ide by auto
	+ show "\<^bold>\<lfloor>f\<^bold>\<rfloor> = Cod (Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>)"
	+ proof -
	+ have "Src (Trg f) = Trg \<^bold>\<lfloor>f\<^bold>\<rfloor>"
	+ using f Nml_Nmlize(3) by simp
	+ thus ?thesis
	+ using f 1 Obj_Trg HcompNml_Trg_Nml Nml_Nmlize(1) Ide_Nmlize_Ide by auto
	+ qed
	+ qed
	+ show "\<^bold>\<lfloor>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<l>\<^bold>[f\<^bold>]\<^bold>\<rfloor>"
	+ using assms f HcompNml_Nml_Src Nml_Nmlize Can_red Nmlize_Hcomp
	+ Nmlize_Inv Nmlize_Trg(1) Nmlize_red Nmlize_red2
	+ Ide_Nmlize_Can VcompNml_Nml_Ide red_Trg
	+ apply (simp add: HcompNml_Obj_Nml)
	+ proof -
	+ assume f: "Ide f"
	+ have "\<^bold>\<lfloor>Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
	+ proof -
	+ have "Obj (Trg f)"
	+ using f Obj_Trg by simp
	+ thus ?thesis
	+ using f apply (cases "Trg f")
	+ by (simp_all add: Nml_Nmlize(1) Nml_Nmlize(2) Ide_Nmlize_Ide)
	+ qed
	+ thus "\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
	+ by (metis Cod_Inv Can_red(1) Cod.simps(4) Nmlize.simps(4)
	+ Nmlize.simps(5) Nmlize_Vcomp_Cod_Arr red_simps(3)
	+ \<open>VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)) \<^bold>\<l>\<^bold>[f\<^bold>]\<close> f)
	+ qed
	+ qed
	+ also have "... = \<l>[\<lbrace>f\<rbrace>]"
	+ using assms E.eval_Lunit_Ide by blast
	+ finally show ?thesis by simp
	+ qed
	+ show "can (f \<^bold>\<star> Src f) f = \<r>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
	+ using assms 1 inv_can inv_inv
	+ by (metis (no_types, lifting) Nml_Nmlize(1) Nmlize.simps(3)
	+ Nmlize_Src(1) HcompNml_Nml_Src Ide.simps(3) Ide_implies_Arr
	+ Obj_Src Obj_implies_Ide Trg_Src)
	+ show "can (Trg f \<^bold>\<star> f) f = \<l>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
	+ using assms 2 inv_can inv_inv
	+ by (metis (no_types, lifting) Nml_Nmlize(1) Nmlize.simps(3)
	+ Nmlize_Trg(1) HcompNml_Trg_Nml Ide.simps(3) Ide_implies_Arr
	+ Obj_Trg Obj_implies_Ide Src_Trg)
	+ qed
	+
	+ lemma canE_associator:
	+ assumes "Ide f" and "Ide g" and "Ide h" and "Src f = Trg g" and "Src g = Trg h"
	+ shows "can (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h) = \<a>[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
	+ and "can ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h) = \<a>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
	+ proof -
	+ show "can (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h) = \<a>[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
	+ proof -
	+ have "can (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h) = \<lbrace>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<rbrace>"
	+ using can_def by simp
	+ also have "... = \<lbrace>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<rbrace>"
	+ proof (intro E.eval_eqI)
	+ have 1: "Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down> \<in> VHom ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h)"
	+ using assms Inv_in_Hom [of "(f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>"] Can_red [of "f \<^bold>\<star> g \<^bold>\<star> h"]
	+ red_in_Hom [of "f \<^bold>\<star> g \<^bold>\<star> h"] red_in_Hom [of "(f \<^bold>\<star> g) \<^bold>\<star> h"]
	+ Nmlize_Hcomp_Hcomp Nmlize_Hcomp_Hcomp'
	+ Ide_implies_Arr Nml_HcompNml Nmlize_Nml Ide_HcompNml
	+ by auto
	+ show par: "VPar (Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<a>\<^bold>[f, g, h\<^bold>]"
	+ using assms 1 Inv_in_Hom red_in_Hom Ide_in_Hom by simp
	+ show "\<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
	+ proof -
	+ have "\<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
	+ proof -
	+ have "Can (Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>)"
	+ (* Here presburger depends on par being at the end, not after assms. *)
	+ using assms Nmlize_Inv Can_Inv
	+ Arr.simps(10) Arr.simps(4) Can.simps(4) Can_red(1) Ide.simps(3)
	+ Src.simps(3) Trg.simps(3) par
	+ by presburger
	+ hence "Ide \<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
	+ using Ide_Nmlize_Can by blast
	+ thus ?thesis
	+ using Ide_in_Hom Dom_Ide by presburger
	+ qed
	+ also have 6: "... = \<^bold>\<lfloor>(f \<^bold>\<star> g) \<^bold>\<star> h\<^bold>\<rfloor>"
	+ using 1 Nmlize_Dom [of "Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>"]
	+ by (metis (mono_tags, lifting) mem_Collect_eq)
	+ also have 5: "... = Dom \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
	+ using assms 6 par Nmlize_Dom Nml_Nmlize(4) by metis
	+ also have "... = \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
	+ using assms 5 Ide_in_Hom by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ also have "... = \<a>[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
	+ using assms E.eval_Assoc_Ide \<alpha>_def by fastforce
	+ finally show ?thesis by simp
	+ qed
	+ show "can ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h) = \<a>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
	+ proof -
	+ have "can ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h) = \<lbrace>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<rbrace>"
	+ using can_def by simp
	+ also have "... = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<rbrace>"
	+ proof (intro E.eval_eqI)
	+ have 1: "Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down> \<in> VHom (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h)"
	+ using assms Inv_in_Hom [of "((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>"] Can_red [of "(f \<^bold>\<star> g) \<^bold>\<star> h"]
	+ red_in_Hom [of "(f \<^bold>\<star> g) \<^bold>\<star> h"] red_in_Hom [of "f \<^bold>\<star> g \<^bold>\<star> h"]
	+ Nmlize_Hcomp_Hcomp Nmlize_Hcomp_Hcomp'
	+ Ide_implies_Arr Nml_HcompNml Nmlize_Nml Ide_HcompNml
	+ by auto
	+ show par: "VPar (Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]"
	+ using assms 1 Inv_in_Hom red_in_Hom Ide_in_Hom by simp
	+ show "\<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
	+ proof -
	+ have "\<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
	+ proof -
	+ have "Can (Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>)"
	+ using assms Nmlize_Inv Can_Inv
	+ Arr.simps(10) Arr.simps(4) Can.simps(4) Can_red(1) Ide.simps(3)
	+ Src.simps(3) Trg.simps(3) par
	+ by presburger
	+ hence "Ide \<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
	+ using Ide_Nmlize_Can by blast
	+ thus ?thesis
	+ using Ide_in_Hom Dom_Ide by presburger
	+ qed
	+ also have 6: "... = \<^bold>\<lfloor>f \<^bold>\<star> g \<^bold>\<star> h\<^bold>\<rfloor>"
	+ using 1 Nmlize_Dom [of "Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>"]
	+ by (metis (mono_tags, lifting) mem_Collect_eq)
	+ also have 5: "... = Dom \<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
	+ using assms 6 par Nmlize_Dom Nml_Nmlize(4) by metis
	+ also have "... = \<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
	+ using assms 5 Ide_in_Hom by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
	+ using assms E.eval_Assoc'_Ide by fastforce
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma can_Ide_self:
	+ assumes "Ide t"
	+ shows "can t t = \<lbrace>t\<rbrace>"
	+ proof (unfold can_def)
	+ show "\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>t\<rbrace>"
	+ proof (intro E.eval_eqI)
	+ show "VPar (Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) t"
	+ using assms red_in_Hom Inv_in_Hom Ide_implies_Can Can_Inv Can_red(1) Ide_in_Hom(2)
	+ by auto
	+ show "\<^bold>\<lfloor>Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms red_in_Hom Inv_in_Hom Ide_implies_Can Cod_Inv
	+ by (metis (mono_tags, lifting) Can_red(1) Nml_Nmlize(1) Nmlize.simps(4)
	+ Nmlize_Inv Ide_Nmlize_Ide Nmlize_red Inv_Ide VcompNml_Ide_Nml
	+ \<open>VPar (Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) t\<close>)
	+ qed
	+ qed
	+
	+ subsection "Rules for Whiskering"
	+
	+ lemma whisker_can_right_0:
	+ assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "ide f" and "Src t = \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0"
	+ shows "can u t \<star> f = can (u \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) (t \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
	+ proof -
	+ have "f = can \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<langle>f\<^bold>\<rangle>"
	+ using assms can_Ide_self by simp
	+ thus ?thesis
	+ using assms Ide_implies_Arr hcomp_can
	+ by (metis Nml_Nmlize(2) Ide.simps(2) Trg.simps(2))
	+ qed
	+
	+ lemma whisker_can_right_1:
	+ assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "obj a" and "Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
	+ shows "can u t \<star> a = can (u \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) (t \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
	+ proof -
	+ have "a = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
	+ using assms can_Ide_self by auto
	+ thus ?thesis
	+ using assms Ide_implies_Arr hcomp_can
	+ by (metis Nml_Nmlize(2) Ide.simps(1) Trg.simps(1))
	+ qed
	+
	+ lemma whisker_can_left_0:
	+ assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "ide g" and "Trg t = \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0"
	+ shows "g \<star> can u t = can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> u) (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> t)"
	+ proof -
	+ have "g = can \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<langle>g\<^bold>\<rangle>"
	+ using assms can_Ide_self by simp
	+ thus ?thesis
	+ using assms Ide_implies_Arr hcomp_can
	+ by (metis Nml_Nmlize(3) Ide.simps(2) Src.simps(2))
	+ qed
	+
	+ lemma whisker_can_left_1:
	+ assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "obj b" and "Trg t = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
	+ shows "b \<star> can u t = can (\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> u) (\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> t)"
	+ proof -
	+ have "b = can \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
	+ using assms can_Ide_self by auto
	+ thus ?thesis
	+ using assms Ide_implies_Arr hcomp_can
	+ by (metis Nml_Nmlize(3) Ide.simps(1) Src.simps(1))
	+ qed
	+
	+ end
	+
	+end
	diff --git a/thys/Bicategory/CategoryWithPullbacks.thy b/thys/Bicategory/CategoryWithPullbacks.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/CategoryWithPullbacks.thy
	@@ -0,0 +1,1268 @@
	+(* Title: CategoryWithPullbacks
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Category with Pullbacks"
	+
	+theory CategoryWithPullbacks
	+imports Category3.Limit
	+begin
	+
	+text \<open>
	+ In this section, we give a traditional definition of pullbacks in a category as
	+ limits of cospan diagrams and we define a locale \<open>category_with_pullbacks\<close> that
	+ is satisfied by categories in which every cospan diagram has a limit.
	+ These definitions build on the general definition of limit that we gave in
	+ @{theory Category3.Limit}. We then define a locale \<open>elementary_category_with_pullbacks\<close>
	+ that axiomatizes categories equipped with chosen functions that assign to each cospan
	+ a corresponding span of ``projections'', which enjoy the familiar universal property
	+ of a pullback. After developing consequences of the axioms, we prove that the two
	+ locales are in agreement, in the sense that every interpretation of
	+ \<open>category_with_pullbacks\<close> extends to an interpretation of
	+ \<open>elementary_category_with_pullbacks\<close>, and conversely, the underlying category of
	+ an interpretation of \<open>elementary_category_with_pullbacks\<close> always yields an interpretation
	+ of \<open>category_with_pullbacks\<close>.
	+\<close>
	+
	+ subsection "Commutative Squares"
	+
	+ context category
	+ begin
	+
	+ text \<open>
	+ The following provides some useful technology for working with commutative squares.
	+ \<close>
	+
	+ definition commutative_square
	+ where "commutative_square f g h k \<equiv> cospan f g \<and> span h k \<and> dom f = cod h \<and> f \<cdot> h = g \<cdot> k"
	+
	+ lemma commutative_squareI [intro, simp]:
	+ assumes "cospan f g" and "span h k" and "dom f = cod h" and "f \<cdot> h = g \<cdot> k"
	+ shows "commutative_square f g h k"
	+ using assms commutative_square_def by auto
	+
	+ lemma commutative_squareE [elim]:
	+ assumes "commutative_square f g h k"
	+ and "\<lbrakk> arr f; arr g; arr h; arr k; cod f = cod g; dom h = dom k; dom f = cod h;
	+ dom g = cod k; f \<cdot> h = g \<cdot> k \<rbrakk> \<Longrightarrow> T"
	+ shows T
	+ using assms commutative_square_def
	+ by (metis (mono_tags, lifting) seqE seqI)
	+
	+ lemma commutative_square_comp_arr:
	+ assumes "commutative_square f g h k" and "seq h l"
	+ shows "commutative_square f g (h \<cdot> l) (k \<cdot> l)"
	+ using assms
	+ apply (elim commutative_squareE, intro commutative_squareI, auto)
	+ using comp_assoc by metis
	+
	+ lemma arr_comp_commutative_square:
	+ assumes "commutative_square f g h k" and "seq l f"
	+ shows "commutative_square (l \<cdot> f) (l \<cdot> g) h k"
	+ using assms comp_assoc
	+ by (elim commutative_squareE, intro commutative_squareI, auto)
	+
	+ end
	+
	+ subsection "Cospan Diagrams"
	+
	+ (* TODO: Rework the ugly development of equalizers into this form. *)
	+
	+ text \<open>
	+ The ``shape'' of a cospan diagram is a category having two non-identity arrows
	+ with distinct domains and a common codomain.
	+ \<close>
	+
	+ locale cospan_shape
	+ begin
	+
	+ datatype Arr = Null \| AA \| BB \| TT \| AT \| BT
	+
	+ fun comp
	+ where "comp AA AA = AA"
	+ \| "comp AT AA = AT"
	+ \| "comp TT AT = AT"
	+ \| "comp BB BB = BB"
	+ \| "comp BT BB = BT"
	+ \| "comp TT BT = BT"
	+ \| "comp TT TT = TT"
	+ \| "comp _ _ = Null"
	+
	+ interpretation partial_magma comp
	+ proof
	+ show "\<exists>!n. \<forall>f. comp n f = n \<and> comp f n = n"
	+ proof
	+ show "\<forall>f. comp Null f = Null \<and> comp f Null = Null" by simp
	+ show "\<And>n. \<forall>f. comp n f = n \<and> comp f n = n \<Longrightarrow> n = Null"
	+ by (metis comp.simps(8))
	+ qed
	+ qed
	+
	+ lemma null_char:
	+ shows "null = Null"
	+ proof -
	+ have "\<forall>f. comp Null f = Null \<and> comp f Null = Null" by simp
	+ thus ?thesis
	+ using null_def ex_un_null theI [of "\<lambda>n. \<forall>f. comp n f = n \<and> comp f n = n"]
	+ by (metis partial_magma.comp_null(2) partial_magma_axioms)
	+ qed
	+
	+ lemma ide_char:
	+ shows "ide f \<longleftrightarrow> f = AA \<or> f = BB \<or> f = TT"
	+ proof
	+ show "ide f \<Longrightarrow> f = AA \<or> f = BB \<or> f = TT"
	+ using ide_def null_char by (cases f, simp_all)
	+ show "f = AA \<or> f = BB \<or> f = TT \<Longrightarrow> ide f"
	+ proof -
	+ have 1: "\<And>f g. f = AA \<or> f = BB \<or> f = TT \<Longrightarrow>
	+ comp f f \<noteq> Null \<and>
	+ (comp g f \<noteq> Null \<longrightarrow> comp g f = g) \<and>
	+ (comp f g \<noteq> Null \<longrightarrow> comp f g = g)"
	+ proof -
	+ fix f g
	+ show "f = AA \<or> f = BB \<or> f = TT \<Longrightarrow>
	+ comp f f \<noteq> Null \<and>
	+ (comp g f \<noteq> Null \<longrightarrow> comp g f = g) \<and>
	+ (comp f g \<noteq> Null \<longrightarrow> comp f g = g)"
	+ by (cases f; cases g, auto)
	+ qed
	+ assume f: "f = AA \<or> f = BB \<or> f = TT"
	+ show "ide f"
	+ using f 1 ide_def null_char by simp
	+ qed
	+ qed
	+
	+ fun Dom
	+ where "Dom AA = AA"
	+ \| "Dom BB = BB"
	+ \| "Dom TT = TT"
	+ \| "Dom AT = AA"
	+ \| "Dom BT = BB"
	+ \| "Dom _ = Null"
	+
	+ fun Cod
	+ where "Cod AA = AA"
	+ \| "Cod BB = BB"
	+ \| "Cod TT = TT"
	+ \| "Cod AT = TT"
	+ \| "Cod BT = TT"
	+ \| "Cod _ = Null"
	+
	+ lemma domains_char':
	+ shows "domains f = (if f = Null then {} else {Dom f})"
	+ proof (cases "f = Null")
	+ show "f = Null \<Longrightarrow> ?thesis"
	+ using domains_null null_char by auto
	+ show "f \<noteq> Null \<Longrightarrow> ?thesis"
	+ proof -
	+ assume f: "f \<noteq> Null"
	+ have "Dom f \<in> domains f"
	+ using f domains_def ide_char null_char by (cases f, auto)
	+ moreover have "\<And>a. a \<in> domains f \<Longrightarrow> a = Dom f"
	+ using f domains_def ide_char null_char by (cases f, auto)
	+ ultimately have "domains f = {Dom f}" by blast
	+ thus ?thesis using f by simp
	+ qed
	+ qed
	+
	+ lemma codomains_char':
	+ shows "codomains f = (if f = Null then {} else {Cod f})"
	+ proof (cases "f = Null")
	+ show "f = Null \<Longrightarrow> ?thesis"
	+ using codomains_null null_char by auto
	+ show "f \<noteq> Null \<Longrightarrow> ?thesis"
	+ proof -
	+ assume f: "f \<noteq> Null"
	+ have "Cod f \<in> codomains f"
	+ using f codomains_def ide_char null_char by (cases f, auto)
	+ moreover have "\<And>a. a \<in> codomains f \<Longrightarrow> a = Cod f"
	+ using f codomains_def ide_char null_char by (cases f, auto)
	+ ultimately have "codomains f = {Cod f}" by blast
	+ thus ?thesis using f by simp
	+ qed
	+ qed
	+
	+ lemma arr_char:
	+ shows "arr f \<longleftrightarrow> f \<noteq> Null"
	+ using arr_def domains_char' codomains_char' by simp
	+
	+ lemma seq_char:
	+ shows "seq g f \<longleftrightarrow> (f = AA \<and> (g = AA \<or> g = AT)) \<or>
	+ (f = BB \<and> (g = BB \<or> g = BT)) \<or>
	+ (f = AT \<and> g = TT) \<or>
	+ (f = BT \<and> g = TT) \<or>
	+ (f = TT \<and> g = TT)"
	+ using arr_char null_char
	+ by (cases f; cases g, simp_all)
	+
	+ interpretation category comp
	+ proof
	+ show "\<And>g f. comp g f \<noteq> null \<Longrightarrow> seq g f"
	+ using null_char arr_char seq_char by simp
	+ show "\<And>f. (domains f \<noteq> {}) = (codomains f \<noteq> {})"
	+ using domains_char' codomains_char' by auto
	+ show "\<And>h g f. seq h g \<Longrightarrow> seq (comp h g) f \<Longrightarrow> seq g f"
	+ proof -
	+ fix f g h
	+ show "seq h g \<Longrightarrow> seq (comp h g) f \<Longrightarrow> seq g f"
	+ using seq_char arr_char
	+ by (cases g; cases h; simp_all)
	+ qed
	+ show "\<And>h g f. seq h (comp g f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
	+ proof -
	+ fix f g h
	+ show "seq h (comp g f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
	+ using seq_char arr_char
	+ by (cases f; cases g; simp_all)
	+ qed
	+ show "\<And>g f h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (comp h g) f"
	+ proof -
	+ fix f g h
	+ show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (comp h g) f"
	+ using seq_char arr_char
	+ by (cases f; simp_all; cases g; simp_all; cases h; auto)
	+ qed
	+ show "\<And>g f h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> comp (comp h g) f = comp h (comp g f)"
	+ proof -
	+ fix f g h
	+ show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> comp (comp h g) f = comp h (comp g f)"
	+ using seq_char
	+ by (cases f; simp_all; cases g; simp_all; cases h; auto)
	+ qed
	+ qed
	+
	+ lemma is_category:
	+ shows "category comp"
	+ ..
	+
	+ (*
	+ * TODO: The statement of domains_char and codomains_char in Category should be corrected
	+ * so that they are true characterizations that cover the case of null.
	+ *)
	+
	+ lemma dom_char:
	+ shows "dom = Dom"
	+ using dom_def domains_char domains_char' null_char by auto
	+
	+ lemma cod_char:
	+ shows "cod = Cod"
	+ using cod_def codomains_char codomains_char' null_char by auto
	+
	+ end
	+
	+ sublocale cospan_shape \<subseteq> category comp
	+ using is_category by auto
	+
	+ locale cospan_diagram =
	+ J: cospan_shape +
	+ C: category C
	+ for C :: "'c comp" (infixr "\<cdot>" 55)
	+ and f0 :: 'c
	+ and f1 :: 'c +
	+ assumes is_cospan: "C.cospan f0 f1"
	+ begin
	+
	+ no_notation J.comp (infixr "\<cdot>" 55)
	+ notation J.comp (infixr "\<cdot>\<^sub>J" 55)
	+
	+ fun map
	+ where "map J.AA = C.dom f0"
	+ \| "map J.BB = C.dom f1"
	+ \| "map J.TT = C.cod f0"
	+ \| "map J.AT = f0"
	+ \| "map J.BT = f1"
	+ \| "map _ = C.null"
	+
	+ end
	+
	+ sublocale cospan_diagram \<subseteq> diagram J.comp C map
	+ proof
	+ show "\<And>f. \<not> J.arr f \<Longrightarrow> map f = C.null"
	+ using J.arr_char by simp
	+ fix f
	+ assume f: "J.arr f"
	+ show "C.arr (map f)"
	+ using f J.arr_char is_cospan by (cases f, simp_all)
	+ show "C.dom (map f) = map (J.dom f)"
	+ using f J.arr_char J.dom_char is_cospan by (cases f, simp_all)
	+ show "C.cod (map f) = map (J.cod f)"
	+ using f J.arr_char J.cod_char is_cospan by (cases f, simp_all)
	+ next
	+ fix f g
	+ assume fg: "J.seq g f"
	+ show "map (g \<cdot>\<^sub>J f) = map g \<cdot> map f"
	+ using fg J.seq_char J.null_char J.not_arr_null is_cospan
	+ apply (cases f; cases g, simp_all)
	+ using C.comp_arr_dom C.comp_cod_arr by auto
	+ qed
	+
	+ subsection "Category with Pullbacks"
	+
	+ text \<open>
	+ A \emph{pullback} in a category @{term C} is a limit of a cospan diagram in @{term C}.
	+ \<close>
	+
	+ context cospan_diagram
	+ begin
	+
	+ definition mkCone
	+ where "mkCone p0 p1 \<equiv> \<lambda>j. if j = J.AA then p0
	+ else if j = J.BB then p1
	+ else if j = J.AT then f0 \<cdot> p0
	+ else if j = J.BT then f1 \<cdot> p1
	+ else if j = J.TT then f0 \<cdot> p0
	+ else C.null"
	+
	+ abbreviation is_rendered_commutative_by
	+ where "is_rendered_commutative_by p0 p1 \<equiv> C.seq f0 p0 \<and> f0 \<cdot> p0 = f1 \<cdot> p1"
	+
	+ abbreviation has_as_pullback
	+ where "has_as_pullback p0 p1 \<equiv> limit_cone (C.dom p0) (mkCone p0 p1)"
	+
	+ lemma cone_mkCone:
	+ assumes "is_rendered_commutative_by p0 p1"
	+ shows "cone (C.dom p0) (mkCone p0 p1)"
	+ proof -
	+ interpret E: constant_functor J.comp C \<open>C.dom p0\<close>
	+ apply unfold_locales using assms by auto
	+ show "cone (C.dom p0) (mkCone p0 p1)"
	+ proof
	+ fix f
	+ show "\<not> J.arr f \<Longrightarrow> mkCone p0 p1 f = C.null"
	+ using mkCone_def J.arr_char by simp
	+ assume f: "J.arr f"
	+ show "C.dom (mkCone p0 p1 f) = E.map (J.dom f)"
	+ using assms f mkCone_def J.arr_char J.dom_char
	+ apply (cases f, simp_all)
	+ apply (metis C.dom_comp)
	+ apply (metis C.dom_comp)
	+ apply (metis C.dom_comp)
	+ by (metis C.dom_comp)
	+ show "C.cod (mkCone p0 p1 f) = map (J.cod f)"
	+ using assms f mkCone_def J.arr_char J.cod_char is_cospan
	+ by (cases f, auto)
	+ show "map f \<cdot> mkCone p0 p1 (J.dom f) = mkCone p0 p1 f"
	+ using assms f mkCone_def J.arr_char J.dom_char C.comp_ide_arr is_cospan
	+ by (cases f, auto)
	+ show "mkCone p0 p1 (J.cod f) \<cdot> E.map f = mkCone p0 p1 f"
	+ using assms f mkCone_def J.arr_char J.cod_char C.comp_arr_dom
	+ apply (cases f, auto)
	+ apply (metis C.dom_comp C.seqE)
	+ apply (metis C.dom_comp)
	+ apply (metis C.dom_comp)
	+ by (metis C.dom_comp)
	+ qed
	+ qed
	+
	+ lemma is_rendered_commutative_by_cone:
	+ assumes "cone a \<chi>"
	+ shows "is_rendered_commutative_by (\<chi> J.AA) (\<chi> J.BB)"
	+ proof -
	+ interpret \<chi>: cone J.comp C map a \<chi>
	+ using assms by auto
	+ show ?thesis
	+ proof
	+ show "C.seq f0 (\<chi> J.AA)"
	+ by (metis C.seqI J.category_axioms J.cod_char J.seq_char \<chi>.preserves_cod
	+ \<chi>.preserves_reflects_arr category.seqE cospan_diagram.is_cospan
	+ cospan_diagram_axioms cospan_shape.Cod.simps(1) map.simps(1))
	+ show "f0 \<cdot> \<chi> J.AA = f1 \<cdot> \<chi> J.BB"
	+ by (metis J.cod_char J.dom_char \<chi>.A.map_simp \<chi>.naturality
	+ cospan_shape.Cod.simps(4-5) cospan_shape.Dom.simps(4-5)
	+ cospan_shape.comp.simps(2,5) cospan_shape.seq_char
	+ map.simps(4-5))
	+ qed
	+ qed
	+
	+ lemma mkCone_cone:
	+ assumes "cone a \<chi>"
	+ shows "mkCone (\<chi> J.AA) (\<chi> J.BB) = \<chi>"
	+ proof -
	+ interpret \<chi>: cone J.comp C map a \<chi>
	+ using assms by auto
	+ have 1: "is_rendered_commutative_by (\<chi> J.AA) (\<chi> J.BB)"
	+ using assms is_rendered_commutative_by_cone by blast
	+ interpret mkCone_\<chi>: cone J.comp C map \<open>C.dom (\<chi> J.AA)\<close> \<open>mkCone (\<chi> J.AA) (\<chi> J.BB)\<close>
	+ using assms cone_mkCone 1 by auto
	+ show ?thesis
	+ proof -
	+ have "\<And>j. j = J.AA \<Longrightarrow> mkCone (\<chi> J.AA) (\<chi> J.BB) j = \<chi> j"
	+ using mkCone_def \<chi>.is_extensional by simp
	+ moreover have "\<And>j. j = J.BB \<Longrightarrow> mkCone (\<chi> J.AA) (\<chi> J.BB) j = \<chi> j"
	+ using mkCone_def \<chi>.is_extensional by simp
	+ moreover have "\<And>j. j = J.TT \<Longrightarrow> mkCone (\<chi> J.AA) (\<chi> J.BB) j = \<chi> j"
	+ using 1 mkCone_def \<chi>.is_extensional \<chi>.A.map_simp \<chi>.preserves_comp_1
	+ cospan_shape.seq_char
	+ by (metis J.Arr.distinct(14) J.Arr.distinct(20) J.category_axioms \<chi>.is_natural_2
	+ category.seqE cospan_shape.Arr.distinct(25) cospan_shape.Arr.distinct(27)
	+ cospan_shape.comp.simps(5) map.simps(5))
	+ ultimately have "\<And>j. J.ide j \<Longrightarrow> mkCone (\<chi> J.AA) (\<chi> J.BB) j = \<chi> j"
	+ using J.ide_char by auto
	+ thus "mkCone (\<chi> J.AA) (\<chi> J.BB) = \<chi>"
	+ using mkCone_def NaturalTransformation.eqI [of J.comp C]
	+ \<chi>.natural_transformation_axioms mkCone_\<chi>.natural_transformation_axioms
	+ J.ide_char
	+ by simp
	+ qed
	+ qed
	+
	+ end
	+
	+ locale pullback_cone =
	+ J: cospan_shape +
	+ C: category C +
	+ D: cospan_diagram C f0 f1 +
	+ limit_cone J.comp C D.map \<open>C.dom p0\<close> \<open>D.mkCone p0 p1\<close>
	+ for C :: "'c comp" (infixr "\<cdot>" 55)
	+ and f0 :: 'c
	+ and f1 :: 'c
	+ and p0 :: 'c
	+ and p1 :: 'c
	+ begin
	+
	+ (* TODO: Equalizer should be simplifiable in the same way. *)
	+ lemma renders_commutative:
	+ shows "D.is_rendered_commutative_by p0 p1"
	+ using D.mkCone_def D.cospan_diagram_axioms cone_axioms
	+ cospan_diagram.is_rendered_commutative_by_cone
	+ by fastforce
	+
	+ lemma is_universal':
	+ assumes "D.is_rendered_commutative_by p0' p1'"
	+ shows "\<exists>!h. \<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright> \<and> p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
	+ proof -
	+ have "D.cone (C.dom p0') (D.mkCone p0' p1')"
	+ using assms D.cone_mkCone by blast
	+ hence 1: "\<exists>!h. \<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright> \<and>
	+ D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
	+ using is_universal [of "C.dom p0'" "D.mkCone p0' p1'"] by simp
	+ have 2: "\<And>h. \<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright> \<Longrightarrow>
	+ D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' \<longleftrightarrow>
	+ p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
	+ proof -
	+ fix h
	+ assume h: "\<guillemotleft>h : C.dom p0' \<rightarrow> C.dom p0\<guillemotright>"
	+ show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' \<longleftrightarrow>
	+ p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
	+ proof
	+ assume 3: "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
	+ show "p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
	+ proof
	+ show "p0 \<cdot> h = p0'"
	+ proof -
	+ have "p0' = D.mkCone p0' p1' J.AA"
	+ using D.mkCone_def J.arr_char by simp
	+ also have "... = D.cones_map h (D.mkCone p0 p1) J.AA"
	+ using 3 by simp
	+ also have "... = p0 \<cdot> h"
	+ using h D.mkCone_def J.arr_char cone_\<chi> by auto
	+ finally show ?thesis by auto
	+ qed
	+ show "p1 \<cdot> h = p1'"
	+ proof -
	+ have "p1' = D.mkCone p0' p1' J.BB"
	+ using D.mkCone_def J.arr_char by simp
	+ also have "... = D.cones_map h (D.mkCone p0 p1) J.BB"
	+ using 3 by simp
	+ also have "... = p1 \<cdot> h"
	+ using h D.mkCone_def J.arr_char cone_\<chi> by auto
	+ finally show ?thesis by auto
	+ qed
	+ qed
	+ next
	+ assume 4: "p0 \<cdot> h = p0' \<and> p1 \<cdot> h = p1'"
	+ show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
	+ proof
	+ fix j
	+ have "\<not> J.arr j \<Longrightarrow> D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
	+ using h cone_axioms D.mkCone_def J.arr_char by auto
	+ moreover have "J.arr j \<Longrightarrow>
	+ D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
	+ using assms h 4 cone_\<chi> D.mkCone_def J.arr_char [of J.AT] renders_commutative
	+ C.comp_assoc
	+ by fastforce
	+ ultimately show "D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
	+ using J.arr_char J.Dom.cases by blast
	+ qed
	+ qed
	+ qed
	+ thus ?thesis using 1 by blast
	+ qed
	+
	+ lemma induced_arrowI':
	+ assumes "D.is_rendered_commutative_by p0' p1'"
	+ shows "\<guillemotleft>induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0' \<rightarrow> C.dom p0\<guillemotright>"
	+ and "p0 \<cdot> induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
	+ and "p1 \<cdot> induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
	+ proof -
	+ interpret A': constant_functor J.comp C \<open>C.dom p0'\<close>
	+ using assms by (unfold_locales, auto)
	+ have cone: "D.cone (C.dom p0') (D.mkCone p0' p1')"
	+ using assms D.cone_mkCone [of p0' p1'] by blast
	+ show 1: "p0 \<cdot> induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
	+ proof -
	+ have "p0 \<cdot> induced_arrow (C.dom p0') (D.mkCone p0' p1') =
	+ D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
	+ (D.mkCone p0 p1) J.AA"
	+ using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_\<chi> by force
	+ also have "... = p0'"
	+ proof -
	+ have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
	+ (D.mkCone p0 p1) =
	+ D.mkCone p0' p1'"
	+ using cone induced_arrowI by blast
	+ thus ?thesis
	+ using J.arr_char D.mkCone_def by simp
	+ qed
	+ finally show ?thesis by auto
	+ qed
	+ show 2: "p1 \<cdot> induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
	+ proof -
	+ have "p1 \<cdot> induced_arrow (C.dom p1') (D.mkCone p0' p1') =
	+ D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
	+ (D.mkCone p0 p1) J.BB"
	+ proof -
	+ have "C.dom p0' = C.dom p1'"
	+ using assms by (metis C.dom_comp)
	+ thus ?thesis
	+ using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_\<chi> by force
	+ qed
	+ also have "... = p1'"
	+ proof -
	+ have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
	+ (D.mkCone p0 p1) =
	+ D.mkCone p0' p1'"
	+ using cone induced_arrowI by blast
	+ thus ?thesis
	+ using J.arr_char D.mkCone_def by simp
	+ qed
	+ finally show ?thesis by auto
	+ qed
	+ show "\<guillemotleft>induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0' \<rightarrow> C.dom p0\<guillemotright>"
	+ using 1 cone induced_arrowI by simp
	+ qed
	+
	+ end
	+
	+ context category
	+ begin
	+
	+ definition has_as_pullback
	+ where "has_as_pullback f0 f1 p0 p1 \<equiv>
	+ cospan f0 f1 \<and> cospan_diagram.has_as_pullback C f0 f1 p0 p1"
	+
	+ definition has_pullbacks
	+ where "has_pullbacks = (\<forall>f0 f1. cospan f0 f1 \<longrightarrow> (\<exists>p0 p1. has_as_pullback f0 f1 p0 p1))"
	+
	+ end
	+
	+ locale category_with_pullbacks =
	+ category +
	+ assumes has_pullbacks: has_pullbacks
	+
	+ subsection "Elementary Category with Pullbacks"
	+
	+ text \<open>
	+ An \emph{elementary category with pullbacks} is a category equipped with a specific
	+ way of mapping each cospan to a span such that the resulting square commutes and
	+ such that the span is universal for that property. It is useful to assume that the
	+ functions mapping a cospan to the two projections of the pullback, are extensional;
	+ that is, they yield @{term null} when applied to arguments that do not form a cospan.
	+ \<close>
	+
	+ locale elementary_category_with_pullbacks =
	+ category C
	+ for C :: "'a comp" (infixr "\<cdot>" 55)
	+ and prj0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>0[_, _]")
	+ and prj1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>1[_, _]") +
	+ assumes prj0_ext: "\<not> cospan f g \<Longrightarrow> \<p>\<^sub>0[f, g] = null"
	+ and prj1_ext: "\<not> cospan f g \<Longrightarrow> \<p>\<^sub>1[f, g] = null"
	+ and pullback_commutes [intro]: "cospan f g \<Longrightarrow> commutative_square f g \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]"
	+ and universal: "commutative_square f g h k \<Longrightarrow> \<exists>!l. \<p>\<^sub>1[f, g] \<cdot> l = h \<and> \<p>\<^sub>0[f, g] \<cdot> l = k"
	+
	+ subsection "Properties"
	+
	+ text \<open>
	+ Next, we go on to develop the properties of an elementary category with pullbacks.
	+ \<close>
	+
	+ context elementary_category_with_pullbacks
	+ begin
	+
	+ lemma pullback_commutes':
	+ assumes "cospan f g"
	+ shows "f \<cdot> \<p>\<^sub>1[f, g] = g \<cdot> \<p>\<^sub>0[f, g]"
	+ using assms commutative_square_def by blast
	+
	+ lemma prj0_in_hom':
	+ assumes "cospan f g"
	+ shows "\<guillemotleft>\<p>\<^sub>0[f, g] : dom \<p>\<^sub>0[f, g] \<rightarrow> dom g\<guillemotright>"
	+ using assms pullback_commutes
	+ by (metis category.commutative_squareE category_axioms in_homI)
	+
	+ lemma prj1_in_hom':
	+ assumes "cospan f g"
	+ shows "\<guillemotleft>\<p>\<^sub>1[f, g] : dom \<p>\<^sub>0[f, g] \<rightarrow> dom f\<guillemotright>"
	+ using assms pullback_commutes
	+ by (metis category.commutative_squareE category_axioms in_homI)
	+
	+ text \<open>
	+ The following gives us a notation for the common domain of the two projections
	+ of a pullback.
	+ \<close>
	+
	+ definition pbdom (infix "\<down>\<down>" 51)
	+ where "f \<down>\<down> g \<equiv> dom \<p>\<^sub>0[f, g]"
	+
	+ lemma pbdom_in_hom [intro]:
	+ assumes "cospan f g"
	+ shows "\<guillemotleft>f \<down>\<down> g : f \<down>\<down> g \<rightarrow> f \<down>\<down> g\<guillemotright>"
	+ unfolding pbdom_def
	+ using assms prj0_in_hom'
	+ by (metis arr_dom_iff_arr arr_iff_in_hom cod_dom dom_dom in_homE)
	+
	+ lemma ide_pbdom [simp]:
	+ assumes "cospan f g"
	+ shows "ide (f \<down>\<down> g)"
	+ using assms ide_in_hom by auto[1]
	+
	+ lemma prj0_in_hom [intro, simp]:
	+ assumes "cospan f g" and "a = f \<down>\<down> g" and "b = dom g"
	+ shows "\<guillemotleft>\<p>\<^sub>0[f, g] : a \<rightarrow> b\<guillemotright>"
	+ unfolding pbdom_def
	+ using assms prj0_in_hom' by (simp add: pbdom_def)
	+
	+ lemma prj1_in_hom [intro, simp]:
	+ assumes "cospan f g" and "a = f \<down>\<down> g" and "b = dom f"
	+ shows "\<guillemotleft>\<p>\<^sub>1[f, g] : a \<rightarrow> b\<guillemotright>"
	+ unfolding pbdom_def
	+ using assms prj1_in_hom' by (simp add: pbdom_def)
	+
	+ lemma prj0_simps [simp]:
	+ assumes "cospan f g"
	+ shows "arr \<p>\<^sub>0[f, g]" and "dom \<p>\<^sub>0[f, g] = f \<down>\<down> g" and "cod \<p>\<^sub>0[f, g] = dom g"
	+ using assms prj0_in_hom by (blast, blast, blast)
	+
	+ lemma prj0_simps_arr [iff]:
	+ shows "arr \<p>\<^sub>0[f, g] \<longleftrightarrow> cospan f g"
	+ proof
	+ show "cospan f g \<Longrightarrow> arr \<p>\<^sub>0[f, g]"
	+ using prj0_in_hom by auto
	+ show "arr \<p>\<^sub>0[f, g] \<Longrightarrow> cospan f g"
	+ using prj0_ext not_arr_null by metis
	+ qed
	+
	+ lemma prj1_simps [simp]:
	+ assumes "cospan f g"
	+ shows "arr \<p>\<^sub>1[f, g]" and "dom \<p>\<^sub>1[f, g] = f \<down>\<down> g" and "cod \<p>\<^sub>1[f, g] = dom f"
	+ using assms prj1_in_hom by (blast, blast, blast)
	+
	+ lemma prj1_simps_arr [iff]:
	+ shows "arr \<p>\<^sub>1[f, g] \<longleftrightarrow> cospan f g"
	+ proof
	+ show "cospan f g \<Longrightarrow> arr \<p>\<^sub>1[f, g]"
	+ using prj1_in_hom by auto
	+ show "arr \<p>\<^sub>1[f, g] \<Longrightarrow> cospan f g"
	+ using prj1_ext not_arr_null by metis
	+ qed
	+
	+ lemma span_prj:
	+ assumes "cospan f g"
	+ shows "span \<p>\<^sub>0[f, g] \<p>\<^sub>1[f, g]"
	+ using assms by simp
	+
	+ text \<open>
	+ We introduce a notation for tupling, which produces the induced arrow into a pullback.
	+ In our notation, the ``$0$-side'', which we regard as the input, occurs on the right,
	+ and the ``$1$-side'', which we regard as the output, occurs on the left.
	+ \<close>
	+
	+ definition tuple ("\<langle>_ \<lbrakk>_, _\<rbrakk> _\<rangle>")
	+ where "\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<equiv> if commutative_square f g h k then
	+ THE l. \<p>\<^sub>0[f, g] \<cdot> l = k \<and> \<p>\<^sub>1[f, g] \<cdot> l = h
	+ else null"
	+
	+ lemma tuple_in_hom [intro]:
	+ assumes "commutative_square f g h k"
	+ shows "\<guillemotleft>\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> : dom h \<rightarrow> f \<down>\<down> g\<guillemotright>"
	+ proof
	+ have 1: "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = k \<and> \<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = h"
	+ unfolding tuple_def
	+ using assms universal theI [of "\<lambda>l. \<p>\<^sub>0[f, g] \<cdot> l = k \<and> \<p>\<^sub>1[f, g] \<cdot> l = h"]
	+ apply simp
	+ by meson
	+ show "arr \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle>"
	+ using assms 1
	+ apply (elim commutative_squareE)
	+ by (metis (no_types, lifting) seqE)
	+ show "dom \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = dom h"
	+ using assms 1
	+ apply (elim commutative_squareE)
	+ by (metis (no_types, lifting) dom_comp)
	+ show "cod \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = f \<down>\<down> g"
	+ unfolding pbdom_def
	+ using assms 1
	+ apply (elim commutative_squareE)
	+ by (metis seqE)
	+ qed
	+
	+ lemma tuple_is_extensional:
	+ assumes "\<not> commutative_square f g h k"
	+ shows "\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = null"
	+ unfolding tuple_def
	+ using assms by simp
	+
	+ lemma tuple_simps [simp]:
	+ assumes "commutative_square f g h k"
	+ shows "arr \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle>" and "dom \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = dom h" and "cod \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = f \<down>\<down> g"
	+ using assms tuple_in_hom apply blast
	+ using assms tuple_in_hom apply blast
	+ using assms tuple_in_hom by blast
	+
	+ lemma prj_tuple [simp]:
	+ assumes "commutative_square f g h k"
	+ shows "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = k" and "\<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = h"
	+ proof -
	+ have 1: "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = k \<and> \<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = h"
	+ unfolding tuple_def
	+ using assms universal theI [of "\<lambda>l. \<p>\<^sub>0[f, g] \<cdot> l = k \<and> \<p>\<^sub>1[f, g] \<cdot> l = h"]
	+ apply simp
	+ by meson
	+ show "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = k" using 1 by simp
	+ show "\<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> = h" using 1 by simp
	+ qed
	+
	+ lemma tuple_prj:
	+ assumes "cospan f g" and "seq \<p>\<^sub>1[f, g] h"
	+ shows "\<langle>\<p>\<^sub>1[f, g] \<cdot> h \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> h\<rangle> = h"
	+ proof -
	+ have 1: "commutative_square f g (\<p>\<^sub>1[f, g] \<cdot> h) (\<p>\<^sub>0[f, g] \<cdot> h)"
	+ using assms pullback_commutes
	+ by (simp add: commutative_square_comp_arr)
	+ have "\<p>\<^sub>0[f, g] \<cdot> \<langle>\<p>\<^sub>1[f, g] \<cdot> h \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> h\<rangle> = \<p>\<^sub>0[f, g] \<cdot> h"
	+ using assms 1 by simp
	+ moreover have "\<p>\<^sub>1[f, g] \<cdot> \<langle>\<p>\<^sub>1[f, g] \<cdot> h \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> h\<rangle> = \<p>\<^sub>1[f, g] \<cdot> h"
	+ using assms 1 by simp
	+ ultimately show ?thesis
	+ unfolding tuple_def
	+ using assms 1 universal [of f g "\<p>\<^sub>1[f, g] \<cdot> h" "\<p>\<^sub>0[f, g] \<cdot> h"]
	+ theI_unique [of "\<lambda>l. \<p>\<^sub>0[f, g] \<cdot> l = \<p>\<^sub>0[f, g] \<cdot> h \<and> \<p>\<^sub>1[f, g] \<cdot> l = \<p>\<^sub>1[f, g] \<cdot> h" h]
	+ by auto
	+ qed
	+
	+ lemma tuple_prj_spc [simp]:
	+ assumes "cospan f g"
	+ shows "\<langle>\<p>\<^sub>1[f, g] \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g]\<rangle> = f \<down>\<down> g"
	+ proof -
	+ have "\<langle>\<p>\<^sub>1[f, g] \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g]\<rangle> = \<langle>\<p>\<^sub>1[f, g] \<cdot> (f \<down>\<down> g) \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> (f \<down>\<down> g)\<rangle>"
	+ using assms comp_arr_dom by simp
	+ thus ?thesis
	+ using assms tuple_prj by simp
	+ qed
	+
	+ lemma prj_joint_monic:
	+ assumes "cospan f g" and "seq \<p>\<^sub>1[f, g] h" and "seq \<p>\<^sub>1[f, g] h'"
	+ and "\<p>\<^sub>0[f, g] \<cdot> h = \<p>\<^sub>0[f, g] \<cdot> h'" and "\<p>\<^sub>1[f, g] \<cdot> h = \<p>\<^sub>1[f, g] \<cdot> h'"
	+ shows "h = h'"
	+ proof -
	+ have "h = \<langle>\<p>\<^sub>1[f, g] \<cdot> h \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> h\<rangle>"
	+ using assms tuple_prj [of f g h] by simp
	+ also have "... = \<langle>\<p>\<^sub>1[f, g] \<cdot> h' \<lbrakk>f, g\<rbrakk> \<p>\<^sub>0[f, g] \<cdot> h'\<rangle>"
	+ using assms by simp
	+ also have "... = h'"
	+ using assms tuple_prj [of f g h'] by simp
	+ finally show ?thesis by blast
	+ qed
	+
	+ text \<open>
	+ The pullback of an identity along an arbitrary arrow is an isomorphism.
	+ \<close>
	+
	+ lemma iso_pullback_ide:
	+ assumes "cospan \<mu> \<nu>" and "ide \<mu>"
	+ shows "iso \<p>\<^sub>0[\<mu>, \<nu>]"
	+ proof -
	+ have "inverse_arrows \<p>\<^sub>0[\<mu>, \<nu>] \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle>"
	+ proof
	+ show 1: "ide (\<p>\<^sub>0[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle>)"
	+ proof -
	+ have "commutative_square \<mu> \<nu> \<nu> (dom \<nu>)"
	+ using assms comp_arr_dom comp_cod_arr by auto
	+ hence "\<p>\<^sub>0[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> = dom \<nu>"
	+ using assms prj_tuple(1) [of \<mu> \<nu> \<nu> "dom \<nu>"] by simp
	+ thus ?thesis
	+ using assms by simp
	+ qed
	+ show "ide (\<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>])"
	+ proof -
	+ have "\<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>] = (\<mu> \<down>\<down> \<nu>)"
	+ proof -
	+ have "\<p>\<^sub>0[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>] = \<p>\<^sub>0[\<mu>, \<nu>] \<cdot> (\<mu> \<down>\<down> \<nu>)"
	+ proof -
	+ have "\<p>\<^sub>0[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>] = (\<p>\<^sub>0[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle>) \<cdot> \<p>\<^sub>0[\<mu>, \<nu>]"
	+ using assms 1 comp_reduce by blast
	+ also have "... = dom \<nu> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>]"
	+ proof -
	+ have "commutative_square \<mu> \<nu> \<nu> (dom \<nu>)"
	+ using assms comp_arr_dom comp_cod_arr by auto
	+ thus ?thesis
	+ using assms prj_tuple(1) [of \<mu> \<nu> \<nu> "dom \<nu>"] by simp
	+ qed
	+ also have "... = \<p>\<^sub>0[\<mu>, \<nu>] \<cdot> (\<mu> \<down>\<down> \<nu>)"
	+ using assms prj0_in_hom [of \<mu> \<nu>] pullback_commutes comp_arr_dom comp_cod_arr
	+ by (metis in_homE)
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "\<p>\<^sub>1[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>] = \<p>\<^sub>1[\<mu>, \<nu>] \<cdot> (\<mu> \<down>\<down> \<nu>)"
	+ proof -
	+ have "\<p>\<^sub>1[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>] = (\<p>\<^sub>1[\<mu>, \<nu>] \<cdot> \<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle>) \<cdot> \<p>\<^sub>0[\<mu>, \<nu>]"
	+ by (simp add: assms(2) local.comp_assoc)
	+ also have "... = \<nu> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>]"
	+ proof -
	+ have "commutative_square \<mu> \<nu> \<nu> (dom \<nu>)"
	+ using assms comp_arr_dom comp_cod_arr by auto
	+ thus ?thesis
	+ using assms prj_tuple(2) [of \<mu> \<nu> \<nu> "dom \<nu>"] by simp
	+ qed
	+ also have "... = \<mu> \<cdot> \<p>\<^sub>1[\<mu>, \<nu>]"
	+ using assms pullback_commutes
	+ by (simp add: commutative_square_def)
	+ also have "... = \<p>\<^sub>1[\<mu>, \<nu>] \<cdot> (\<mu> \<down>\<down> \<nu>)"
	+ using assms comp_arr_dom comp_cod_arr pullback_commutes by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using assms prj0_in_hom prj1_in_hom
	+ prj_joint_monic [of \<mu> \<nu> "\<langle>\<nu> \<lbrakk>\<mu>, \<nu>\<rbrakk> dom \<nu>\<rangle> \<cdot> \<p>\<^sub>0[\<mu>, \<nu>]" "\<mu> \<down>\<down> \<nu>"]
	+ by (metis comp_arr_dom prj1_simps(1) prj1_simps(2))
	+ qed
	+ thus ?thesis
	+ using assms prj0_in_hom [of \<mu> \<nu>] ide_dom [of "\<p>\<^sub>1[\<mu>, \<nu>]"] by auto
	+ qed
	+ qed
	+ thus ?thesis by auto
	+ qed
	+
	+ lemma comp_tuple_arr:
	+ assumes "commutative_square f g h k" and "seq h l"
	+ shows "\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l = \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
	+ proof -
	+ have "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l = \<p>\<^sub>0[f, g] \<cdot> \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
	+ proof -
	+ have "\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l = (\<p>\<^sub>0[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle>) \<cdot> l"
	+ using comp_assoc by simp
	+ also have "... = k \<cdot> l"
	+ using assms prj_tuple(1) by auto
	+ also have "... = \<p>\<^sub>0[f, g] \<cdot> \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
	+ proof -
	+ have 1: "commutative_square f g (h \<cdot> l) (k \<cdot> l)"
	+ using assms commutative_square_comp_arr by auto
	+ show ?thesis
	+ using assms by (metis "1" prj_tuple(1))
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "\<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l = \<p>\<^sub>1[f, g] \<cdot> \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
	+ proof -
	+ have "\<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l = (\<p>\<^sub>1[f, g] \<cdot> \<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle>) \<cdot> l"
	+ using comp_assoc by simp
	+ also have "... = h \<cdot> l"
	+ using assms prj_tuple(2) by auto
	+ also have "... = \<p>\<^sub>1[f, g] \<cdot> \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
	+ proof -
	+ have 1: "commutative_square f g (h \<cdot> l) (k \<cdot> l)"
	+ using assms commutative_square_comp_arr by blast
	+ show ?thesis
	+ using assms by (metis "1" prj_tuple(2))
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "seq \<p>\<^sub>1[f, g] (\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l)"
	+ using assms tuple_in_hom [of f h g k] prj1_in_hom
	+ by (intro seqI, elim seqE, auto, fastforce)
	+ moreover have "seq \<p>\<^sub>1[f, g] \<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"
	+ using assms tuple_in_hom [of f "h \<cdot> l" g "k \<cdot> l"]
	+ using calculation(2) calculation(3) by auto
	+ ultimately show ?thesis
	+ using assms prj_joint_monic [of f g "\<langle>h \<lbrakk>f, g\<rbrakk> k\<rangle> \<cdot> l" "\<langle>h \<cdot> l \<lbrakk>f, g\<rbrakk> k \<cdot> l\<rangle>"]
	+ by auto
	+ qed
	+
	+ lemma pullback_arr_cod:
	+ assumes "arr f"
	+ shows "inverse_arrows \<p>\<^sub>1[f, cod f] \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>"
	+ and "inverse_arrows \<p>\<^sub>0[cod f, f] \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle>"
	+ proof -
	+ show "inverse_arrows \<p>\<^sub>1[f, cod f] \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>"
	+ proof
	+ have 1: "commutative_square f (cod f) (dom f) f"
	+ using assms comp_arr_dom comp_cod_arr by auto
	+ show "ide (\<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f])"
	+ proof -
	+ have "\<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f] = f \<down>\<down> cod f"
	+ proof -
	+ have "\<p>\<^sub>0[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f] = \<p>\<^sub>0[f, cod f] \<cdot> (f \<down>\<down> cod f)"
	+ proof -
	+ have "\<p>\<^sub>0[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f] =
	+ (\<p>\<^sub>0[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>) \<cdot> \<p>\<^sub>1[f, cod f]"
	+ using comp_assoc by simp
	+ also have "... = f \<cdot> \<p>\<^sub>1[f, cod f]"
	+ using assms 1 prj_tuple(1) [of f "dom f" "cod f" f] by simp
	+ also have "... = \<p>\<^sub>0[f, cod f] \<cdot> (f \<down>\<down> cod f)"
	+ using assms 1 pullback_commutes [of f "cod f"] comp_arr_dom comp_cod_arr
	+ by (metis commutative_squareE pbdom_def)
	+ finally show ?thesis by blast
	+ qed
	+ moreover
	+ have "\<p>\<^sub>1[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f] = \<p>\<^sub>1[f, cod f] \<cdot> (f \<down>\<down> cod f)"
	+ proof -
	+ have "\<p>\<^sub>1[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f] =
	+ (\<p>\<^sub>1[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>) \<cdot> \<p>\<^sub>1[f, cod f]"
	+ proof -
	+ have "seq \<p>\<^sub>1[f, cod f] \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>"
	+ using assms 1 prj1_in_hom [of f "cod f"]
	+ tuple_in_hom [of f "dom f" "cod f" f]
	+ by auto
	+ moreover have "seq \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<p>\<^sub>1[f, cod f]"
	+ using assms 1 prj1_in_hom [of f "cod f"]
	+ tuple_in_hom [of f "dom f" "cod f" f]
	+ by auto
	+ ultimately show ?thesis using comp_assoc by simp
	+ qed
	+ also have "... = dom f \<cdot> \<p>\<^sub>1[f, cod f]"
	+ using assms 1 prj_tuple(2) [of f "dom f" "cod f" f] by simp
	+ also have "... = \<p>\<^sub>1[f, cod f] \<cdot> (f \<down>\<down> cod f)"
	+ using assms comp_arr_dom comp_cod_arr by simp
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis
	+ using assms
	+ prj_joint_monic
	+ [of f "cod f" "\<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> \<cdot> \<p>\<^sub>1[f, cod f]" "f \<down>\<down> cod f"]
	+ by simp
	+ qed
	+ thus ?thesis
	+ using assms arr_cod cod_cod ide_dom prj1_simps_arr by simp
	+ qed
	+ show "ide (\<p>\<^sub>1[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle>)"
	+ proof -
	+ have "\<p>\<^sub>1[f, cod f] \<cdot> \<langle>dom f \<lbrakk>f, cod f\<rbrakk> f\<rangle> = dom f"
	+ using assms 1 by simp
	+ thus ?thesis using assms by simp
	+ qed
	+ qed
	+
	+ show "inverse_arrows \<p>\<^sub>0[cod f, f] \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle>"
	+ proof
	+ have 1: "commutative_square (cod f) f f (dom f)"
	+ using assms comp_arr_dom comp_cod_arr by auto
	+ show "ide (\<p>\<^sub>0[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle>)"
	+ proof -
	+ have "\<p>\<^sub>0[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> = dom f"
	+ using assms 1 prj_tuple(1) [of "cod f" f f "dom f"] by blast
	+ thus ?thesis using assms by simp
	+ qed
	+ show "ide (\<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f])"
	+ proof -
	+ have "\<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f] = cod f \<down>\<down> f"
	+ proof -
	+ have "\<p>\<^sub>0[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f] = \<p>\<^sub>0[cod f, f] \<cdot> (cod f \<down>\<down> f)"
	+ proof -
	+ have "\<p>\<^sub>0[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f] =
	+ (\<p>\<^sub>0[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle>) \<cdot> \<p>\<^sub>0[cod f, f]"
	+ using assms
	+ by (metis (no_types, lifting) category.ext category_axioms comp_reduce
	+ match_1 match_2 seqE)
	+ also have "... = dom f \<cdot> \<p>\<^sub>0[cod f, f]"
	+ using assms 1 prj_tuple(1) [of "cod f" f f "dom f"] by simp
	+ also have "... = \<p>\<^sub>0[cod f, f] \<cdot> (cod f \<down>\<down> f)"
	+ using assms comp_arr_dom comp_cod_arr by simp
	+ finally show ?thesis
	+ using prj0_in_hom by blast
	+ qed
	+ moreover
	+ have "\<p>\<^sub>1[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f] = \<p>\<^sub>1[cod f, f] \<cdot> (cod f \<down>\<down> f)"
	+ proof -
	+ have "\<p>\<^sub>1[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f] =
	+ (\<p>\<^sub>1[cod f, f] \<cdot> \<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle>) \<cdot> \<p>\<^sub>0[cod f, f]"
	+ using comp_assoc by simp
	+ also have "... = f \<cdot> \<p>\<^sub>0[cod f, f]"
	+ using assms 1 prj_tuple(2) [of "cod f" f f "dom f"] by simp
	+ also have "... = \<p>\<^sub>1[cod f, f] \<cdot> (cod f \<down>\<down> f)"
	+ using assms 1 pullback_commutes [of "cod f" f] comp_arr_dom comp_cod_arr
	+ by (metis (mono_tags, lifting) commutative_squareE pbdom_def)
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis
	+ using assms prj_joint_monic [of "cod f" f "\<langle>f \<lbrakk>cod f, f\<rbrakk> dom f\<rangle> \<cdot> \<p>\<^sub>0[cod f, f]"]
	+ by simp
	+ qed
	+ thus ?thesis using assms by simp
	+ qed
	+ qed
	+ qed
	+
	+ text \<open>
	+ The pullback of a monomorphism along itself is automatically symmetric: the left
	+ and right projections are equal.
	+ \<close>
	+
	+ lemma pullback_mono_self:
	+ assumes "mono f"
	+ shows "\<p>\<^sub>0[f, f] = \<p>\<^sub>1[f, f]"
	+ proof -
	+ have "f \<cdot> \<p>\<^sub>0[f, f] = f \<cdot> \<p>\<^sub>1[f, f]"
	+ using assms pullback_commutes [of f f]
	+ by (metis commutative_squareE mono_implies_arr)
	+ thus ?thesis
	+ using assms monoE [of f "\<p>\<^sub>1[f, f]" "\<p>\<^sub>0[f, f]"]
	+ by (metis mono_implies_arr prj0_simps(1) prj0_simps(3) seqI)
	+ qed
	+
	+ lemma pullback_iso_self:
	+ assumes "iso f"
	+ shows "\<p>\<^sub>0[f, f] = \<p>\<^sub>1[f, f]"
	+ using assms pullback_mono_self iso_is_section section_is_mono by simp
	+
	+ lemma pullback_ide_self [simp]:
	+ assumes "ide a"
	+ shows "\<p>\<^sub>0[a, a] = \<p>\<^sub>1[a, a]"
	+ using assms pullback_iso_self ide_is_iso by blast
	+
	+ end
	+
	+ subsection "Agreement between the Definitions"
	+
	+ text \<open>
	+ It is very easy to write locale assumptions that have unintended consequences
	+ or that are even inconsistent. So, to keep ourselves honest, we don't just accept the
	+ definition of ``elementary category with pullbacks'', but in fact we formally establish
	+ the sense in which it agrees with our standard definition of ``category with pullbacks'',
	+ which is given in terms of limit cones.
	+ This is extra work, but it ensures that we didn't make a mistake.
	+ \<close>
	+
	+ context category_with_pullbacks
	+ begin
	+
	+ definition prj1
	+ where "prj1 f g \<equiv> if cospan f g then
	+ fst (SOME x. cospan_diagram.has_as_pullback C f g (fst x) (snd x))
	+ else null"
	+
	+ definition prj0
	+ where "prj0 f g \<equiv> if cospan f g then
	+ snd (SOME x. cospan_diagram.has_as_pullback C f g (fst x) (snd x))
	+ else null"
	+
	+ lemma prj_yields_pullback:
	+ assumes "cospan f g"
	+ shows "cospan_diagram.has_as_pullback C f g (prj1 f g) (prj0 f g)"
	+ proof -
	+ have "\<exists>x. cospan_diagram.has_as_pullback C f g (fst x) (snd x)"
	+ proof -
	+ obtain p0 p1 where "cospan_diagram.has_as_pullback C f g p0 p1"
	+ using assms has_pullbacks has_pullbacks_def has_as_pullback_def by metis
	+ hence "cospan_diagram.has_as_pullback C f g (fst (p0, p1)) (snd (p0, p1))"
	+ by simp
	+ thus ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using assms has_pullbacks has_pullbacks_def prj0_def prj1_def
	+ someI_ex [of "\<lambda>x. cospan_diagram.has_as_pullback C f g (fst x) (snd x)"]
	+ by simp
	+ qed
	+
	+ interpretation elementary_category_with_pullbacks C prj0 prj1
	+ proof
	+ show "\<And>f g. \<not> cospan f g \<Longrightarrow> prj0 f g = null"
	+ using prj0_def by auto
	+ show "\<And>f g. \<not> cospan f g \<Longrightarrow> prj1 f g = null"
	+ using prj1_def by auto
	+ show "\<And>f g. cospan f g \<Longrightarrow> commutative_square f g (prj1 f g) (prj0 f g)"
	+ proof
	+ fix f g
	+ assume fg: "cospan f g"
	+ show "cospan f g" by fact
	+ interpret J: cospan_shape .
	+ interpret D: cospan_diagram C f g
	+ using fg by (unfold_locales, auto)
	+ let ?\<chi> = "D.mkCone (prj1 f g) (prj0 f g)"
	+ interpret \<chi>: limit_cone J.comp C D.map \<open>dom (prj1 f g)\<close> ?\<chi>
	+ using fg prj_yields_pullback by auto
	+ have 1: "prj1 f g = ?\<chi> J.AA \<and> prj0 f g = ?\<chi> J.BB"
	+ using D.mkCone_def by simp
	+ show "span (prj1 f g) (prj0 f g)"
	+ proof -
	+ have "arr (prj1 f g) \<and> arr (prj0 f g)"
	+ using 1 J.arr_char
	+ by (metis J.seqE \<chi>.preserves_reflects_arr cospan_shape.seq_char)
	+ moreover have "dom (prj1 f g) = dom (prj0 f g)"
	+ using 1
	+ by (metis D.is_rendered_commutative_by_cone D.map.simps(4) D.map.simps(5) J.seqE
	+ \<chi>.cone_axioms \<chi>.preserves_comp_1 \<chi>.preserves_dom cospan_shape.comp.simps(2)
	+ cospan_shape.comp.simps(5) cospan_shape.seq_char)
	+ ultimately show ?thesis by simp
	+ qed
	+ show "dom f = cod (prj1 f g)"
	+ using 1 \<chi>.preserves_cod [of J.BB] J.cod_char D.mkCone_def [of "prj1 f g" "prj0 f g"]
	+ by (metis D.map.simps(1) D.preserves_cod J.seqE \<chi>.preserves_cod cod_dom
	+ cospan_shape.seq_char fg)
	+ show "f \<cdot> prj1 f g = g \<cdot> prj0 f g"
	+ using 1 fg D.is_rendered_commutative_by_cone \<chi>.cone_axioms by force
	+ qed
	+ show "\<And>f g h k. commutative_square f g h k \<Longrightarrow> \<exists>!l. prj1 f g \<cdot> l = h \<and> prj0 f g \<cdot> l = k"
	+ proof -
	+ fix f g h k
	+ assume fghk: "commutative_square f g h k"
	+ interpret J: cospan_shape .
	+ interpret D: cospan_diagram C f g
	+ using fghk by (unfold_locales, auto)
	+ let ?\<chi> = "D.mkCone (prj1 f g) (prj0 f g)"
	+ interpret \<chi>: limit_cone J.comp C D.map \<open>dom (prj1 f g)\<close> ?\<chi>
	+ using fghk prj_yields_pullback by auto
	+ interpret \<chi>: pullback_cone C f g \<open>prj1 f g\<close> \<open>prj0 f g\<close> ..
	+ have 1: "prj1 f g = ?\<chi> J.AA \<and> prj0 f g = ?\<chi> J.BB"
	+ using D.mkCone_def by simp
	+ show "\<exists>!l. prj1 f g \<cdot> l = h \<and> prj0 f g \<cdot> l = k"
	+ proof
	+ let ?l = "SOME l. prj1 f g \<cdot> l = h \<and> prj0 f g \<cdot> l = k"
	+ show "prj1 f g \<cdot> ?l = h \<and> prj0 f g \<cdot> ?l = k"
	+ using fghk \<chi>.is_universal' [of h k] \<chi>.renders_commutative
	+ someI_ex [of "\<lambda>l. prj1 f g \<cdot> l = h \<and> prj0 f g \<cdot> l = k"]
	+ by blast
	+ thus "\<And>l. prj1 f g \<cdot> l = h \<and> prj0 f g \<cdot> l = k \<Longrightarrow> l = ?l"
	+ using fghk \<chi>.is_universal' [of h k] \<chi>.renders_commutative
	+ by (metis (no_types, lifting) \<chi>.limit_cone_axioms category.in_homI category.seqE
	+ commutative_squareE dom_comp limit_cone_def seqI)
	+ qed
	+ qed
	+ qed
	+
	+ proposition extends_to_elementary_category_with_pullbacks:
	+ shows "elementary_category_with_pullbacks C prj0 prj1"
	+ ..
	+
	+ end
	+
	+ context elementary_category_with_pullbacks
	+ begin
	+
	+ interpretation category_with_pullbacks C
	+ proof
	+ show "has_pullbacks"
	+ proof (unfold has_pullbacks_def)
	+ have "\<And>f g. cospan f g \<Longrightarrow> \<exists>p0 p1. has_as_pullback f g p0 p1"
	+ proof -
	+ fix f g
	+ assume fg: "cospan f g"
	+ interpret J: cospan_shape .
	+ interpret D: cospan_diagram C f g
	+ using fg by (unfold_locales, auto)
	+ have 2: "D.is_rendered_commutative_by \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]"
	+ using fg pullback_commutes' by simp
	+ let ?\<chi> = "D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]"
	+ interpret \<chi>: cone J.comp C D.map \<open>dom \<p>\<^sub>1[f, g]\<close> ?\<chi>
	+ using D.cone_mkCone 2 by auto
	+ interpret \<chi>: limit_cone J.comp C D.map \<open>dom \<p>\<^sub>1[f, g]\<close> ?\<chi>
	+ proof
	+ fix a' \<chi>'
	+ assume \<chi>': "D.cone a' \<chi>'"
	+ interpret \<chi>': cone J.comp C D.map a' \<chi>'
	+ using \<chi>' by simp
	+ have 3: "commutative_square f g (\<chi>' J.AA) (\<chi>' J.BB)"
	+ proof
	+ show "cospan f g" by fact
	+ show "span (\<chi>' J.AA) (\<chi>' J.BB)"
	+ by (simp add: J.ide_char)
	+ show "dom f = cod (\<chi>' J.AA)"
	+ using \<open>span (\<chi>' J.AA) (\<chi>' J.BB)\<close> J.cod_char by auto
	+ show "f \<cdot> \<chi>' J.AA = g \<cdot> \<chi>' J.BB"
	+ using D.is_rendered_commutative_by_cone \<chi>'.cone_axioms by blast
	+ qed
	+ show "\<exists>!h. \<guillemotleft>h : a' \<rightarrow> dom \<p>\<^sub>1[f, g]\<guillemotright> \<and>
	+ D.cones_map h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) = \<chi>'"
	+ proof
	+ let ?h = "\<langle>\<chi>' J.AA \<lbrakk>f, g\<rbrakk> \<chi>' J.BB\<rangle>"
	+ show h': "\<guillemotleft>?h : a' \<rightarrow> dom \<p>\<^sub>1[f, g]\<guillemotright> \<and>
	+ D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) = \<chi>'"
	+ proof
	+ show h: "\<guillemotleft>?h : a' \<rightarrow> dom \<p>\<^sub>1[f, g]\<guillemotright>"
	+ using fg 3 by fastforce
	+ show "D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) = \<chi>'"
	+ proof -
	+ have "D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g] \<in> D.cones (cod \<langle>\<chi>' J.AA \<lbrakk>f, g\<rbrakk> \<chi>' J.BB\<rangle>)"
	+ using fg h D.cone_mkCone D.is_rendered_commutative_by_cone
	+ \<chi>.cone_axioms
	+ by auto
	+ hence 4: "D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) \<in> D.cones a'"
	+ using fg h D.cones_map_mapsto [of ?h] by blast
	+ interpret \<chi>'h: cone J.comp C D.map a'
	+ \<open>D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g])\<close>
	+ using 4 by simp
	+ show ?thesis
	+ proof -
	+ have "\<And>j. J.ide j \<Longrightarrow> D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) j = \<chi>' j"
	+ proof -
	+ fix j
	+ show "J.ide j \<Longrightarrow> D.cones_map ?h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) j = \<chi>' j"
	+ using fg h 3 J.ide_char D.mkCone_def [of "\<p>\<^sub>1[f, g]" "\<p>\<^sub>0[f, g]"]
	+ \<chi>.cone_axioms
	+ apply (cases j, simp_all)
	+ by (metis D.map.simps(4) J.dom_eqI
	+ \<chi>'.A.constant_functor_axioms \<chi>'.is_natural_1 \<chi>'.naturality
	+ J.seqE constant_functor.map_simp cospan_shape.comp.simps(3)
	+ cospan_shape.comp.simps(7) cospan_shape.seq_char
	+ prj_tuple(2) comp_assoc)
	+ qed
	+ thus ?thesis
	+ using NaturalTransformation.eqI
	+ \<chi>'.natural_transformation_axioms \<chi>'h.natural_transformation_axioms
	+ by blast
	+ qed
	+ qed
	+ qed
	+ show "\<And>h. \<guillemotleft>h : a' \<rightarrow> dom \<p>\<^sub>1[f, g]\<guillemotright> \<and>
	+ D.cones_map h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) = \<chi>' \<Longrightarrow>
	+ h = ?h"
	+ proof -
	+ fix h
	+ assume 1: "\<guillemotleft>h : a' \<rightarrow> dom \<p>\<^sub>1[f, g]\<guillemotright> \<and>
	+ D.cones_map h (D.mkCone \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]) = \<chi>'"
	+ hence 2: "cod h = dom \<p>\<^sub>1[f, g]" using 1 by auto
	+ show "h = ?h"
	+ proof -
	+ have "\<p>\<^sub>0[f, g] \<cdot> h = \<p>\<^sub>0[f, g] \<cdot> ?h"
	+ using 1 3 fg J.arr_char \<chi>.cone_axioms J.Arr.distinct(11) D.mkCone_def
	+ by auto
	+ moreover have "\<p>\<^sub>1[f, g] \<cdot> h = \<p>\<^sub>1[f, g] \<cdot> ?h"
	+ using 1 3 fg J.arr_char \<chi>.cone_axioms J.Arr.distinct(11) D.mkCone_def
	+ by auto
	+ ultimately show ?thesis
	+ using fg 1 h' prj_joint_monic by blast
	+ qed
	+ qed
	+ qed
	+ qed
	+ have "has_as_pullback f g \<p>\<^sub>1[f, g] \<p>\<^sub>0[f, g]"
	+ using fg has_as_pullback_def \<chi>.limit_cone_axioms by blast
	+ thus "\<exists>p0 p1. has_as_pullback f g p0 p1"
	+ by blast
	+ qed
	+ thus "\<forall>f g. cospan f g \<longrightarrow> (\<exists>p0 p1. has_as_pullback f g p0 p1)"
	+ by simp
	+ qed
	+ qed
	+
	+ proposition is_category_with_pullbacks:
	+ shows "category_with_pullbacks C"
	+ ..
	+
	+ end
	+
	+ sublocale elementary_category_with_pullbacks \<subseteq> category_with_pullbacks
	+ using is_category_with_pullbacks by auto
	+
	+end
	+
	diff --git a/thys/Bicategory/Coherence.thy b/thys/Bicategory/Coherence.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/Coherence.thy
	@@ -0,0 +1,3946 @@
	+(* Title: Coherence
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Coherence"
	+
	+theory Coherence
	+imports Bicategory
	+begin
	+
	+ text \<open>
	+ \sloppypar
	+ In this section, we generalize to bicategories the proof of the Coherence Theorem
	+ that we previously gave for monoidal categories
	+ (see \<open>MonoidalCategory.evaluation_map.coherence\<close> in @{session MonoidalCategory}).
	+ As was the case for the previous proof, the current proof takes a syntactic approach.
	+ First we define a formal ``bicategorical language'' of terms constructed using
	+ syntactic operators that correspond to the various operations (vertical and horizontal
	+ composition, associators and unitors) found in a bicategory.
	+ Terms of the language are classified as formal ``arrows'', ``identities'', or ``objects''
	+ according to the syntactic operators used in their formation.
	+ A class of terms called ``canonical'' is also defined in this way.
	+ Functions that map ``arrows'' to their ``domain'' and ``codomain'', and to their
	+ ``source'' and ``target'' are defined by recursion on the structure of terms.
	+ Next, we define a notion of ``normal form'' for terms in this language and we
	+ give a recursive definition of a function that maps terms to their normal forms.
	+ Normalization moves vertical composition inside of horizontal composition and
	+ ``flattens'' horizontal composition by associating all horizontal compositions to the right.
	+ In addition, normalization deletes from a term any horizontal composites involving an arrow
	+ and its source or target, replacing such composites by just the arrow itself.
	+ We then define a ``reduction function'' that maps each identity term \<open>t\<close> to a
	+ ``canonical'' term \<open>t\<^bold>\<down>\<close> that connects \<open>t\<close> with its normal form. The definition of reduction
	+ is also recursive, but it is somewhat more complex than normalization in that it
	+ involves two mutually recursive functions: one that applies to any identity term
	+ and another that applies only to terms that are the horizontal composite
	+ of two identity terms.
	+
	+ The next step is to define an ``evaluation function'' that evaluates terms in a given
	+ bicategory (which is left as an unspecified parameter). We show that evaluation respects
	+ bicategorical structure:
	+ the domain, codomain, source, and target mappings on terms correspond under evaluation
	+ to the actual domain, codomain, source and target mappings on the given bicategory,
	+ the vertical and horizontal composition on terms correspond to the actual vertical
	+ and horizontal composition of the bicategory, and unit and associativity terms evaluate
	+ to the actual unit and associativity isomorphisms of the bicategory.
	+ In addition, ``object terms'' evaluate to objects (\emph{i.e.}~0-cells),
	+ ``identity terms'' evaluate to identities (\emph{i.e.}~1-cells),
	+ ``arrow terms'' evaluate to arrows (\emph{i.e.}~2-cells), and ``canonical terms'' evaluate
	+ to canonical isomorphisms.
	+ A term is defined to be ``coherent'' if, roughly speaking, it is a formal arrow
	+ whose evaluation commutes with the evaluations of the reductions to normal form of
	+ its domain and codomain.
	+ We then prove the Coherence Theorem, expressed in the form: ``every arrow is coherent.''
	+ This implies a more classical version of the Coherence Theorem, which says that:
	+ ``syntactically parallel arrows with the same normal form have equal evaluations''.
	+ \<close>
	+
	+ subsection "Bicategorical Language"
	+
	+ text \<open>
	+ For the most part, the definition of the ``bicategorical language'' of terms is
	+ a straightforward generalization of the ``monoidal language'' that we used for
	+ monoidal categories.
	+ Some modifications are required, however, due to the fact that horizontal composition
	+ in a bicategory is a partial operation, whereas the the tensor product in a monoidal
	+ category is well-defined for all pairs of arrows.
	+ One difference is that we have found it necessary to introduce a new class of primitive
	+ terms whose elements represent ``formal objects'', so that there is some way to
	+ identify the source and target of what would otherwise be an empty horizontal composite.
	+ This was not an issue for monoidal categories, because the totality of horizontal
	+ composition meant that there was no need for syntactically defined sources and targets.
	+ Another difference is what we have chosen for the ``generators'' of the language
	+ and how they are used to form primitive terms. For monoidal categories,
	+ we supposed that we were given a category \<open>C\<close> and the syntax contained a constructor
	+ to form a primitive term corresponding to each arrow of \<open>C\<close>.
	+ We assumed a category as the given data, rather than something less structured,
	+ such as a graph, because we were primarily interested in the tensor product and
	+ the associators and unitors, and were relatively uninterested in the strictly
	+ associative and unital composition of the underlying category.
	+ For bicategories, we also take the vertical composition as given for the same
	+ reasons; however, this is not yet sufficient due to the fact that horizontal
	+ composition in a bicategory is a partial operation, in contrast to the tensor
	+ product in a monoidal category, which is defined for all pairs of arrows.
	+ To deal with this issue, for bicategories we assume that source and target
	+ mappings are also given, so that the given data forms a category with
	+ ``horizontal homs''. The given source and target mappings are extended to all terms
	+ and used to define when two terms are ``formally horizontally composable''.
	+ \<close>
	+
	+ locale bicategorical_language =
	+ category V +
	+ horizontal_homs V src trg
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ begin
	+
	+ text \<open>
	+ Constructor \<open>Prim\<^sub>0\<close> is used to construct ``formal objects'' and \<open>Prim\<close> is used to
	+ construct primitive terms that are not formal objects.
	+ \<close>
	+
	+ datatype (discs_sels) 't "term" =
	+ Prim\<^sub>0 't ("\<^bold>\<langle>_\<^bold>\<rangle>\<^sub>0")
	+ \| Prim 't ("\<^bold>\<langle>_\<^bold>\<rangle>")
	+ \| Hcomp "'t term" "'t term" (infixr "\<^bold>\<star>" 53)
	+ \| Vcomp "'t term" "'t term" (infixr "\<^bold>\<cdot>" 55)
	+ \| Lunit "'t term" ("\<^bold>\<l>\<^bold>[_\<^bold>]")
	+ \| Lunit' "'t term" ("\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
	+ \| Runit "'t term" ("\<^bold>\<r>\<^bold>[_\<^bold>]")
	+ \| Runit' "'t term" ("\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
	+ \| Assoc "'t term" "'t term" "'t term" ("\<^bold>\<a>\<^bold>[_, _, _\<^bold>]")
	+ \| Assoc' "'t term" "'t term" "'t term" ("\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[_, _, _\<^bold>]")
	+
	+ text \<open>
	+ We define formal domain, codomain, source, and target functions on terms.
	+ \<close>
	+
	+ primrec Src :: "'a term \<Rightarrow> 'a term"
	+ where "Src \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
	+ \| "Src \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>src \<mu>\<^bold>\<rangle>\<^sub>0"
	+ \| "Src (t \<^bold>\<star> u) = Src u"
	+ \| "Src (t \<^bold>\<cdot> u) = Src t"
	+ \| "Src \<^bold>\<l>\<^bold>[t\<^bold>] = Src t"
	+ \| "Src \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Src t"
	+ \| "Src \<^bold>\<r>\<^bold>[t\<^bold>] = Src t"
	+ \| "Src \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Src t"
	+ \| "Src \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Src v"
	+ \| "Src \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Src v"
	+
	+ primrec Trg :: "'a term \<Rightarrow> 'a term"
	+ where "Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
	+ \| "Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>trg \<mu>\<^bold>\<rangle>\<^sub>0"
	+ \| "Trg (t \<^bold>\<star> u) = Trg t"
	+ \| "Trg (t \<^bold>\<cdot> u) = Trg t"
	+ \| "Trg \<^bold>\<l>\<^bold>[t\<^bold>] = Trg t"
	+ \| "Trg \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t"
	+ \| "Trg \<^bold>\<r>\<^bold>[t\<^bold>] = Trg t"
	+ \| "Trg \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t"
	+ \| "Trg \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Trg t"
	+ \| "Trg \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Trg t"
	+
	+ primrec Dom :: "'a term \<Rightarrow> 'a term"
	+ where "Dom \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
	+ \| "Dom \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>dom \<mu>\<^bold>\<rangle>"
	+ \| "Dom (t \<^bold>\<star> u) = Dom t \<^bold>\<star> Dom u"
	+ \| "Dom (t \<^bold>\<cdot> u) = Dom u"
	+ \| "Dom \<^bold>\<l>\<^bold>[t\<^bold>] = Trg t \<^bold>\<star> Dom t"
	+ \| "Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
	+ \| "Dom \<^bold>\<r>\<^bold>[t\<^bold>] = Dom t \<^bold>\<star> Src t"
	+ \| "Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
	+ \| "Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Dom t \<^bold>\<star> Dom u) \<^bold>\<star> Dom v"
	+ \| "Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Dom t \<^bold>\<star> (Dom u \<^bold>\<star> Dom v)"
	+
	+ primrec Cod :: "'a term \<Rightarrow> 'a term"
	+ where "Cod \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
	+ \| "Cod \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>cod \<mu>\<^bold>\<rangle>"
	+ \| "Cod (t \<^bold>\<star> u) = Cod t \<^bold>\<star> Cod u"
	+ \| "Cod (t \<^bold>\<cdot> u) = Cod t"
	+ \| "Cod \<^bold>\<l>\<^bold>[t\<^bold>] = Cod t"
	+ \| "Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t \<^bold>\<star> Cod t"
	+ \| "Cod \<^bold>\<r>\<^bold>[t\<^bold>] = Cod t"
	+ \| "Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Cod t \<^bold>\<star> Src t"
	+ \| "Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Cod t \<^bold>\<star> (Cod u \<^bold>\<star> Cod v)"
	+ \| "Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Cod t \<^bold>\<star> Cod u) \<^bold>\<star> Cod v"
	+
	+ text \<open>
	+ A term is a ``formal arrow'' if it is constructed from primitive arrows in such a way
	+ that horizontal and vertical composition are applied only to formally composable pairs
	+ of terms. The definitions of ``formal identity'' and ``formal object'' follow a
	+ similar pattern.
	+ \<close>
	+
	+ primrec Arr :: "'a term \<Rightarrow> bool"
	+ where "Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
	+ \| "Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle> = arr \<mu>"
	+ \| "Arr (t \<^bold>\<star> u) = (Arr t \<and> Arr u \<and> Src t = Trg u)"
	+ \| "Arr (t \<^bold>\<cdot> u) = (Arr t \<and> Arr u \<and> Dom t = Cod u)"
	+ \| "Arr \<^bold>\<l>\<^bold>[t\<^bold>] = Arr t"
	+ \| "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
	+ \| "Arr \<^bold>\<r>\<^bold>[t\<^bold>] = Arr t"
	+ \| "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
	+ \| "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v)"
	+ \| "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v)"
	+
	+ primrec Ide :: "'a term \<Rightarrow> bool"
	+ where "Ide \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
	+ \| "Ide \<^bold>\<langle>\<mu>\<^bold>\<rangle> = ide \<mu>"
	+ \| "Ide (t \<^bold>\<star> u) = (Ide t \<and> Ide u \<and> Src t = Trg u)"
	+ \| "Ide (t \<^bold>\<cdot> u) = False"
	+ \| "Ide \<^bold>\<l>\<^bold>[t\<^bold>] = False"
	+ \| "Ide \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
	+ \| "Ide \<^bold>\<r>\<^bold>[t\<^bold>] = False"
	+ \| "Ide \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
	+ \| "Ide \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = False"
	+ \| "Ide \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = False"
	+
	+ primrec Obj :: "'a term \<Rightarrow> bool"
	+ where "Obj \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
	+ \| "Obj \<^bold>\<langle>\<mu>\<^bold>\<rangle> = False"
	+ \| "Obj (t \<^bold>\<star> u) = False"
	+ \| "Obj (t \<^bold>\<cdot> u) = False"
	+ \| "Obj \<^bold>\<l>\<^bold>[t\<^bold>] = False"
	+ \| "Obj \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
	+ \| "Obj \<^bold>\<r>\<^bold>[t\<^bold>] = False"
	+ \| "Obj \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
	+ \| "Obj \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = False"
	+ \| "Obj \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = False"
	+
	+ abbreviation HSeq :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
	+ where "HSeq t u \<equiv> Arr t \<and> Arr u \<and> Src t = Trg u"
	+
	+ abbreviation VSeq :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
	+ where "VSeq t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Cod u"
	+
	+ abbreviation HPar :: "'a term => 'a term \<Rightarrow> bool"
	+ where "HPar t u \<equiv> Arr t \<and> Arr u \<and> Src t = Src u \<and> Trg t = Trg u"
	+
	+ abbreviation VPar :: "'a term => 'a term \<Rightarrow> bool"
	+ where "VPar t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Dom u \<and> Cod t = Cod u"
	+
	+ abbreviation HHom :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term set"
	+ where "HHom a b \<equiv> { t. Arr t \<and> Src t = a \<and> Trg t = b }"
	+
	+ abbreviation VHom :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term set"
	+ where "VHom f g \<equiv> { t. Arr t \<and> Dom t = f \<and> Cod t = g }"
	+
	+ lemma is_Prim0_Src:
	+ shows "is_Prim\<^sub>0 (Src t)"
	+ by (induct t; simp)
	+
	+ lemma is_Prim0_Trg:
	+ shows "is_Prim\<^sub>0 (Trg t)"
	+ by (induct t; simp)
	+
	+ lemma Src_Src [simp]:
	+ shows "Arr t \<Longrightarrow> Src (Src t) = Src t"
	+ by (induct t) auto
	+
	+ lemma Trg_Trg [simp]:
	+ shows "Arr t \<Longrightarrow> Trg (Trg t) = Trg t"
	+ by (induct t) auto
	+
	+ lemma Src_Trg [simp]:
	+ shows "Arr t \<Longrightarrow> Src (Trg t) = Trg t"
	+ by (induct t) auto
	+
	+ lemma Trg_Src [simp]:
	+ shows "Arr t \<Longrightarrow> Trg (Src t) = Src t"
	+ by (induct t) auto
	+
	+ lemma Dom_Src [simp]:
	+ shows "Arr t \<Longrightarrow> Dom (Src t) = Src t"
	+ by (induct t) auto
	+
	+ lemma Dom_Trg [simp]:
	+ shows "Arr t \<Longrightarrow> Dom (Trg t) = Trg t"
	+ by (induct t) auto
	+
	+ lemma Cod_Src [simp]:
	+ shows "Arr t \<Longrightarrow> Cod (Src t) = Src t"
	+ by (induct t) auto
	+
	+ lemma Cod_Trg [simp]:
	+ shows "Arr t \<Longrightarrow> Cod (Trg t) = Trg t"
	+ by (induct t) auto
	+
	+ lemma Src_Dom_Cod:
	+ shows "Arr t \<Longrightarrow> Src (Dom t) = Src t \<and> Src (Cod t) = Src t"
	+ using src_dom src_cod by (induct t) auto
	+
	+ lemma Src_Dom [simp]:
	+ shows "Arr t \<Longrightarrow> Src (Dom t) = Src t"
	+ using Src_Dom_Cod by blast
	+
	+ lemma Src_Cod [simp]:
	+ shows "Arr t \<Longrightarrow> Src (Cod t) = Src t"
	+ using Src_Dom_Cod by blast
	+
	+ lemma Trg_Dom_Cod:
	+ shows "Arr t \<Longrightarrow> Trg (Dom t) = Trg t \<and> Trg (Cod t) = Trg t"
	+ using trg_dom trg_cod by (induct t) auto
	+
	+ lemma Trg_Dom [simp]:
	+ shows "Arr t \<Longrightarrow> Trg (Dom t) = Trg t"
	+ using Trg_Dom_Cod by blast
	+
	+ lemma Trg_Cod [simp]:
	+ shows "Arr t \<Longrightarrow> Trg (Cod t) = Trg t"
	+ using Trg_Dom_Cod by blast
	+
	+ lemma VSeq_implies_HPar:
	+ shows "VSeq t u \<Longrightarrow> HPar t u"
	+ using Src_Dom [of t] Src_Cod [of u] Trg_Dom [of t] Trg_Cod [of u] by auto
	+
	+ lemma Dom_Dom [simp]:
	+ shows "Arr t \<Longrightarrow> Dom (Dom t) = Dom t"
	+ by (induct t, auto)
	+
	+ lemma Cod_Cod [simp]:
	+ shows "Arr t \<Longrightarrow> Cod (Cod t) = Cod t"
	+ by (induct t, auto)
	+
	+ lemma Dom_Cod [simp]:
	+ shows "Arr t \<Longrightarrow> Dom (Cod t) = Cod t"
	+ by (induct t, auto)
	+
	+ lemma Cod_Dom [simp]:
	+ shows "Arr t \<Longrightarrow> Cod (Dom t) = Dom t"
	+ by (induct t, auto)
	+
	+ lemma Obj_implies_Ide [simp]:
	+ shows "Obj t \<Longrightarrow> Ide t"
	+ by (induct t) auto
	+
	+ lemma Ide_implies_Arr [simp]:
	+ shows "Ide t \<Longrightarrow> Arr t"
	+ by (induct t, auto)
	+
	+ lemma Dom_Ide:
	+ shows "Ide t \<Longrightarrow> Dom t = t"
	+ by (induct t, auto)
	+
	+ lemma Cod_Ide:
	+ shows "Ide t \<Longrightarrow> Cod t = t"
	+ by (induct t, auto)
	+
	+ lemma Obj_Src [simp]:
	+ shows "Arr t \<Longrightarrow> Obj (Src t)"
	+ by (induct t) auto
	+
	+ lemma Obj_Trg [simp]:
	+ shows "Arr t \<Longrightarrow> Obj (Trg t)"
	+ by (induct t) auto
	+
	+ lemma Ide_Dom [simp]:
	+ shows "Arr t \<Longrightarrow> Ide (Dom t)"
	+ by (induct t, auto)
	+
	+ lemma Ide_Cod [simp]:
	+ shows "Arr t \<Longrightarrow> Ide (Cod t)"
	+ by (induct t, auto)
	+
	+ lemma Arr_in_Hom:
	+ assumes "Arr t"
	+ shows "t \<in> HHom (Src t) (Trg t)" and "t \<in> VHom (Dom t) (Cod t)"
	+ proof -
	+ have 1: "Arr t \<Longrightarrow> t \<in> HHom (Src t) (Trg t) \<and> t \<in> VHom (Dom t) (Cod t)"
	+ by (induct t, auto)
	+ show "t \<in> HHom (Src t) (Trg t)" using assms 1 by simp
	+ show "t \<in> VHom (Dom t) (Cod t)" using assms 1 by simp
	+ qed
	+
	+ lemma Ide_in_Hom:
	+ assumes "Ide t"
	+ shows "t \<in> HHom (Src t) (Trg t)" and "t \<in> VHom t t"
	+ proof -
	+ have 1: "Ide t \<Longrightarrow> t \<in> HHom (Src t) (Trg t) \<and> t \<in> VHom t t"
	+ by (induct t, auto)
	+ show "t \<in> HHom (Src t) (Trg t)" using assms 1 by simp
	+ show "t \<in> VHom t t" using assms 1 by simp
	+ qed
	+
	+ lemma Obj_in_Hom:
	+ assumes "Obj t"
	+ shows "t \<in> HHom t t" and "t \<in> VHom t t"
	+ proof -
	+ have 1: "Obj t \<Longrightarrow> t \<in> HHom t t \<and> t \<in> VHom t t"
	+ by (induct t, auto)
	+ show "t \<in> HHom t t" using assms 1 by simp
	+ show "t \<in> VHom t t" using assms 1 by simp
	+ qed
	+
	+ text \<open>
	+ A formal arrow is ``canonical'' if the only primitive arrows used in its construction
	+ are objects and identities.
	+ \<close>
	+
	+ primrec Can :: "'a term \<Rightarrow> bool"
	+ where "Can \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
	+ \| "Can \<^bold>\<langle>\<mu>\<^bold>\<rangle> = ide \<mu>"
	+ \| "Can (t \<^bold>\<star> u) = (Can t \<and> Can u \<and> Src t = Trg u)"
	+ \| "Can (t \<^bold>\<cdot> u) = (Can t \<and> Can u \<and> Dom t = Cod u)"
	+ \| "Can \<^bold>\<l>\<^bold>[t\<^bold>] = Can t"
	+ \| "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Can t"
	+ \| "Can \<^bold>\<r>\<^bold>[t\<^bold>] = Can t"
	+ \| "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Can t"
	+ \| "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Can t \<and> Can u \<and> Can v \<and> Src t = Trg u \<and> Src u = Trg v)"
	+ \| "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Can t \<and> Can u \<and> Can v \<and> Src t = Trg u \<and> Src u = Trg v)"
	+
	+ lemma Ide_implies_Can:
	+ shows "Ide t \<Longrightarrow> Can t"
	+ by (induct t, auto)
	+
	+ lemma Can_implies_Arr:
	+ shows "Can t \<Longrightarrow> Arr t"
	+ by (induct t, auto)
	+
	+ text \<open>
	+ Canonical arrows can be formally inverted.
	+ \<close>
	+
	+ primrec Inv :: "'a term \<Rightarrow> 'a term"
	+ where "Inv \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
	+ \| "Inv \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>inv \<mu>\<^bold>\<rangle>"
	+ \| "Inv (t \<^bold>\<star> u) = (Inv t \<^bold>\<star> Inv u)"
	+ \| "Inv (t \<^bold>\<cdot> u) = (Inv u \<^bold>\<cdot> Inv t)"
	+ \| "Inv \<^bold>\<l>\<^bold>[t\<^bold>] = \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]"
	+ \| "Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<^bold>\<l>\<^bold>[Inv t\<^bold>]"
	+ \| "Inv \<^bold>\<r>\<^bold>[t\<^bold>] = \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]"
	+ \| "Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<^bold>\<r>\<^bold>[Inv t\<^bold>]"
	+ \| "Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv t, Inv u, Inv v\<^bold>]"
	+ \| "Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = \<^bold>\<a>\<^bold>[Inv t, Inv u, Inv v\<^bold>]"
	+
	+ lemma Src_Inv [simp]:
	+ shows "Can t \<Longrightarrow> Src (Inv t) = Src t"
	+ using Can_implies_Arr VSeq_implies_HPar
	+ apply (induct t, auto)
	+ by metis
	+
	+ lemma Trg_Inv [simp]:
	+ shows "Can t \<Longrightarrow> Trg (Inv t) = Trg t"
	+ using Can_implies_Arr VSeq_implies_HPar
	+ apply (induct t, auto)
	+ by metis
	+
	+ lemma Dom_Inv [simp]:
	+ shows "Can t \<Longrightarrow> Dom (Inv t) = Cod t"
	+ by (induct t, auto)
	+
	+ lemma Cod_Inv [simp]:
	+ shows "Can t \<Longrightarrow> Cod (Inv t) = Dom t"
	+ by (induct t, auto)
	+
	+ lemma Inv_preserves_Ide:
	+ shows "Ide t \<Longrightarrow> Ide (Inv t)"
	+ using Ide_implies_Can by (induct t, auto)
	+
	+ lemma Can_Inv [simp]:
	+ shows "Can t \<Longrightarrow> Can (Inv t)"
	+ by (induct t, auto)
	+
	+ lemma Inv_in_Hom [intro]:
	+ assumes "Can t"
	+ shows "Inv t \<in> HHom (Src t) (Trg t)" and "Inv t \<in> VHom (Cod t) (Dom t)"
	+ using assms Can_Inv Can_implies_Arr by simp_all
	+
	+ lemma Inv_Ide [simp]:
	+ assumes "Ide a"
	+ shows "Inv a = a"
	+ using assms by (induct a, auto)
	+
	+ lemma Inv_Inv [simp]:
	+ assumes "Can t"
	+ shows "Inv (Inv t) = t"
	+ using assms by (induct t, auto)
	+
	+ subsection "Normal Terms"
	+
	+ text \<open>
	+ We call a term ``normal'' if it is either a formal object or it is constructed from
	+ primitive arrows using only horizontal composition associated to the right.
	+ Essentially, such terms are (typed) composable sequences of arrows of @{term V},
	+ where the empty list is represented by a formal object and \<open>\<^bold>\<star>\<close> is used as
	+ the list constructor.
	+ \<close>
	+
	+ fun Nml :: "'a term \<Rightarrow> bool"
	+ where "Nml \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
	+ \| "Nml \<^bold>\<langle>\<mu>\<^bold>\<rangle> = arr \<mu>"
	+ \| "Nml (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<star> u) = (arr \<nu> \<and> Nml u \<and> \<not> is_Prim\<^sub>0 u \<and> \<^bold>\<langle>src \<nu>\<^bold>\<rangle>\<^sub>0 = Trg u)"
	+ \| "Nml _ = False"
	+
	+ lemma Nml_HcompD:
	+ assumes "Nml (t \<^bold>\<star> u)"
	+ shows "\<^bold>\<langle>un_Prim t\<^bold>\<rangle> = t" and "arr (un_Prim t)" and "Nml t" and "Nml u"
	+ and "\<not> is_Prim\<^sub>0 u" and "\<^bold>\<langle>src (un_Prim t)\<^bold>\<rangle>\<^sub>0 = Trg u" and "Src t = Trg u"
	+ proof -
	+ have 1: "t = \<^bold>\<langle>un_Prim t\<^bold>\<rangle> \<and> arr (un_Prim t) \<and> Nml t \<and> Nml u \<and> \<not> is_Prim\<^sub>0 u \<and>
	+ \<^bold>\<langle>src (un_Prim t)\<^bold>\<rangle>\<^sub>0 = Trg u"
	+ using assms by (cases t; simp; cases u; simp)
	+ show "\<^bold>\<langle>un_Prim t\<^bold>\<rangle> = t" using 1 by simp
	+ show "arr (un_Prim t)" using 1 by simp
	+ show "Nml t" using 1 by simp
	+ show "Nml u" using 1 by simp
	+ show "\<not> is_Prim\<^sub>0 u" using 1 by simp
	+ show "\<^bold>\<langle>src (un_Prim t)\<^bold>\<rangle>\<^sub>0 = Trg u" using 1 by simp
	+ show "Src t = Trg u"
	+ using assms
	+ apply (cases t) by simp_all
	+ qed
	+
	+ lemma Nml_implies_Arr:
	+ shows "Nml t \<Longrightarrow> Arr t"
	+ apply (induct t, auto)
	+ using Nml_HcompD by simp_all
	+
	+ lemma Nml_Src [simp]:
	+ shows "Nml t \<Longrightarrow> Nml (Src t)"
	+ apply (induct t, simp_all)
	+ using Nml_HcompD by metis
	+
	+ lemma Nml_Trg [simp]:
	+ shows "Nml t \<Longrightarrow> Nml (Trg t)"
	+ apply (induct t, simp_all)
	+ using Nml_HcompD by metis
	+
	+ lemma Nml_Dom [simp]:
	+ shows "Nml t \<Longrightarrow> Nml (Dom t)"
	+ proof (induct t, simp_all add: Nml_HcompD)
	+ fix u v
	+ assume I1: "Nml (Dom u)"
	+ assume I2: "Nml (Dom v)"
	+ assume uv: "Nml (u \<^bold>\<star> v)"
	+ show "Nml (Dom u \<^bold>\<star> Dom v)"
	+ proof -
	+ have 1: "is_Prim (Dom u) \<and> arr (un_Prim (Dom u)) \<and> Dom u = \<^bold>\<langle>dom (un_Prim u)\<^bold>\<rangle>"
	+ using uv by (cases u; simp; cases v, simp_all)
	+ have 2: "Nml v \<and> \<not> is_Prim\<^sub>0 v \<and> \<not> is_Vcomp v \<and> \<not> is_Lunit' v \<and> \<not> is_Runit' v"
	+ using uv by (cases u, simp_all; cases v, simp_all)
	+ have "arr (dom (un_Prim u))"
	+ using 1 by fastforce
	+ moreover have "Nml (Dom v) \<and> \<not> is_Prim\<^sub>0 v"
	+ using 2 I2 by (cases v, simp_all)
	+ moreover have "\<^bold>\<langle>src (dom (un_Prim u))\<^bold>\<rangle>\<^sub>0 = Trg (Dom v)"
	+ proof -
	+ have "Trg (Dom v) = Src (Dom u)"
	+ using uv Nml_implies_Arr by fastforce
	+ also have "... = \<^bold>\<langle>src (dom (un_Prim u))\<^bold>\<rangle>\<^sub>0"
	+ using 1 by fastforce
	+ finally show ?thesis by argo
	+ qed
	+ moreover have "\<not> is_Prim\<^sub>0 (Dom v)"
	+ using 2 by (cases v, simp_all)
	+ ultimately show ?thesis using 1 2 by simp
	+ qed
	+ qed
	+
	+ lemma Nml_Cod [simp]:
	+ shows "Nml t \<Longrightarrow> Nml (Cod t)"
	+ proof (induct t, simp_all add: Nml_HcompD)
	+ fix u v
	+ assume I1: "Nml (Cod u)"
	+ assume I2: "Nml (Cod v)"
	+ assume uv: "Nml (u \<^bold>\<star> v)"
	+ show "Nml (Cod u \<^bold>\<star> Cod v)"
	+ proof -
	+ have 1: "is_Prim (Cod u) \<and> arr (un_Prim (Cod u)) \<and> Cod u = \<^bold>\<langle>cod (un_Prim u)\<^bold>\<rangle>"
	+ using uv by (cases u; simp; cases v, simp_all)
	+ have 2: "Nml v \<and> \<not> is_Prim\<^sub>0 v \<and> \<not> is_Vcomp v \<and> \<not> is_Lunit' v \<and> \<not> is_Runit' v"
	+ using uv by (cases u; simp; cases v, simp_all)
	+ have "arr (cod (un_Prim u))"
	+ using 1 by fastforce
	+ moreover have "Nml (Cod v) \<and> \<not> is_Prim\<^sub>0 v"
	+ using 2 I2 by (cases v, simp_all)
	+ moreover have "\<^bold>\<langle>src (cod (un_Prim u))\<^bold>\<rangle>\<^sub>0 = Trg (Cod v)"
	+ proof -
	+ have "Trg (Cod v) = Src (Cod u)"
	+ using uv Nml_implies_Arr by fastforce
	+ also have "... = \<^bold>\<langle>src (cod (un_Prim u))\<^bold>\<rangle>\<^sub>0"
	+ using 1 by fastforce
	+ finally show ?thesis by argo
	+ qed
	+ moreover have "\<not> is_Prim\<^sub>0 (Cod v)"
	+ using 2 by (cases v; simp)
	+ ultimately show ?thesis using 1 2 by simp
	+ qed
	+ qed
	+
	+ lemma Nml_Inv [simp]:
	+ assumes "Can t" and "Nml t"
	+ shows "Nml (Inv t)"
	+ proof -
	+ have "Can t \<and> Nml t \<Longrightarrow> Nml (Inv t)"
	+ apply (induct t, simp_all)
	+ proof -
	+ fix u v
	+ assume I1: "Nml u \<Longrightarrow> Nml (Inv u)"
	+ assume I2: "Nml v \<Longrightarrow> Nml (Inv v)"
	+ assume uv: "Can u \<and> Can v \<and> Src u = Trg v \<and> Nml (u \<^bold>\<star> v)"
	+ show "Nml (Inv u \<^bold>\<star> Inv v)"
	+ proof -
	+ have u: "Arr u \<and> Can u" using uv Can_implies_Arr by blast
	+ have v: "Arr v \<and> Can v" using uv Can_implies_Arr by blast
	+ have 1: "\<^bold>\<langle>un_Prim u\<^bold>\<rangle> = u \<and> ide (un_Prim u) \<and> Nml u \<and> Nml v \<and> \<not> is_Prim\<^sub>0 v \<and>
	+ \<^bold>\<langle>src (un_Prim u)\<^bold>\<rangle>\<^sub>0 = Trg v"
	+ using uv Nml_HcompD [of u v] apply simp
	+ using uv by (cases u, simp_all)
	+ have 2: "\<^bold>\<langle>un_Prim (Inv u)\<^bold>\<rangle> = Inv u \<and> arr (un_Prim (Inv u)) \<and> Nml (Inv u)"
	+ using 1 by (cases u; simp)
	+ moreover have "Nml (Inv v) \<and> \<not> is_Prim\<^sub>0 (Inv v)"
	+ using 1 I2 by (cases v, simp_all)
	+ moreover have "\<^bold>\<langle>src (un_Prim (Inv u))\<^bold>\<rangle>\<^sub>0 = Trg (Inv v)"
	+ using 1 2 v by (cases u, simp_all)
	+ ultimately show ?thesis
	+ by (cases u, simp_all)
	+ qed
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ text \<open>
	+ The following function defines a horizontal composition for normal terms.
	+ If such terms are regarded as lists, this is just (typed) list concatenation.
	+ \<close>
	+
	+ fun HcompNml (infixr "\<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor>" 53)
	+ where "\<^bold>\<langle>\<nu>\<^bold>\<rangle>\<^sub>0 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
	+ \| "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = t"
	+ \| "\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = \<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<star> u"
	+ \| "(t \<^bold>\<star> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
	+ \| "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = undefined"
	+
	+ lemma HcompNml_Prim [simp]:
	+ assumes "\<not> is_Prim\<^sub>0 t"
	+ shows "\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = \<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<star> t"
	+ using assms by (cases t, simp_all)
	+
	+ lemma HcompNml_term_Prim\<^sub>0 [simp]:
	+ assumes "Src t = Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
	+ shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = t"
	+ using assms by (cases t, simp_all)
	+
	+ lemma HcompNml_Nml:
	+ assumes "Nml (t \<^bold>\<star> u)"
	+ shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = t \<^bold>\<star> u"
	+ using assms HcompNml_Prim by (metis Nml_HcompD(1) Nml_HcompD(5))
	+
	+ lemma Nml_HcompNml:
	+ assumes "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "Nml (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ and "Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u"
	+ and "Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u"
	+ and "Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u"
	+ and "Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t"
	+ proof -
	+ have 0: "\<And>u. \<lbrakk> Nml t; Nml u; Src t = Trg u \<rbrakk> \<Longrightarrow>
	+ Nml (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
	+ Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
	+ Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t"
	+ proof (induct t, simp_all add: Nml_HcompD(1-4))
	+ fix \<nu> :: 'a and u :: "'a term"
	+ assume \<nu>: "arr \<nu>"
	+ assume u: "Nml u"
	+ assume 1: "\<^bold>\<langle>src \<nu>\<^bold>\<rangle>\<^sub>0 = Trg u"
	+ show "Nml (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>dom \<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
	+ Cod (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>cod \<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
	+ Src (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>trg \<nu>\<^bold>\<rangle>\<^sub>0"
	+ using u \<nu> 1 by (cases u, simp_all)
	+ next
	+ fix u v w
	+ assume I1: "\<And>x. Nml x \<Longrightarrow> Src v = Trg x \<Longrightarrow>
	+ Nml (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) \<and> Dom (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom x \<and>
	+ Cod (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod x \<and>
	+ Src (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Src x \<and> Trg (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Trg v"
	+ assume I2: "\<And>x. Nml x \<Longrightarrow> Trg u = Trg x \<Longrightarrow>
	+ Nml (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom x \<and>
	+ Cod (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod x \<and>
	+ Src (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Src x \<and> Trg (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Trg w"
	+ assume vw: "Nml (v \<^bold>\<star> w)"
	+ assume u: "Nml u"
	+ assume wu: "Src w = Trg u"
	+ show "Nml ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
	+ Dom ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = (Dom v \<^bold>\<star> Dom w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
	+ Cod ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = (Cod v \<^bold>\<star> Cod w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
	+ Src ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg v"
	+ proof -
	+ have v: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> Nml v"
	+ using vw Nml_implies_Arr Nml_HcompD by metis
	+ have w: "Nml w \<and> \<not> is_Prim\<^sub>0 w \<and> \<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w"
	+ using vw by (simp add: Nml_HcompD)
	+ have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis" by (cases u; simp add: vw wu)
	+ moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
	+ proof -
	+ assume 1: "\<not> is_Prim\<^sub>0 u"
	+ have "Src v = Trg (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using u v w I2 [of u] by (cases v, simp_all)
	+ hence "Nml (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
	+ Dom (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
	+ Cod (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
	+ Src (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg v"
	+ using u v w I1 [of "w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u"] I2 [of u] by argo
	+ moreover have "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = (v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u"
	+ using 1 by (cases u, simp_all)
	+ moreover have "(Dom v \<^bold>\<star> Dom w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u = Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using v w u vw 1 I2 Nml_Dom HcompNml_Prim Nml_HcompD(1) Nml_HcompD(5)
	+ by (cases u, simp_all)
	+ moreover have "(Cod v \<^bold>\<star> Cod w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u = Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using v w u vw 1 I2 Nml_HcompD(1) Nml_HcompD(5) HcompNml_Prim
	+ by (cases u, simp_all)
	+ ultimately show ?thesis
	+ by argo
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ next
	+ fix a u
	+ assume a: "obj a"
	+ assume u: "Nml u"
	+ assume au: "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = Trg u"
	+ show "Nml (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<and>
	+ Dom (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom (Trg u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u \<and>
	+ Cod (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod (Trg u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u \<and>
	+ Src (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u \<and> Trg (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg (Trg u)"
	+ using au
	+ by (metis Cod.simps(1) Dom.simps(1) HcompNml.simps(1) Trg.simps(1) u)
	+ qed
	+ show "Nml (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) " using assms 0 by blast
	+ show "Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u" using assms 0 by blast
	+ show "Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u" using assms 0 by blast
	+ show "Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u" using assms 0 by blast
	+ show "Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t" using assms 0 by blast
	+ qed
	+
	+ lemma HcompNml_in_Hom [intro]:
	+ assumes "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<in> HHom (Src u) (Trg t)"
	+ and "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<in> VHom (Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u) (Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u)"
	+ using assms Nml_HcompNml Nml_implies_Arr by auto
	+
	+ lemma Src_HcompNml:
	+ assumes "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "Src (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Src u"
	+ using assms Nml_HcompNml(4) by simp
	+
	+ lemma Trg_HcompNml:
	+ assumes "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "Trg (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Trg t"
	+ using assms Nml_HcompNml(5) by simp
	+
	+ lemma Dom_HcompNml:
	+ assumes "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "Dom (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u"
	+ using assms Nml_HcompNml(2) by simp
	+
	+ lemma Cod_HcompNml:
	+ assumes "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "Cod (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u"
	+ using assms Nml_HcompNml(3) by simp
	+
	+ lemma is_Hcomp_HcompNml:
	+ assumes "Nml t" and "Nml u" and "Src t = Trg u"
	+ and "\<not> is_Prim\<^sub>0 t" and "\<not> is_Prim\<^sub>0 u"
	+ shows "is_Hcomp (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ proof -
	+ have "\<lbrakk> \<not> is_Hcomp (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u); Nml t; Nml u; Src t = Trg u; \<not> is_Prim\<^sub>0 t; \<not> is_Prim\<^sub>0 u \<rbrakk>
	+ \<Longrightarrow> False"
	+ proof (induct t, simp_all add: Nml_HcompD)
	+ fix a
	+ assume a: "obj a"
	+ assume u: "Nml u"
	+ assume 1: "\<not> is_Hcomp u"
	+ assume 2: "\<not> is_Prim\<^sub>0 (Trg u)"
	+ show "False"
	+ using u 1 2 by (cases u; simp)
	+ next
	+ fix v w
	+ assume I2: "\<not> is_Hcomp (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<Longrightarrow> False"
	+ assume vw: "Nml (v \<^bold>\<star> w)"
	+ assume u: "Nml u"
	+ assume 1: "\<not> is_Hcomp ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ assume 2: "\<not> is_Prim\<^sub>0 u"
	+ assume 3: "Src w = Trg u"
	+ show "False"
	+ proof -
	+ have v: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle>"
	+ using vw Nml_HcompD by force
	+ have w: "Nml w \<and> \<not> is_Prim\<^sub>0 w \<and> \<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w"
	+ using vw Nml_HcompD [of v w] by blast
	+ have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = v \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ proof -
	+ have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using u v 2 by (cases u, simp_all)
	+ also have "... = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using u w I2 by fastforce
	+ also have "... = v \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using v by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis using 1 by simp
	+ qed
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ text \<open>
	+ The following function defines the ``dimension'' of a term,
	+ which is the number of inputs (or outputs) when the term is regarded as an
	+ interconnection matrix.
	+ For normal terms, this is just the length of the term when regarded as a list
	+ of arrows of @{term C}.
	+ This function is used as a ranking of terms in the subsequent associativity proof.
	+ \<close>
	+
	+ primrec dim :: "'a term \<Rightarrow> nat"
	+ where "dim \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = 0"
	+ \| "dim \<^bold>\<langle>\<mu>\<^bold>\<rangle> = 1"
	+ \| "dim (t \<^bold>\<star> u) = (dim t + dim u)"
	+ \| "dim (t \<^bold>\<cdot> u) = dim t"
	+ \| "dim \<^bold>\<l>\<^bold>[t\<^bold>] = dim t"
	+ \| "dim \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
	+ \| "dim \<^bold>\<r>\<^bold>[t\<^bold>] = dim t"
	+ \| "dim \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
	+ \| "dim \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
	+ \| "dim \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
	+
	+ lemma HcompNml_assoc:
	+ assumes "Nml t" and "Nml u" and "Nml v" and "Src t = Trg u" and "Src u = Trg v"
	+ shows "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
	+ proof -
	+ have "\<And>n t u v. \<lbrakk> dim t = n; Nml t; Nml u; Nml v; Src t = Trg u; Src u = Trg v \<rbrakk> \<Longrightarrow>
	+ (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
	+ proof -
	+ fix n
	+ show "\<And>t u v. \<lbrakk> dim t = n; Nml t; Nml u; Nml v; Src t = Trg u; Src u = Trg v \<rbrakk> \<Longrightarrow>
	+ (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
	+ proof (induction n rule: nat_less_induct)
	+ fix n :: nat and t :: "'a term" and u v
	+ assume I: "\<forall>m<n. \<forall>t u v. dim t = m \<longrightarrow> Nml t \<longrightarrow> Nml u \<longrightarrow> Nml v \<longrightarrow>
	+ Src t = Trg u \<longrightarrow> Src u = Trg v \<longrightarrow>
	+ (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
	+ assume dim: "dim t = n"
	+ assume t: "Nml t"
	+ assume u: "Nml u"
	+ assume v: "Nml v"
	+ assume tu: "Src t = Trg u"
	+ assume uv: "Src u = Trg v"
	+ show "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
	+ proof -
	+ have "is_Prim\<^sub>0 t \<Longrightarrow> ?thesis" by (cases t; simp)
	+ moreover have "\<not>is_Prim\<^sub>0 t \<Longrightarrow> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
	+ by (cases t; simp; cases u; simp)
	+ moreover have "\<not> is_Prim\<^sub>0 t \<Longrightarrow> \<not> is_Prim\<^sub>0 u \<Longrightarrow> is_Prim\<^sub>0 v \<Longrightarrow> ?thesis"
	+ proof -
	+ assume 1: "\<not> is_Prim\<^sub>0 t"
	+ assume 2: "\<not> is_Prim\<^sub>0 u"
	+ assume 3: "is_Prim\<^sub>0 v"
	+ have "\<not>is_Prim\<^sub>0 (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using 1 2 t u tu is_Hcomp_HcompNml [of t u]
	+ by (cases t, simp, cases u, auto)
	+ thus ?thesis
	+ using 1 2 3 tu uv by (cases v, simp, cases "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u", simp_all)
	+ qed
	+ moreover have "\<not>is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v \<and> is_Prim t \<Longrightarrow> ?thesis"
	+ using v by (cases t, simp_all, cases u, simp_all; cases v, simp_all)
	+ moreover have "\<not>is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v \<and> is_Hcomp t \<Longrightarrow> ?thesis"
	+ proof (cases t, simp_all)
	+ fix w :: "'a term" and x :: "'a term"
	+ assume 1: " \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v"
	+ assume 2: "t = (w \<^bold>\<star> x)"
	+ show "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
	+ proof -
	+ have w: "w = \<^bold>\<langle>un_Prim w\<^bold>\<rangle>"
	+ using t 1 2 Nml_HcompD by auto
	+ have x: "Nml x"
	+ using t w 1 2 by (metis Nml.simps(3))
	+ have "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
	+ using u v w x 1 2 by (cases u, simp_all)
	+ also have "... = (w \<^bold>\<star> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
	+ using t w u 1 2 HcompNml_Prim is_Hcomp_HcompNml Nml_HcompD
	+ by (metis Src.simps(3) term.distinct_disc(3) tu)
	+ also have "... = w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ((x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
	+ using u v w x 1 by (cases u, simp_all; cases v, simp_all)
	+ also have "... = w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v))"
	+ proof -
	+ have "dim x < dim t"
	+ using 2 w by (cases w; simp)
	+ moreover have "Src x = Trg u \<and> Src u = Trg v"
	+ using tu uv 2 by auto
	+ ultimately show ?thesis
	+ using u v x dim I by simp
	+ qed
	+ also have "... = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
	+ proof -
	+ have 3: "is_Hcomp (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
	+ using u v uv 1 is_Hcomp_HcompNml by auto
	+ obtain u' :: "'a term" and v' where uv': "u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = u' \<^bold>\<star> v'"
	+ using 3 is_Hcomp_def by blast
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ moreover have "is_Prim\<^sub>0 t \<or> is_Prim t \<or> is_Hcomp t"
	+ using t by (cases t, simp_all)
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma HcompNml_Trg_Nml:
	+ assumes "Nml t"
	+ shows "Trg t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = t"
	+ proof -
	+ have "Nml t \<Longrightarrow> Trg t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = t"
	+ proof (induct t, simp_all add: Nml_HcompD)
	+ fix u v
	+ assume uv: "Nml (u \<^bold>\<star> v)"
	+ assume I1: "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
	+ have 1: "Nml u \<and> Nml v \<and> Src u = Trg v"
	+ using uv Nml_HcompD by blast
	+ have 2: "Trg (u \<^bold>\<star> v) = Trg u"
	+ using uv by auto
	+ show "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<star> v = u \<^bold>\<star> v"
	+ proof -
	+ have "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<star> v = Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
	+ using uv HcompNml_Nml by simp
	+ also have "... = (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
	+ using 1 2 HcompNml_assoc Src_Trg Nml_Trg Nml_implies_Arr by simp
	+ also have "... = u \<^bold>\<star> v"
	+ using I1 uv HcompNml_Nml by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ thus ?thesis using assms by simp
	+ qed
	+
	+ lemma HcompNml_Nml_Src:
	+ assumes "Nml t"
	+ shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src t = t"
	+ proof -
	+ have "Nml t \<Longrightarrow> t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src t = t"
	+ proof (induct t, simp_all add: Nml_HcompD)
	+ fix u v
	+ assume uv: "Nml (u \<^bold>\<star> v)"
	+ assume I2: "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = v"
	+ have 1: "Nml u \<and> Nml v \<and> Src u = Trg v"
	+ using uv Nml_HcompD by blast
	+ have 2: "Src (u \<^bold>\<star> v) = Src v"
	+ using uv Trg_HcompNml by auto
	+ show "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = u \<^bold>\<star> v"
	+ proof -
	+ have "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v"
	+ using uv HcompNml_Nml by simp
	+ also have "... = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v)"
	+ using 1 2 HcompNml_assoc Trg_Src Nml_Src Nml_implies_Arr by simp
	+ also have "... = u \<^bold>\<star> v"
	+ using I2 uv HcompNml_Nml by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ thus ?thesis using assms by simp
	+ qed
	+
	+ lemma HcompNml_Obj_Nml:
	+ assumes "Obj t" and "Nml u" and "Src t = Trg u"
	+ shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
	+ using assms by (cases t, simp_all add: HcompNml_Trg_Nml)
	+
	+ lemma HcompNml_Nml_Obj:
	+ assumes "Nml t" and "Obj u" and "Src t = Trg u"
	+ shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = t"
	+ using assms by (cases u, simp_all)
	+
	+ lemma Ide_HcompNml:
	+ assumes "Ide t" and "Ide u" and "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "Ide (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using assms
	+ by (metis (mono_tags, lifting) Nml_HcompNml(1) Nml_implies_Arr Dom_HcompNml
	+ Ide_Dom Ide_in_Hom(2) mem_Collect_eq)
	+
	+ lemma Can_HcompNml:
	+ assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "Can (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ proof -
	+ have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Src t = Trg u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ proof (induct t, simp_all add: HcompNml_Trg_Nml HcompNml_Nml_Src)
	+ show "\<And>x u. ide x \<and> arr x \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u \<Longrightarrow> Can (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ by (metis Ide.simps(1-2) Ide_implies_Can Can.simps(3) Nml.elims(2)
	+ Nml.simps(2) HcompNml.simps(12) HcompNml_Prim Ide_HcompNml
	+ Src.simps(2) term.disc(2))
	+ show "\<And>v w u.
	+ (\<And>u. Nml v \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> Trg w = Trg u \<Longrightarrow> Can (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<Longrightarrow>
	+ (\<And>ua. Nml w \<Longrightarrow> Can ua \<and> Nml ua \<Longrightarrow> Trg u = Trg ua \<Longrightarrow> Can (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ua)) \<Longrightarrow>
	+ Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w) \<Longrightarrow>
	+ Can u \<and> Nml u \<Longrightarrow> Src w = Trg u \<Longrightarrow> Can ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ by (metis Nml_HcompD(3-4) HcompNml_Nml Nml_HcompNml(1)
	+ HcompNml_assoc Trg_HcompNml)
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma Inv_HcompNml:
	+ assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "Inv (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
	+ proof -
	+ have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Src t = Trg u \<rbrakk>
	+ \<Longrightarrow> Inv (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
	+ proof (induct t, simp_all add: HcompNml_Trg_Nml HcompNml_Nml_Src)
	+ show "\<And>x u. \<lbrakk> obj x; Can u \<and> Nml u; \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Trg u \<rbrakk> \<Longrightarrow> Inv u = Inv (Trg u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
	+ by (metis HcompNml.simps(1) Inv.simps(1))
	+ show "\<And>x u. ide x \<and> arr x \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u \<Longrightarrow>
	+ Inv (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
	+ by (metis Ide.simps(2) HcompNml.simps(2) HcompNml_Prim Inv.simps(1,3)
	+ Inv_Ide Inv_Inv is_Prim\<^sub>0_def)
	+ fix v w u
	+ assume I1: "\<And>x. Nml v \<Longrightarrow> Can x \<and> Nml x \<Longrightarrow> Trg w = Trg x \<Longrightarrow>
	+ Inv (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv x"
	+ assume I2: "\<And>x. Nml w \<Longrightarrow> Can x \<and> Nml x \<Longrightarrow> Trg u = Trg x \<Longrightarrow>
	+ Inv (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Inv w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv x"
	+ assume vw: "Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w)"
	+ assume wu: "Src w = Trg u"
	+ assume u: "Can u \<and> Nml u"
	+ have v: "Can v \<and> Nml v"
	+ using vw Nml_HcompD by blast
	+ have w: "Can w \<and> Nml w"
	+ using v vw by (cases v, simp_all)
	+ show "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = (Inv v \<^bold>\<star> Inv w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
	+ proof -
	+ have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
	+ apply (cases u) by simp_all
	+ moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
	+ proof -
	+ assume 1: "\<not> is_Prim\<^sub>0 u"
	+ have "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u))"
	+ using 1 by (cases u, simp_all)
	+ also have "... = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using u v w vw wu I1 Nml_HcompNml Can_HcompNml Nml_Inv Can_Inv
	+ by simp
	+ also have "... = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (Inv w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u)"
	+ using u v w I2 Nml_HcompNml by simp
	+ also have "... = (Inv v \<^bold>\<star> Inv w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
	+ using v 1 by (cases u, simp_all)
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ text \<open>
	+ The following function defines vertical composition for compatible normal terms,
	+ by ``pushing the composition down'' to arrows of @{text V}.
	+ \<close>
	+
	+ fun VcompNml :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term" (infixr "\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>" 55)
	+ where "\<^bold>\<langle>\<nu>\<^bold>\<rangle>\<^sub>0 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = u"
	+ \| "\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>\<nu> \<cdot> \<mu>\<^bold>\<rangle>"
	+ \| "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (w \<^bold>\<star> x) = (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w \<^bold>\<star> v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
	+ \| "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = t"
	+ \| "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> _ = undefined \<^bold>\<cdot> undefined"
	+
	+ text \<open>
	+ Note that the last clause above is not relevant to normal terms.
	+ We have chosen a provably non-normal value in order to validate associativity.
	+ \<close>
	+
	+ lemma Nml_VcompNml:
	+ assumes "Nml t" and "Nml u" and "Dom t = Cod u"
	+ shows "Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
	+ and "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
	+ and "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
	+ proof -
	+ have 0: "\<And>u. \<lbrakk> Nml t; Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
	+ Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
	+ proof (induct t, simp_all add: Nml_HcompD)
	+ show "\<And>x u. obj x \<Longrightarrow> Nml u \<Longrightarrow> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod u \<Longrightarrow>
	+ Nml (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and>
	+ Cod (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod (Cod u)"
	+ by (metis Cod.simps(1) VcompNml.simps(1))
	+ fix \<nu> u
	+ assume \<nu>: "arr \<nu>"
	+ assume u: "Nml u"
	+ assume 1: "\<^bold>\<langle>dom \<nu>\<^bold>\<rangle> = Cod u"
	+ show "Nml (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = \<^bold>\<langle>cod \<nu>\<^bold>\<rangle>"
	+ using \<nu> u 1 by (cases u, simp_all)
	+ next
	+ fix u v w
	+ assume I2: "\<And>u. \<lbrakk> Nml u; Dom w = Cod u \<rbrakk> \<Longrightarrow>
	+ Nml (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod w"
	+ assume vw: "Nml (v \<^bold>\<star> w)"
	+ have v: "Nml v"
	+ using vw Nml_HcompD by force
	+ have w: "Nml w"
	+ using vw Nml_HcompD by force
	+ assume u: "Nml u"
	+ assume 1: "(Dom v \<^bold>\<star> Dom w) = Cod u"
	+ show "Nml ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and>
	+ Cod ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod v \<^bold>\<star> Cod w"
	+ using u v w 1
	+ proof (cases u, simp_all)
	+ fix x y
	+ assume 2: "u = x \<^bold>\<star> y"
	+ have 4: "is_Prim x \<and> x = \<^bold>\<langle>un_Prim x\<^bold>\<rangle> \<and> arr (un_Prim x) \<and> Nml y \<and> \<not> is_Prim\<^sub>0 y"
	+ using u 2 by (cases x, cases y, simp_all)
	+ have 5: "is_Prim v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> arr (un_Prim v) \<and> Nml w \<and> \<not> is_Prim\<^sub>0 w"
	+ using v w vw by (cases v, simp_all)
	+ have 6: "dom (un_Prim v) = cod (un_Prim x) \<and> Dom w = Cod y"
	+ proof -
	+ have "\<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w" using vw Nml_HcompD [of v w] by simp
	+ thus "dom (un_Prim v) = cod (un_Prim x) \<and> Dom w = Cod y"
	+ using 1 2 4 5 apply (cases u, simp_all)
	+ by (metis Cod.simps(2) Dom.simps(2) term.simps(2))
	+ qed
	+ have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = \<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y"
	+ using 2 4 5 6 VcompNml.simps(2) [of "un_Prim v" "un_Prim x"] by simp
	+ moreover have "Nml (\<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
	+ proof -
	+ have "Nml (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
	+ using I2 4 5 6 by simp
	+ moreover have "\<not> is_Prim\<^sub>0 (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
	+ using vw 4 5 6 I2 Nml_Cod Nml_HcompD(5) is_Prim\<^sub>0_def
	+ by (metis Cod.simps(1) Cod.simps(3))
	+ moreover have "\<^bold>\<langle>src (un_Prim v \<cdot> un_Prim x)\<^bold>\<rangle>\<^sub>0 = Trg (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
	+ using vw 4 5 6 I2 Nml_HcompD(6) Nml_implies_Arr
	+ src.is_natural_1 src.preserves_comp_2 Trg_Cod src_cod
	+ by (metis seqI)
	+ ultimately show ?thesis
	+ using 4 5 6 Nml.simps(3) [of "un_Prim v \<cdot> un_Prim x" "(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"]
	+ by simp
	+ qed
	+ ultimately show "Nml (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) \<and>
	+ Dom (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Dom x \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) = Dom y \<and>
	+ Cod (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Cod v \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) = Cod w"
	+ using 4 5 6 I2
	+ by (metis (no_types, lifting) Cod.simps(2) Dom.simps(2) VcompNml.simps(2)
	+ cod_comp dom_comp seqI)
	+ qed
	+ qed
	+ show "Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)" using assms 0 by blast
	+ show "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u" using assms 0 by blast
	+ show "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t" using assms 0 by blast
	+ qed
	+
	+ lemma VcompNml_in_Hom [intro]:
	+ assumes "Nml t" and "Nml u" and "Dom t = Cod u"
	+ shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> HHom (Src u) (Trg u)" and "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> VHom (Dom u) (Cod t)"
	+ proof -
	+ show 1: "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> VHom (Dom u) (Cod t)"
	+ using assms Nml_VcompNml Nml_implies_Arr by simp
	+ show "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> HHom (Src u) (Trg u)"
	+ using assms 1 Src_Dom Trg_Dom Nml_implies_Arr by fastforce
	+ qed
	+
	+ lemma Src_VcompNml:
	+ assumes "Nml t" and "Nml u" and "Dom t = Cod u"
	+ shows "Src (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Src u"
	+ using assms VcompNml_in_Hom by simp
	+
	+ lemma Trg_VcompNml:
	+ assumes "Nml t" and "Nml u" and "Dom t = Cod u"
	+ shows "Trg (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Trg u"
	+ using assms VcompNml_in_Hom by simp
	+
	+ lemma Dom_VcompNml:
	+ assumes "Nml t" and "Nml u" and "Dom t = Cod u"
	+ shows "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
	+ using assms Nml_VcompNml(2) by simp
	+
	+ lemma Cod_VcompNml:
	+ assumes "Nml t" and "Nml u" and "Dom t = Cod u"
	+ shows "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
	+ using assms Nml_VcompNml(3) by simp
	+
	+ lemma VcompNml_Cod_Nml [simp]:
	+ assumes "Nml t"
	+ shows "VcompNml (Cod t) t = t"
	+ proof -
	+ have "Nml t \<Longrightarrow> Cod t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
	+ apply (induct t)
	+ by (auto simp add: Nml_HcompD comp_cod_arr)
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma VcompNml_Nml_Dom [simp]:
	+ assumes "Nml t"
	+ shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Dom t) = t"
	+ proof -
	+ have "Nml t \<Longrightarrow> t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Dom t = t"
	+ apply (induct t) by (auto simp add: Nml_HcompD comp_arr_dom)
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma VcompNml_Ide_Nml [simp]:
	+ assumes "Nml t" and "Ide a" and "Dom a = Cod t"
	+ shows "a \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
	+ using assms Ide_in_Hom by simp
	+
	+ lemma VcompNml_Nml_Ide [simp]:
	+ assumes "Nml t" and "Ide a" and "Dom t = Cod a"
	+ shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> a = t"
	+ using assms Ide_in_Hom by auto
	+
	+ lemma VcompNml_assoc:
	+ assumes "Nml t" and "Nml u" and "Nml v"
	+ and "Dom t = Cod u" and "Dom u = Cod v"
	+ shows "(t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
	+ proof -
	+ have "\<And>u v. \<lbrakk> Nml t; Nml u; Nml v; Dom t = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
	+ (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
	+ proof (induct t, simp_all)
	+ show "\<And>x u v. obj x \<Longrightarrow> Nml u \<Longrightarrow> Nml v \<Longrightarrow> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod u \<Longrightarrow> Dom u = Cod v \<Longrightarrow>
	+ u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v"
	+ by (metis VcompNml.simps(1))
	+ fix f u v
	+ assume f: "arr f"
	+ assume u: "Nml u"
	+ assume v: "Nml v"
	+ assume 1: "\<^bold>\<langle>dom f\<^bold>\<rangle> = Cod u"
	+ assume 2: "Dom u = Cod v"
	+ show "(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
	+ using u v f 1 2 comp_assoc
	+ apply (cases u)
	+ apply simp_all
	+ apply (cases v)
	+ by simp_all
	+ next
	+ fix u v w x
	+ assume I1: "\<And>u v. \<lbrakk> Nml w; Nml u; Nml v; Dom w = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
	+ (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
	+ assume I2: "\<And>u v. \<lbrakk> Nml x; Nml u; Nml v; Dom x = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
	+ (x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
	+ assume wx: "Nml (w \<^bold>\<star> x)"
	+ assume u: "Nml u"
	+ assume v: "Nml v"
	+ assume 1: "(Dom w \<^bold>\<star> Dom x) = Cod u"
	+ assume 2: "Dom u = Cod v"
	+ show "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v"
	+ proof -
	+ have w: "Nml w"
	+ using wx Nml_HcompD by blast
	+ have x: "Nml x"
	+ using wx Nml_HcompD by blast
	+ have "is_Hcomp u"
	+ using u 1 by (cases u) simp_all
	+ thus ?thesis
	+ using u v apply (cases u, simp_all, cases v, simp_all)
	+ proof -
	+ fix u1 u2 v1 v2
	+ assume 3: "u = (u1 \<^bold>\<star> u2)"
	+ assume 4: "v = (v1 \<^bold>\<star> v2)"
	+ show "(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u1) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 = w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 \<and>
	+ (x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u2) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2 = x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2"
	+ proof -
	+ have "Nml u1 \<and> Nml u2"
	+ using u 3 Nml_HcompD by blast
	+ moreover have "Nml v1 \<and> Nml v2"
	+ using v 4 Nml_HcompD by blast
	+ ultimately show ?thesis using w x I1 I2 1 2 3 4 by simp
	+ qed
	+ qed
	+ qed
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma Ide_VcompNml:
	+ assumes "Ide t" and "Ide u" and "Nml t" and "Nml u" and "Dom t = Cod u"
	+ shows "Ide (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
	+ proof -
	+ have "\<And>u. \<lbrakk> Ide t; Ide u; Nml t; Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow> Ide (VcompNml t u)"
	+ by (induct t, simp_all)
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma Can_VcompNml:
	+ assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Dom t = Cod u"
	+ shows "Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
	+ proof -
	+ have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
	+ proof (induct t, simp_all)
	+ fix t u v
	+ assume I1: "\<And>v. \<lbrakk> Nml t; Can v \<and> Nml v; Dom t = Cod v \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
	+ assume I2: "\<And>v. \<lbrakk> Nml u; Can v \<and> Nml v; Dom u = Cod v \<rbrakk> \<Longrightarrow> Can (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
	+ assume tu: "Can t \<and> Can u \<and> Src t = Trg u \<and> Nml (t \<^bold>\<star> u)"
	+ have t: "Can t \<and> Nml t"
	+ using tu Nml_HcompD by blast
	+ have u: "Can u \<and> Nml u"
	+ using tu Nml_HcompD by blast
	+ assume v: "Can v \<and> Nml v"
	+ assume 1: "(Dom t \<^bold>\<star> Dom u) = Cod v"
	+ show "Can ((t \<^bold>\<star> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
	+ proof -
	+ have 2: "(Dom t \<^bold>\<star> Dom u) = Cod v" using 1 by simp
	+ show ?thesis
	+ using v 2
	+ proof (cases v; simp)
	+ fix w x
	+ assume wx: "v = (w \<^bold>\<star> x)"
	+ have "Can w \<and> Nml w" using v wx Nml_HcompD Can.simps(3) by blast
	+ moreover have "Can x \<and> Nml x" using v wx Nml_HcompD Can.simps(3) by blast
	+ moreover have "Dom t = Cod w" using 2 wx by simp
	+ moreover have ux: "Dom u = Cod x" using 2 wx by simp
	+ ultimately show "Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w) \<and> Can (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) \<and> Src (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w) = Trg (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
	+ using t u v tu wx I1 I2
	+ by (metis Nml_HcompD(7) Src_VcompNml Trg_VcompNml)
	+ qed
	+ qed
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma Inv_VcompNml:
	+ assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Dom t = Cod u"
	+ shows "Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
	+ proof -
	+ have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
	+ Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
	+ proof (induct t, simp_all)
	+ show "\<And>x u. \<lbrakk> obj x; Can u \<and> Nml u; \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod u \<rbrakk> \<Longrightarrow> Inv u = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv (Cod u)"
	+ by (simp add: Can_implies_Arr)
	+ show "\<And>x u. \<lbrakk> ide x \<and> arr x; Can u \<and> Nml u; \<^bold>\<langle>x\<^bold>\<rangle> = Cod u \<rbrakk> \<Longrightarrow>
	+ Inv u = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv (Cod u)"
	+ by (simp add: Can_implies_Arr)
	+ fix v w u
	+ assume vw: "Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w)"
	+ have v: "Can v \<and> Nml w"
	+ using vw Nml_HcompD by blast
	+ have w: "Can w \<and> Nml w"
	+ using vw Nml_HcompD by blast
	+ assume I1: "\<And>x. \<lbrakk> Nml v; Can x \<and> Nml x; Dom v = Cod x \<rbrakk> \<Longrightarrow>
	+ Inv (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Inv x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv v"
	+ assume I2: "\<And>x. \<lbrakk> Nml w; Can x \<and> Nml x; Dom w = Cod x \<rbrakk> \<Longrightarrow>
	+ Inv (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Inv x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv w"
	+ assume u: "Can u \<and> Nml u"
	+ assume 1: "(Dom v \<^bold>\<star> Dom w) = Cod u"
	+ show "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> Inv w)"
	+ using v 1
	+ proof (cases w, simp_all)
	+ show "\<And>\<mu>. obj \<mu> \<Longrightarrow> Dom v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = Cod u \<Longrightarrow> w = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> Can v \<Longrightarrow>
	+ Inv ((v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0)"
	+ using Nml_HcompD(5) is_Prim\<^sub>0_def vw by blast
	+ show "\<And>\<mu>. arr \<mu> \<Longrightarrow> Dom v \<^bold>\<star> \<^bold>\<langle>dom \<mu>\<^bold>\<rangle> = Cod u \<Longrightarrow> w = \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<Longrightarrow> Can v \<Longrightarrow>
	+ Inv ((v \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> \<^bold>\<langle>inv \<mu>\<^bold>\<rangle>)"
	+ by (metis Ide.simps(2) Can.simps(2) Nml_HcompD(1) Dom.simps(2) Inv_Ide
	+ Dom_Inv Nml_Inv ideD(2) inv_ide VcompNml_Cod_Nml VcompNml_Nml_Dom
	+ u vw)
	+ show "\<And>y z. Nml (y \<^bold>\<star> z) \<Longrightarrow> Dom v \<^bold>\<star> Dom y \<^bold>\<star> Dom z = Cod u \<Longrightarrow>
	+ w = y \<^bold>\<star> z \<Longrightarrow> Can v \<Longrightarrow>
	+ Inv ((v \<^bold>\<star> y \<^bold>\<star> z) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> Inv y \<^bold>\<star> Inv z)"
	+ proof -
	+ fix y z
	+ assume 2: "Nml (y \<^bold>\<star> z)"
	+ assume yz: "w = y \<^bold>\<star> z"
	+ show "Inv ((v \<^bold>\<star> y \<^bold>\<star> z) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv v \<^bold>\<star> Inv y \<^bold>\<star> Inv z)"
	+ using u vw yz I1 I2 1 2 VcompNml_Nml_Ide
	+ apply (cases u)
	+ apply simp_all
	+ by (metis Nml_HcompD(3-4))
	+ qed
	+ qed
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma Can_and_Nml_implies_Ide:
	+ assumes "Can t" and "Nml t"
	+ shows "Ide t"
	+ proof -
	+ have "\<lbrakk> Can t; Nml t \<rbrakk> \<Longrightarrow> Ide t"
	+ apply (induct t) by (simp_all add: Nml_HcompD)
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma VcompNml_Can_Inv [simp]:
	+ assumes "Can t" and "Nml t"
	+ shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t = Cod t"
	+ using assms Can_and_Nml_implies_Ide Ide_in_Hom by simp
	+
	+ lemma VcompNml_Inv_Can [simp]:
	+ assumes "Can t" and "Nml t"
	+ shows "Inv t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = Dom t"
	+ using assms Can_and_Nml_implies_Ide Ide_in_Hom by simp
	+
	+ text \<open>
	+ The next fact is a syntactic version of the interchange law, for normal terms.
	+ \<close>
	+
	+ lemma VcompNml_HcompNml:
	+ assumes "Nml t" and "Nml u" and "Nml v" and "Nml w"
	+ and "VSeq t v" and "VSeq u w" and "Src v = Trg w"
	+ shows "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
	+ proof -
	+ have "\<And>u v w. \<lbrakk> Nml t; Nml u; Nml v; Nml w; VSeq t v; VSeq u w;
	+ Src t = Trg u; Src v = Trg w \<rbrakk> \<Longrightarrow>
	+ (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
	+ proof (induct t, simp_all)
	+ fix u v w x
	+ assume u: "Nml u"
	+ assume v: "Nml v"
	+ assume w: "Nml w"
	+ assume uw: "VSeq u w"
	+ show "\<And>x. Arr v \<and> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod v \<Longrightarrow> (Cod v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
	+ using u v w uw by (cases v) simp_all
	+ show "\<And>x. \<lbrakk> arr x; Arr v \<and> \<^bold>\<langle>dom x\<^bold>\<rangle> = Cod v; \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u; Src v = Trg w \<rbrakk> \<Longrightarrow>
	+ (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
	+ proof -
	+ fix x
	+ assume x: "arr x"
	+ assume 1: "Arr v \<and> \<^bold>\<langle>dom x\<^bold>\<rangle> = Cod v"
	+ assume tu: "\<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u"
	+ assume vw: "Src v = Trg w"
	+ show "(\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
	+ proof -
	+ have 2: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> arr (un_Prim v)" using v 1 by (cases v) simp_all
	+ have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
	+ using u v w x tu uw vw 1 2 Cod.simps(3) VcompNml_Cod_Nml Dom.simps(2)
	+ HcompNml_Prim HcompNml_term_Prim\<^sub>0 Nml_HcompNml(3) HcompNml_Trg_Nml
	+ apply (cases u, simp_all)
	+ by (cases w, simp_all add: Src_VcompNml)
	+ moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
	+ proof -
	+ assume 3: "\<not> is_Prim\<^sub>0 u"
	+ hence 4: "\<not> is_Prim\<^sub>0 w" using u w uw by (cases u, simp_all; cases w, simp_all)
	+ have "(\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<star> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<star> w)"
	+ proof -
	+ have "\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<star> u"
	+ using u x 3 HcompNml_Nml by (cases u, simp_all)
	+ moreover have "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w = v \<^bold>\<star> w"
	+ using w 2 4 HcompNml_Nml by (cases v, simp_all; cases w, simp_all)
	+ ultimately show ?thesis by simp
	+ qed
	+ also have 5: "... = (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<star> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)" by simp
	+ also have "... = (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
	+ using x u w uw vw 1 2 3 4 5
	+ HcompNml_Nml HcompNml_Prim Nml_HcompNml(1)
	+ by (metis Cod.simps(3) Nml.simps(3) Dom.simps(2) Dom.simps(3)
	+ Nml_VcompNml(1) tu v)
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ fix t1 t2
	+ assume t12: "Nml (t1 \<^bold>\<star> t2)"
	+ assume I1: "\<And>u v w. \<lbrakk> Nml t1; Nml u; Nml v; Nml w;
	+ Arr v \<and> Dom t1 = Cod v; VSeq u w;
	+ Trg t2 = Trg u; Src v = Trg w \<rbrakk> \<Longrightarrow>
	+ (t1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
	+ assume I2: "\<And>u' v w. \<lbrakk> Nml t2; Nml u'; Nml v; Nml w;
	+ Arr v \<and> Dom t2 = Cod v; VSeq u' w;
	+ Trg u = Trg u'; Src v = Trg w \<rbrakk> \<Longrightarrow>
	+ (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u') \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u' \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
	+ have t1: "t1 = \<^bold>\<langle>un_Prim t1\<^bold>\<rangle> \<and> arr (un_Prim t1) \<and> Nml t1"
	+ using t12 by (cases t1, simp_all)
	+ have t2: "Nml t2 \<and> \<not>is_Prim\<^sub>0 t2"
	+ using t12 by (cases t1, simp_all)
	+ assume vw: "Src v = Trg w"
	+ assume tu: "Src t2 = Trg u"
	+ assume 1: "Arr t1 \<and> Arr t2 \<and> Src t1 = Trg t2 \<and> Arr v \<and> (Dom t1 \<^bold>\<star> Dom t2) = Cod v"
	+ show "((t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
	+ proof -
	+ have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
	+ using u v w uw tu vw t12 I1 I2 1 Obj_Src
	+ apply (cases u, simp_all)
	+ by (cases w, simp_all add: Src_VcompNml)
	+ moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
	+ proof -
	+ assume u': "\<not> is_Prim\<^sub>0 u"
	+ hence w': "\<not> is_Prim\<^sub>0 w" using u w uw by (cases u, simp_all; cases w, simp_all)
	+ show ?thesis
	+ using 1 v
	+ proof (cases v, simp_all)
	+ fix v1 v2
	+ assume v12: "v = v1 \<^bold>\<star> v2"
	+ have v1: "v1 = \<^bold>\<langle>un_Prim v1\<^bold>\<rangle> \<and> arr (un_Prim v1) \<and> Nml v1"
	+ using v v12 by (cases v1, simp_all)
	+ have v2: "Nml v2 \<and> \<not> is_Prim\<^sub>0 v2"
	+ using v v12 by (cases v1, simp_all)
	+ have 2: "v = (\<^bold>\<langle>un_Prim v1\<^bold>\<rangle> \<^bold>\<star> v2)"
	+ using v1 v12 by simp
	+ show "((t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((v1 \<^bold>\<star> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 \<^bold>\<star> t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w"
	+ proof -
	+ have 3: "(t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = t1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using u u' by (cases u, simp_all)
	+ have 4: "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w = v1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
	+ proof -
	+ have "Src v1 = Trg v2"
	+ using v v12 1 Arr.simps(3) Nml_HcompD(7) by blast
	+ moreover have "Src v2 = Trg w"
	+ using v v12 vw by simp
	+ ultimately show ?thesis
	+ using v w v1 v2 v12 2 HcompNml_assoc [of v1 v2 w] HcompNml_Nml by metis
	+ qed
	+ have "((t1 \<^bold>\<star> t2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((v1 \<^bold>\<star> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w)
	+ = (t1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v1 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w))"
	+ using 3 4 v12 by simp
	+ also have "... = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ((t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w))"
	+ proof -
	+ have "is_Hcomp (t2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
	+ using t2 u u' tu is_Hcomp_HcompNml by auto
	+ moreover have "is_Hcomp (v2 \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w)"
	+ using v2 v12 w w' vw is_Hcomp_HcompNml by auto
	+ ultimately show ?thesis
	+ using u u' v w t1 v1 t12 v12 HcompNml_Prim
	+ by (metis VcompNml.simps(2) VcompNml.simps(3) is_Hcomp_def
	+ term.distinct_disc(3))
	+ qed
	+ also have "... = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
	+ using u w tu uw vw t2 v2 1 2 Nml_implies_Arr I2 by auto
	+ also have "... = ((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<star> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
	+ proof -
	+ have "\<not>is_Prim\<^sub>0 (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
	+ using u w u' w' by (cases u, simp_all; cases w, simp_all)
	+ hence "((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<star> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)
	+ = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ((t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w))"
	+ by (cases "u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w") simp_all
	+ thus ?thesis by presburger
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ moreover have "Src t = Trg u"
	+ using assms Src_Dom Trg_Dom Src_Cod Trg_Cod Nml_implies_Arr by metis
	+ ultimately show ?thesis using assms by simp
	+ qed
	+
	+ text \<open>
	+ The following function reduces a formal arrow to normal form.
	+ \<close>
	+
	+ fun Nmlize :: "'a term \<Rightarrow> 'a term" ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
	+ where "\<^bold>\<lfloor>\<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0\<^bold>\<rfloor> = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
	+ \| "\<^bold>\<lfloor>\<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^bold>\<rfloor> = \<^bold>\<langle>\<mu>\<^bold>\<rangle>"
	+ \| "\<^bold>\<lfloor>t \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ \| "\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ \| "\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ \| "\<^bold>\<lfloor>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ \| "\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ \| "\<^bold>\<lfloor>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ \| "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"
	+ \| "\<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
	+
	+ lemma Nml_Nmlize:
	+ assumes "Arr t"
	+ shows "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t" and "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t"
	+ and "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
	+ proof -
	+ have 0: "Arr t \<Longrightarrow> Nml \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t \<and> Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t \<and>
	+ Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
	+ using Nml_HcompNml Nml_VcompNml HcompNml_assoc
	+ Src_VcompNml Trg_VcompNml VSeq_implies_HPar
	+ apply (induct t)
	+ apply auto
	+ proof -
	+ fix t
	+ assume 1: "Arr t"
	+ assume 2: "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ assume 3: "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t"
	+ assume 4: "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t"
	+ assume 5: "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>"
	+ assume 6: "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
	+ have 7: "Nml \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>"
	+ using 2 5 Nml_Dom by fastforce
	+ have 8: "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Trg t\<^bold>\<rfloor>"
	+ using 1 2 4 Nml_Trg Obj_Trg
	+ by (metis Nml.elims(2) Nmlize.simps(1) Nmlize.simps(2) Obj.simps(3))
	+ have 9: "Nml \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
	+ using 2 6 Nml_Cod by fastforce
	+ have 10: "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
	+ using 1 2 3 Nml_Src Obj_Src
	+ by (metis Nml.elims(2) Nmlize.simps(1) Nmlize.simps(2) Obj.simps(3))
	+ show "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>"
	+ using 2 5 7 8 Nml_implies_Arr Trg_Dom HcompNml_Trg_Nml by metis
	+ show "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = \<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
	+ using 2 6 8 9 Nml_implies_Arr Trg_Cod HcompNml_Trg_Nml by metis
	+ show "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
	+ using 2 5 7 10 Nml_implies_Arr Src_Dom HcompNml_Nml_Src by metis
	+ show "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
	+ using 2 6 9 10 Nml_implies_Arr Src_Cod HcompNml_Nml_Src by metis
	+ next
	+ fix t1 t2 t3
	+ assume "Nml \<^bold>\<lfloor>t1\<^bold>\<rfloor>" and "Nml \<^bold>\<lfloor>t2\<^bold>\<rfloor>" and "Nml \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
	+ assume "Src t1 = Trg t2" and "Src t2 = Trg t3"
	+ assume "Src \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t2" and "Src \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t3"
	+ assume "Trg \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t1" and "Trg \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t2" and "Trg \<^bold>\<lfloor>t3\<^bold>\<rfloor> = Trg t3"
	+ assume "Dom \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>" and "Dom \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>"
	+ and "Cod \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>" and "Dom \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>"
	+ show "\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor> =
	+ (\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>"
	+ using Nml_Dom Nml_implies_Arr Src_Dom Trg_Dom
	+ HcompNml_assoc [of "\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>" "\<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>"]
	+ \<open>Nml \<^bold>\<lfloor>t1\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t2\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t3\<^bold>\<rfloor>\<close>
	+ \<open>Dom \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor>\<close> \<open>Dom \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>\<close> \<open>Dom \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>\<close>
	+ \<open>Src \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t2\<close> \<open>Trg \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t2\<close>
	+ \<open>Src \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t3\<close> \<open>Trg \<^bold>\<lfloor>t3\<^bold>\<rfloor> = Trg t3\<close>
	+ by metis
	+ show "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor> = (\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>"
	+ using Nml_Cod Nml_implies_Arr Src_Cod Trg_Cod
	+ HcompNml_assoc [of "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>" "\<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>"]
	+ \<open>Nml \<^bold>\<lfloor>t1\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t2\<^bold>\<rfloor>\<close> \<open>Nml \<^bold>\<lfloor>t3\<^bold>\<rfloor>\<close>
	+ \<open>Cod \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>\<close> \<open>Cod \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>\<close> \<open>Cod \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>\<close>
	+ \<open>Src \<^bold>\<lfloor>t1\<^bold>\<rfloor> = Trg t2\<close> \<open>Trg \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t2\<close>
	+ \<open>Src \<^bold>\<lfloor>t2\<^bold>\<rfloor> = Trg t3\<close> \<open>Trg \<^bold>\<lfloor>t3\<^bold>\<rfloor> = Trg t3\<close>
	+ by metis
	+ qed
	+ show "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>" using assms 0 by blast
	+ show "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Src t" using assms 0 by blast
	+ show "Trg \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg t" using assms 0 by blast
	+ show "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>" using assms 0 by blast
	+ show "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>" using assms 0 by blast
	+ qed
	+
	+ lemma Nmlize_in_Hom [intro]:
	+ assumes "Arr t"
	+ shows "\<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> HHom (Src t) (Trg t)" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> VHom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
	+ using assms Nml_Nmlize Nml_implies_Arr by auto
	+
	+ lemma Nmlize_Src:
	+ assumes "Arr t"
	+ shows "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src t"
	+ proof -
	+ have 1: "Obj (Src t)"
	+ using assms by simp
	+ obtain a where a: "obj a \<and> Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
	+ using 1 by (cases "Src t", simp_all)
	+ show "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src t"
	+ using a by simp
	+ thus "\<^bold>\<lfloor>Src t\<^bold>\<rfloor> = Src \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms Nmlize_in_Hom by simp
	+ qed
	+
	+ lemma Nmlize_Trg:
	+ assumes "Arr t"
	+ shows "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg t"
	+ proof -
	+ have 1: "Obj (Trg t)"
	+ using assms by simp
	+ obtain a where a: "obj a \<and> Trg t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
	+ using 1 by (cases "Trg t", simp_all)
	+ show "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg t"
	+ using a by simp
	+ thus "\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms Nmlize_in_Hom by simp
	+ qed
	+
	+ lemma Nmlize_Dom:
	+ assumes "Arr t"
	+ shows "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms Nmlize_in_Hom by simp
	+
	+ lemma Nmlize_Cod:
	+ assumes "Arr t"
	+ shows "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms Nmlize_in_Hom by simp
	+
	+ lemma Ide_Nmlize_Ide:
	+ assumes "Ide t"
	+ shows "Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ proof -
	+ have "Ide t \<Longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using Ide_HcompNml Nml_Nmlize
	+ by (induct t, simp_all)
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma Ide_Nmlize_Can:
	+ assumes "Can t"
	+ shows "Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ proof -
	+ have "Can t \<Longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using Can_implies_Arr Ide_HcompNml Nml_Nmlize Ide_VcompNml Nml_HcompNml
	+ apply (induct t, auto simp add: Dom_Ide Cod_Ide)
	+ by (metis Ide_VcompNml)
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma Can_Nmlize_Can:
	+ assumes "Can t"
	+ shows "Can \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms Ide_Nmlize_Can Ide_implies_Can by auto
	+
	+ lemma Nmlize_Nml [simp]:
	+ assumes "Nml t"
	+ shows "\<^bold>\<lfloor>t\<^bold>\<rfloor> = t"
	+ proof -
	+ have "Nml t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> = t"
	+ apply (induct t, simp_all)
	+ using HcompNml_Prim Nml_HcompD by metis
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma Nmlize_Nmlize [simp]:
	+ assumes "Arr t"
	+ shows "\<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms Nml_Nmlize Nmlize_Nml by blast
	+
	+ lemma Nmlize_Hcomp:
	+ assumes "Arr t" and "Arr u"
	+ shows "\<^bold>\<lfloor>t \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<^bold>\<rfloor>"
	+ using assms Nmlize_Nmlize by simp
	+
	+ lemma Nmlize_Hcomp_Obj_Arr [simp]:
	+ assumes "Arr u"
	+ shows "\<^bold>\<lfloor>\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ using assms by simp
	+
	+ lemma Nmlize_Hcomp_Arr_Obj [simp]:
	+ assumes "Arr t" and "Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
	+ shows "\<^bold>\<lfloor>t \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms HcompNml_Nml_Src Nmlize_in_Hom by simp
	+
	+ lemma Nmlize_Hcomp_Prim_Arr [simp]:
	+ assumes "Arr u" and "\<not> is_Prim\<^sub>0 \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ shows "\<^bold>\<lfloor>\<^bold>\<langle>\<mu>\<^bold>\<rangle> \<^bold>\<star> u\<^bold>\<rfloor> = \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ using assms by simp
	+
	+ lemma Nmlize_Hcomp_Hcomp:
	+ assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
	+ shows "\<^bold>\<lfloor>(t \<^bold>\<star> u) \<^bold>\<star> v\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>v\<^bold>\<rfloor>)\<^bold>\<rfloor>"
	+ using assms Nml_Nmlize Nmlize_Nmlize by (simp add: HcompNml_assoc)
	+
	+ lemma Nmlize_Hcomp_Hcomp':
	+ assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
	+ shows "\<^bold>\<lfloor>t \<^bold>\<star> u \<^bold>\<star> v\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>v\<^bold>\<rfloor>\<^bold>\<rfloor>"
	+ using assms Nml_Nmlize Nmlize_Nmlize by (simp add: HcompNml_assoc)
	+
	+ lemma Nmlize_Vcomp_Cod_Arr:
	+ assumes "Arr t"
	+ shows "\<^bold>\<lfloor>Cod t \<^bold>\<cdot> t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ proof -
	+ have "Arr t \<Longrightarrow> \<^bold>\<lfloor>Cod t \<^bold>\<cdot> t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ proof (induct t, simp_all)
	+ show "\<And>x. arr x \<Longrightarrow> cod x \<cdot> x = x"
	+ using comp_cod_arr by blast
	+ fix t1 t2
	+ show "\<And>t1 t2. \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> HSeq t1 t2 \<Longrightarrow>
	+ (\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
	+ using VcompNml_HcompNml Ide_Cod Nml_Nmlize Nmlize_in_Hom
	+ by simp
	+ show "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> VSeq t1 t2 \<Longrightarrow>
	+ \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
	+ using VcompNml_assoc [of "\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>t2\<^bold>\<rfloor>"] Ide_Cod
	+ Nml_Nmlize
	+ by simp
	+ next
	+ show "\<And>t. \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> (\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ by (metis Arr.simps(6) Cod.simps(6) Nmlize.simps(3) Nmlize.simps(6)
	+ Nmlize_Cod)
	+ show "\<And>t. \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> (\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ by (simp add: Nml_Nmlize(1) Nml_Nmlize(2) Nmlize_Src(2) HcompNml_Nml_Obj)
	+ show "\<And>t1 t2 t3. \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
	+ \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
	+ Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
	+ (\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) =
	+ (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
	+ using VcompNml_HcompNml Ide_Cod HcompNml_in_Hom Nml_HcompNml
	+ Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
	+ by simp
	+ show "\<And>t1 t2 t3. \<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
	+ \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
	+ Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
	+ ((\<^bold>\<lfloor>Cod t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) =
	+ \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
	+ using VcompNml_HcompNml Ide_Cod HcompNml_in_Hom Nml_HcompNml
	+ Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
	+ by simp
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma Nmlize_Vcomp_Arr_Dom:
	+ assumes "Arr t"
	+ shows "\<^bold>\<lfloor>t \<^bold>\<cdot> Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ proof -
	+ have "Arr t \<Longrightarrow> \<^bold>\<lfloor>t \<^bold>\<cdot> Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ proof (induct t, simp_all)
	+ show "\<And>x. arr x \<Longrightarrow> x \<cdot> local.dom x = x"
	+ using comp_arr_dom by blast
	+ fix t1 t2
	+ show "\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> HSeq t1 t2 \<Longrightarrow>
	+ (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>) = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
	+ using VcompNml_HcompNml Ide_Dom HcompNml_in_Hom Nml_HcompNml
	+ Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
	+ by simp
	+ show "\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow> VSeq t1 t2 \<Longrightarrow>
	+ (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>"
	+ using VcompNml_assoc [of "\<^bold>\<lfloor>t1\<^bold>\<rfloor>" "\<^bold>\<lfloor>t2\<^bold>\<rfloor>" "\<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>"] Ide_Dom Nml_Nmlize
	+ by simp
	+ next
	+ show "\<And>t. \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Trg t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>) = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ by (simp add: Nml_Nmlize(1) Nml_Nmlize(3) Nmlize_Trg(2)
	+ HcompNml_Obj_Nml bicategorical_language.Ide_Dom
	+ bicategorical_language_axioms)
	+ show "\<And>t. \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<Longrightarrow> Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>) = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ by (simp add: Nml_Nmlize(1) Nml_Nmlize(2) Nmlize_Src(2) HcompNml_Nml_Obj)
	+ show "\<And>t1 t2 t3. \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
	+ \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
	+ Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
	+ ((\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>) =
	+ (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
	+ using VcompNml_HcompNml Ide_Dom HcompNml_in_Hom Nml_HcompNml
	+ Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
	+ by simp
	+ show "\<And>t1 t2 t3. \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> = \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<Longrightarrow> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> = \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<Longrightarrow>
	+ \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor> = \<^bold>\<lfloor>t3\<^bold>\<rfloor> \<Longrightarrow>
	+ Arr t1 \<and> Arr t2 \<and> Arr t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3 \<Longrightarrow>
	+ (\<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>Dom t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t3\<^bold>\<rfloor>) =
	+ \<^bold>\<lfloor>t1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>t3\<^bold>\<rfloor>"
	+ using VcompNml_HcompNml Ide_Dom HcompNml_in_Hom Nml_HcompNml
	+ Nml_Nmlize Nmlize_in_Hom HcompNml_assoc
	+ by simp
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma Nmlize_Inv:
	+ assumes "Can t"
	+ shows "\<^bold>\<lfloor>Inv t\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ proof -
	+ have "Can t \<Longrightarrow> \<^bold>\<lfloor>Inv t\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ proof (induct t, simp_all)
	+ fix u v
	+ assume I1: "\<^bold>\<lfloor>Inv u\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ assume I2: "\<^bold>\<lfloor>Inv v\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>v\<^bold>\<rfloor>"
	+ show "Can u \<and> Can v \<and> Src u = Trg v \<Longrightarrow> Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
	+ using Inv_HcompNml Nml_Nmlize Can_implies_Arr Can_Nmlize_Can
	+ I1 I2
	+ by simp
	+ show "Can u \<and> Can v \<and> Dom u = Cod v \<Longrightarrow> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
	+ using Inv_VcompNml Nml_Nmlize Can_implies_Arr Nmlize_in_Hom Can_Nmlize_Can
	+ I1 I2
	+ by simp
	+ fix w
	+ assume I3: "\<^bold>\<lfloor>Inv w\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>w\<^bold>\<rfloor>"
	+ assume uvw: "Can u \<and> Can v \<and> Can w \<and> Src u = Trg v \<and> Src v = Trg w"
	+ show "Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>w\<^bold>\<rfloor>) = Inv ((\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
	+ using uvw I1 I2 I3
	+ Inv_HcompNml Nml_Nmlize Can_implies_Arr Can_Nmlize_Can
	+ Nml_HcompNml Can_HcompNml HcompNml_assoc
	+ by simp
	+ show "(Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>w\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>))"
	+ using uvw I1 I2 I3
	+ Inv_HcompNml Nml_Nmlize Can_implies_Arr Can_Nmlize_Can
	+ Nml_HcompNml Can_HcompNml HcompNml_assoc Can_Inv
	+ by simp
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ subsection "Reductions"
	+
	+ text \<open>
	+ Function \<open>red\<close> defined below takes a formal identity @{term t} to a canonical arrow
	+ \<open>f\<^bold>\<down> \<in> Hom f \<^bold>\<lfloor>f\<^bold>\<rfloor>\<close>. The auxiliary function \<open>red2\<close> takes a pair @{term "(f, g)"}
	+ of normalized formal identities and produces a canonical arrow
	+ \<open>f \<^bold>\<Down> g \<in> Hom (f \<^bold>\<star> g) \<^bold>\<lfloor>f \<^bold>\<star> g\<^bold>\<rfloor>\<close>.
	+ \<close>
	+
	+ fun red2 (infixr "\<^bold>\<Down>" 53)
	+ where "\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<Down> u = \<^bold>\<l>\<^bold>[u\<^bold>]"
	+ \| "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = \<^bold>\<r>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]"
	+ \| "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> u = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> u"
	+ \| "(t \<^bold>\<star> u) \<^bold>\<Down> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = \<^bold>\<r>\<^bold>[t \<^bold>\<star> u\<^bold>]"
	+ \| "(t \<^bold>\<star> u) \<^bold>\<Down> v = (t \<^bold>\<Down> \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>) \<^bold>\<cdot> (t \<^bold>\<star> (u \<^bold>\<Down> v)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
	+ \| "t \<^bold>\<Down> u = undefined"
	+
	+ fun red ("_\<^bold>\<down>" [56] 56)
	+ where "\<^bold>\<langle>f\<^bold>\<rangle>\<^sub>0\<^bold>\<down> = \<^bold>\<langle>f\<^bold>\<rangle>\<^sub>0"
	+ \| "\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>\<down> = \<^bold>\<langle>f\<^bold>\<rangle>"
	+ \| "(t \<^bold>\<star> u)\<^bold>\<down> = (if Nml (t \<^bold>\<star> u) then t \<^bold>\<star> u else (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<cdot> (t\<^bold>\<down> \<^bold>\<star> u\<^bold>\<down>))"
	+ \| "t\<^bold>\<down> = undefined"
	+
	+ lemma red_Nml [simp]:
	+ assumes "Nml a"
	+ shows "a\<^bold>\<down> = a"
	+ using assms by (cases a, simp_all)
	+
	+ lemma red2_Nml:
	+ assumes "Nml (a \<^bold>\<star> b)"
	+ shows "a \<^bold>\<Down> b = a \<^bold>\<star> b"
	+ proof -
	+ have a: "a = \<^bold>\<langle>un_Prim a\<^bold>\<rangle>"
	+ using assms Nml_HcompD by metis
	+ have b: "Nml b \<and> \<not> is_Prim\<^sub>0 b"
	+ using assms Nml_HcompD by metis
	+ show ?thesis using a b
	+ apply (cases b)
	+ apply simp_all
	+ apply (metis red2.simps(3))
	+ by (metis red2.simps(4))
	+ qed
	+
	+ lemma Can_red2:
	+ assumes "Ide a" and "Nml a" and "Ide b" and "Nml b" and "Src a = Trg b"
	+ shows "Can (a \<^bold>\<Down> b)"
	+ and "a \<^bold>\<Down> b \<in> VHom (a \<^bold>\<star> b) \<^bold>\<lfloor>a \<^bold>\<star> b\<^bold>\<rfloor>"
	+ proof -
	+ have 0: "\<And>b. \<lbrakk> Ide a \<and> Nml a; Ide b \<and> Nml b; Src a = Trg b \<rbrakk> \<Longrightarrow>
	+ Can (a \<^bold>\<Down> b) \<and> a \<^bold>\<Down> b \<in> VHom (a \<^bold>\<star> b) \<^bold>\<lfloor>a \<^bold>\<star> b\<^bold>\<rfloor>"
	+ proof (induct a, simp_all add: HcompNml_Nml_Src HcompNml_Trg_Nml)
	+ fix x b
	+ show "Ide b \<and> Nml b \<Longrightarrow> Can (Trg b \<^bold>\<Down> b) \<and> Arr (Trg b \<^bold>\<Down> b) \<and>
	+ Dom (Trg b \<^bold>\<Down> b) = Trg b \<^bold>\<star> b \<and> Cod (Trg b \<^bold>\<Down> b) = b"
	+ using Ide_implies_Can Ide_in_Hom Nmlize_Nml
	+ apply (cases b, simp_all)
	+ proof -
	+ fix u v
	+ assume uv: "Ide u \<and> Ide v \<and> Src u = Trg v \<and> Nml (u \<^bold>\<star> v)"
	+ show "Can (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) \<and> Arr (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) \<and>
	+ Dom (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) = Trg u \<^bold>\<star> u \<^bold>\<star> v \<and>
	+ Cod (Trg u \<^bold>\<Down> (u \<^bold>\<star> v)) = u \<^bold>\<star> v"
	+ using uv Ide_implies_Can Can_implies_Arr Ide_in_Hom
	+ by (cases u, simp_all)
	+ qed
	+ show "ide x \<and> arr x \<Longrightarrow> Ide b \<and> Nml b \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg b \<Longrightarrow>
	+ Can (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) \<and> Arr (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) \<and> Dom (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<star> b \<and> Cod (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<Down> b) =
	+ \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b"
	+ using Ide_implies_Can Can_implies_Arr Nmlize_Nml Ide_in_Hom
	+ by (cases b, simp_all)
	+ next
	+ fix u v w
	+ assume uv: "Ide u \<and> Ide v \<and> Src u = Trg v \<and> Nml (u \<^bold>\<star> v)"
	+ assume vw: "Src v = Trg w"
	+ assume w: "Ide w \<and> Nml w"
	+ assume I1: "\<And>w. \<lbrakk> Nml u; Ide w \<and> Nml w; Trg v = Trg w \<rbrakk> \<Longrightarrow>
	+ Can (u \<^bold>\<Down> w) \<and> Arr (u \<^bold>\<Down> w) \<and>
	+ Dom (u \<^bold>\<Down> w) = u \<^bold>\<star> w \<and> Cod (u \<^bold>\<Down> w) = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
	+ assume I2: "\<And>x. \<lbrakk> Nml v; Ide x \<and> Nml x; Trg w = Trg x \<rbrakk> \<Longrightarrow>
	+ Can (v \<^bold>\<Down> x) \<and> Arr (v \<^bold>\<Down> x) \<and>
	+ Dom (v \<^bold>\<Down> x) = v \<^bold>\<star> x \<and> Cod (v \<^bold>\<Down> x) = v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x"
	+ show "Can ((u \<^bold>\<star> v) \<^bold>\<Down> w) \<and> Arr ((u \<^bold>\<star> v) \<^bold>\<Down> w) \<and>
	+ Dom ((u \<^bold>\<star> v) \<^bold>\<Down> w) = (u \<^bold>\<star> v) \<^bold>\<star> w \<and>
	+ Cod ((u \<^bold>\<star> v) \<^bold>\<Down> w) = (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
	+ proof -
	+ have u: "Nml u \<and> Ide u"
	+ using uv Nml_HcompD by blast
	+ have v: "Nml v \<and> Ide v"
	+ using uv Nml_HcompD by blast
	+ have "is_Prim\<^sub>0 w \<Longrightarrow> ?thesis"
	+ proof -
	+ assume 1: "is_Prim\<^sub>0 w"
	+ have 2: "(u \<^bold>\<star> v) \<^bold>\<Down> w = \<^bold>\<r>\<^bold>[u \<^bold>\<star> v\<^bold>]"
	+ using 1 by (cases w, simp_all)
	+ have 3: "Can (u \<^bold>\<Down> v) \<and> Arr (u \<^bold>\<Down> v) \<and> Dom (u \<^bold>\<Down> v) = u \<^bold>\<star> v \<and> Cod (u \<^bold>\<Down> v) = u \<^bold>\<star> v"
	+ using u v uv 1 2 I1 Nmlize_Nml Nmlize.simps(3) by metis
	+ hence 4: "VSeq (u \<^bold>\<Down> v) \<^bold>\<r>\<^bold>[u \<^bold>\<star> v\<^bold>]"
	+ using uv
	+ by (metis (mono_tags, lifting) Arr.simps(7) Cod.simps(3) Cod.simps(7)
	+ Nml_implies_Arr Ide_in_Hom(2) mem_Collect_eq)
	+ have "Can ((u \<^bold>\<star> v) \<^bold>\<Down> w)"
	+ using 1 2 3 4 uv by (simp add: Ide_implies_Can)
	+ moreover have "Dom ((u \<^bold>\<star> v) \<^bold>\<Down> w) = (u \<^bold>\<star> v) \<^bold>\<star> w"
	+ using 1 2 3 4 u v w uv vw I1 Ide_in_Hom Nml_HcompNml Ide_in_Hom
	+ by (cases w, simp_all)
	+ moreover have "Cod ((u \<^bold>\<star> v) \<^bold>\<Down> w) = \<^bold>\<lfloor>(u \<^bold>\<star> v) \<^bold>\<star> w\<^bold>\<rfloor>"
	+ using 1 2 3 4 uv
	+ using Nmlize_Nml apply (cases w, simp_all)
	+ by (metis Nmlize.simps(3) Nmlize_Nml HcompNml.simps(3))
	+ ultimately show ?thesis using w Can_implies_Arr by (simp add: 1 uv)
	+ qed
	+ moreover have "\<not> is_Prim\<^sub>0 w \<Longrightarrow> ?thesis"
	+ proof -
	+ assume 1: "\<not> is_Prim\<^sub>0 w"
	+ have 2: "(u \<^bold>\<star> v) \<^bold>\<Down> w = (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) \<^bold>\<cdot> (u \<^bold>\<star> v \<^bold>\<Down> w) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[u, v, w\<^bold>]"
	+ using 1 u v uv w by (cases w; simp)
	+ have 3: "Can (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) \<and> Dom (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor> \<and>
	+ Cod (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = \<^bold>\<lfloor>u \<^bold>\<star> (v \<^bold>\<star> w)\<^bold>\<rfloor>"
	+ proof -
	+ have "Can (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) \<and> Dom (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor> \<and>
	+ Cod (u \<^bold>\<Down> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>) = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>"
	+ using w uv Ide_HcompNml Nml_HcompNml(1)
	+ apply (cases u, simp_all)
	+ using u v vw I1 Nmlize_in_Hom(1) [of "v \<^bold>\<star> w"] Nml_Nmlize Ide_Nmlize_Ide
	+ by simp
	+ moreover have "u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor> = \<^bold>\<lfloor>u \<^bold>\<star> (v \<^bold>\<star> w)\<^bold>\<rfloor>"
	+ using uv u w Nmlize_Hcomp Nmlize_Nmlize Nml_implies_Arr by simp
	+ ultimately show ?thesis by presburger
	+ qed
	+ have 4: "Can (v \<^bold>\<Down> w) \<and> Dom (v \<^bold>\<Down> w) = v \<^bold>\<star> w \<and> Cod (v \<^bold>\<Down> w) = \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>"
	+ using v w vw 1 2 I2 by simp
	+ hence 5: "Src (v \<^bold>\<Down> w) = Src w \<and> Trg (v \<^bold>\<Down> w) = Trg v"
	+ using Src_Dom Trg_Dom Can_implies_Arr by fastforce
	+ have "Can (u \<^bold>\<star> (v \<^bold>\<Down> w)) \<and> Dom (u \<^bold>\<star> (v \<^bold>\<Down> w)) = u \<^bold>\<star> (v \<^bold>\<star> w) \<and>
	+ Cod (u \<^bold>\<star> (v \<^bold>\<Down> w)) = u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>"
	+ using u uv vw 4 5 Ide_implies_Can Ide_in_Hom by simp
	+ moreover have "\<^bold>\<lfloor>u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
	+ proof -
	+ have "\<^bold>\<lfloor>u \<^bold>\<star> \<^bold>\<lfloor>v \<^bold>\<star> w\<^bold>\<rfloor>\<^bold>\<rfloor> = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w)"
	+ using u v w 4
	+ by (metis Ide_Dom Can_implies_Arr Ide_implies_Arr
	+ Nml_Nmlize(1) Nmlize.simps(3) Nmlize_Nml)
	+ also have "... = (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w"
	+ using u v w uv vw HcompNml_assoc by metis
	+ also have "... = \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
	+ using u v w by (metis Nmlize.simps(3) Nmlize_Nml)
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "Can \<^bold>\<a>\<^bold>[u, v, w\<^bold>] \<and> Dom \<^bold>\<a>\<^bold>[u, v, w\<^bold>] = (u \<^bold>\<star> v) \<^bold>\<star> w \<and>
	+ Cod \<^bold>\<a>\<^bold>[u, v, w\<^bold>] = u \<^bold>\<star> (v \<^bold>\<star> w)"
	+ using uv vw w Ide_implies_Can Ide_in_Hom by auto
	+ ultimately show ?thesis
	+ using uv w 2 3 4 Nml_implies_Arr Nmlize_Nmlize Ide_implies_Can
	+ Nmlize_Nml Ide_Dom Can_implies_Arr
	+ by (metis Can.simps(4) Cod.simps(4) Dom.simps(4) Nmlize.simps(3))
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ show "Can (a \<^bold>\<Down> b)" using assms 0 by blast
	+ show "a \<^bold>\<Down> b \<in> VHom (a \<^bold>\<star> b) \<^bold>\<lfloor>a \<^bold>\<star> b\<^bold>\<rfloor>" using 0 assms by blast
	+ qed
	+
	+ lemma red2_in_Hom [intro]:
	+ assumes "Ide u" and "Nml u" and "Ide v" and "Nml v" and "Src u = Trg v"
	+ shows "u \<^bold>\<Down> v \<in> HHom (Src v) (Trg u)" and "u \<^bold>\<Down> v \<in> VHom (u \<^bold>\<star> v) \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>"
	+ proof -
	+ show 1: "u \<^bold>\<Down> v \<in> VHom (u \<^bold>\<star> v) \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>"
	+ using assms Can_red2 Can_implies_Arr by simp
	+ show "u \<^bold>\<Down> v \<in> HHom (Src v) (Trg u)"
	+ using assms 1 Src_Dom [of "u \<^bold>\<Down> v"] Trg_Dom [of "u \<^bold>\<Down> v"] Can_red2 Can_implies_Arr by simp
	+ qed
	+
	+ lemma red2_simps [simp]:
	+ assumes "Ide u" and "Nml u" and "Ide v" and "Nml v" and "Src u = Trg v"
	+ shows "Src (u \<^bold>\<Down> v) = Src v" and "Trg (u \<^bold>\<Down> v) = Trg u"
	+ and "Dom (u \<^bold>\<Down> v) = u \<^bold>\<star> v" and "Cod (u \<^bold>\<Down> v) = \<^bold>\<lfloor>u \<^bold>\<star> v\<^bold>\<rfloor>"
	+ using assms red2_in_Hom by auto
	+
	+ lemma Can_red:
	+ assumes "Ide u"
	+ shows "Can (u\<^bold>\<down>)" and "u\<^bold>\<down> \<in> VHom u \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ proof -
	+ have 0: "Ide u \<Longrightarrow> Can (u\<^bold>\<down>) \<and> u\<^bold>\<down> \<in> VHom u \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ proof (induct u, simp_all add: Dom_Ide Cod_Ide)
	+ fix v w
	+ assume v: "Can (v\<^bold>\<down>) \<and> Arr (v\<^bold>\<down>) \<and> Dom (v\<^bold>\<down>) = v \<and> Cod (v\<^bold>\<down>) = \<^bold>\<lfloor>v\<^bold>\<rfloor>"
	+ assume w: "Can (w\<^bold>\<down>) \<and> Arr (w\<^bold>\<down>) \<and> Dom (w\<^bold>\<down>) = w \<and> Cod (w\<^bold>\<down>) = \<^bold>\<lfloor>w\<^bold>\<rfloor>"
	+ assume vw: "Ide v \<and> Ide w \<and> Src v = Trg w"
	+ show "(Nml (v \<^bold>\<star> w) \<longrightarrow>
	+ Can v \<and> Can w \<and> v \<^bold>\<star> w = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and>
	+ (\<not> Nml (v \<^bold>\<star> w) \<longrightarrow>
	+ Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
	+ Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
	+ Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
	+ proof
	+ show "Nml (v \<^bold>\<star> w) \<longrightarrow>
	+ Can v \<and> Can w \<and> v \<^bold>\<star> w = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
	+ using vw Nml_HcompD Ide_implies_Can Dom_Inv VcompNml_Ide_Nml Inv_Ide
	+ Nmlize.simps(3) Nmlize_Nml
	+ by metis
	+ show "\<not> Nml (v \<^bold>\<star> w) \<longrightarrow>
	+ Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
	+ Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
	+ Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
	+ proof
	+ assume 1: "\<not> Nml (v \<^bold>\<star> w)"
	+ have "Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
	+ using v w vw Can_red2 Nml_Nmlize Ide_Nmlize_Ide Nml_HcompNml Ide_HcompNml
	+ by simp
	+ moreover have "Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>)"
	+ using v w vw Src_Dom Trg_Dom by metis
	+ moreover have "Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
	+ using v w vw Can_red2 Nml_Nmlize Ide_Nmlize_Ide by simp
	+ ultimately show "Can (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and> Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and>
	+ Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) \<and>
	+ Src (v\<^bold>\<down>) = Trg (w\<^bold>\<down>) \<and> Dom (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>w\<^bold>\<rfloor> \<and>
	+ Cod (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>w\<^bold>\<rfloor>) = \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>"
	+ using Can_implies_Arr by blast
	+ qed
	+ qed
	+ qed
	+ show "Can (u\<^bold>\<down>)" using assms 0 by blast
	+ show "u\<^bold>\<down> \<in> VHom u \<^bold>\<lfloor>u\<^bold>\<rfloor>" using assms 0 by blast
	+ qed
	+
	+ lemma red_in_Hom [intro]:
	+ assumes "Ide t"
	+ shows "t\<^bold>\<down> \<in> HHom (Src t) (Trg t)" and "t\<^bold>\<down> \<in> VHom t \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ proof -
	+ show 1: "t\<^bold>\<down> \<in> VHom t \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms Can_red Can_implies_Arr by simp
	+ show "t\<^bold>\<down> \<in> HHom (Src t) (Trg t)"
	+ using assms 1 Src_Dom [of "t\<^bold>\<down>"] Trg_Dom [of "t\<^bold>\<down>"] Can_red Can_implies_Arr by simp
	+ qed
	+
	+ lemma red_simps [simp]:
	+ assumes "Ide t"
	+ shows "Src (t\<^bold>\<down>) = Src t" and "Trg (t\<^bold>\<down>) = Trg t"
	+ and "Dom (t\<^bold>\<down>) = t" and "Cod (t\<^bold>\<down>) = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms red_in_Hom by auto
	+
	+ lemma red_Src:
	+ assumes "Ide t"
	+ shows "Src t\<^bold>\<down> = Src t"
	+ using assms is_Prim0_Src [of t]
	+ by (cases "Src t", simp_all)
	+
	+ lemma red_Trg:
	+ assumes "Ide t"
	+ shows "Trg t\<^bold>\<down> = Trg t"
	+ using assms is_Prim0_Trg [of t]
	+ by (cases "Trg t", simp_all)
	+
	+ lemma Nmlize_red [simp]:
	+ assumes "Ide t"
	+ shows "\<^bold>\<lfloor>t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using assms Can_red Ide_Nmlize_Can Nmlize_in_Hom Ide_in_Hom by fastforce
	+
	+ lemma Nmlize_red2 [simp]:
	+ assumes "Ide t" and "Ide u" and "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "\<^bold>\<lfloor>t \<^bold>\<Down> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t \<^bold>\<star> u\<^bold>\<rfloor>"
	+ using assms Can_red2 Ide_Nmlize_Can Nmlize_in_Hom [of "t \<^bold>\<Down> u"] red2_in_Hom Ide_in_Hom
	+ by simp
	+
	+ end
	+
	+ subsection "Evaluation"
	+
	+ text \<open>
	+ The following locale is concerned with the evaluation of terms of the bicategorical
	+ language determined by \<open>C\<close>, \<open>src\<^sub>C\<close>, and \<open>trg\<^sub>C\<close> in a bicategory \<open>(V, H, \<a>, \<i>, src, trg)\<close>,
	+ given a source and target-preserving functor from \<open>C\<close> to \<open>V\<close>.
	+ \<close>
	+
	+ locale evaluation_map =
	+ C: horizontal_homs C src\<^sub>C trg\<^sub>C +
	+ bicategorical_language C src\<^sub>C trg\<^sub>C +
	+ bicategory V H \<a> \<i> src trg +
	+ E: "functor" C V E
	+ for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
	+ and src\<^sub>C :: "'c \<Rightarrow> 'c"
	+ and trg\<^sub>C :: "'c \<Rightarrow> 'c"
	+ and V :: "'b comp" (infixr "\<cdot>" 55)
	+ and H :: "'b comp" (infixr "\<star>" 53)
	+ and \<a> :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b" ("\<a>[_, _, _]")
	+ and \<i> :: "'b \<Rightarrow> 'b" ("\<i>[_]")
	+ and src :: "'b \<Rightarrow> 'b"
	+ and trg :: "'b \<Rightarrow> 'b"
	+ and E :: "'c \<Rightarrow> 'b" +
	+ assumes preserves_src: "E (src\<^sub>C x) = src (E x)"
	+ and preserves_trg: "E (trg\<^sub>C x) = trg (E x)"
	+ begin
	+
	+ (* TODO: Figure out why this notation has to be reinstated. *)
	+ notation Nmlize ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
	+ notation HcompNml (infixr "\<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor>" 53)
	+ notation VcompNml (infixr "\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>" 55)
	+ notation red ("_\<^bold>\<down>" [56] 56)
	+ notation red2 (infixr "\<^bold>\<Down>" 53)
	+
	+ primrec eval :: "'c term \<Rightarrow> 'b" ("\<lbrace>_\<rbrace>")
	+ where "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle>\<^sub>0\<rbrace> = E f"
	+ \| "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle>\<rbrace> = E f"
	+ \| "\<lbrace>t \<^bold>\<star> u\<rbrace> = \<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>"
	+ \| "\<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
	+ \| "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<ll> \<lbrace>t\<rbrace>"
	+ \| "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<ll>'.map \<lbrace>t\<rbrace>"
	+ \| "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<rr> \<lbrace>t\<rbrace>"
	+ \| "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<rr>'.map \<lbrace>t\<rbrace>"
	+ \| "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
	+ \| "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
	+
	+ lemma preserves_obj:
	+ assumes "C.obj a"
	+ shows "obj (E a)"
	+ proof (unfold obj_def)
	+ show "arr (E a) \<and> src (E a) = E a"
	+ proof
	+ show "arr (E a)" using assms C.obj_def by simp
	+ have "src (E a) = E (src\<^sub>C a)"
	+ using assms preserves_src by metis
	+ also have "... = E a"
	+ using assms C.obj_def by simp
	+ finally show "src (E a) = E a" by simp
	+ qed
	+ qed
	+
	+ lemma eval_in_hom':
	+ shows "Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ proof (induct t)
	+ show "\<And>x. Arr \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 \<Longrightarrow>
	+ \<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> : \<lbrace>Src \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> : \<lbrace>Dom \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace>\<guillemotright>"
	+ apply (simp add: preserves_src preserves_trg)
	+ using preserves_src preserves_trg C.objE
	+ by (metis (full_types) C.obj_def' E.preserves_arr E.preserves_ide in_hhom_def
	+ ide_in_hom(2))
	+ show "\<And>x. Arr \<^bold>\<langle>x\<^bold>\<rangle> \<Longrightarrow>
	+ \<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> : \<lbrace>Src \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> : \<lbrace>Dom \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>\<guillemotright>"
	+ by (auto simp add: preserves_src preserves_trg)
	+ show "\<And>t1 t2.
	+ (Arr t1 \<Longrightarrow> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Src t1\<rbrace> \<rightarrow> \<lbrace>Trg t1\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Dom t1\<rbrace> \<Rightarrow> \<lbrace>Cod t1\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ (Arr t2 \<Longrightarrow> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Src t2\<rbrace> \<rightarrow> \<lbrace>Trg t2\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Dom t2\<rbrace> \<Rightarrow> \<lbrace>Cod t2\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ Arr (t1 \<^bold>\<star> t2) \<Longrightarrow>
	+ \<guillemotleft>\<lbrace>t1 \<^bold>\<star> t2\<rbrace> : \<lbrace>Src (t1 \<^bold>\<star> t2)\<rbrace> \<rightarrow> \<lbrace>Trg (t1 \<^bold>\<star> t2)\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>\<lbrace>t1 \<^bold>\<star> t2\<rbrace> : \<lbrace>Dom (t1 \<^bold>\<star> t2)\<rbrace> \<Rightarrow> \<lbrace>Cod (t1 \<^bold>\<star> t2)\<rbrace>\<guillemotright>"
	+ using hcomp_in_hhom in_hhom_def vconn_implies_hpar(1) vconn_implies_hpar(2) by auto
	+ show "\<And>t1 t2.
	+ (Arr t1 \<Longrightarrow> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Src t1\<rbrace> \<rightarrow> \<lbrace>Trg t1\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t1\<rbrace> : \<lbrace>Dom t1\<rbrace> \<Rightarrow> \<lbrace>Cod t1\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ (Arr t2 \<Longrightarrow> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Src t2\<rbrace> \<rightarrow> \<lbrace>Trg t2\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t2\<rbrace> : \<lbrace>Dom t2\<rbrace> \<Rightarrow> \<lbrace>Cod t2\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ Arr (t1 \<^bold>\<cdot> t2) \<Longrightarrow>
	+ \<guillemotleft>\<lbrace>t1 \<^bold>\<cdot> t2\<rbrace> : \<lbrace>Src (t1 \<^bold>\<cdot> t2)\<rbrace> \<rightarrow> \<lbrace>Trg (t1 \<^bold>\<cdot> t2)\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>\<lbrace>t1 \<^bold>\<cdot> t2\<rbrace> : \<lbrace>Dom (t1 \<^bold>\<cdot> t2)\<rbrace> \<Rightarrow> \<lbrace>Cod (t1 \<^bold>\<cdot> t2)\<rbrace>\<guillemotright>"
	+ using VSeq_implies_HPar seqI' by auto
	+ show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ Arr \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow>
	+ \<guillemotleft>\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
	+ proof (simp add: preserves_src preserves_trg)
	+ fix t
	+ assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ assume 1: "Arr t"
	+ show "\<guillemotleft>\<ll> \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<ll> \<lbrace>t\<rbrace> : \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ proof -
	+ have "src (\<ll> \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
	+ using t 1
	+ by (metis (no_types, lifting) \<ll>.preserves_cod \<ll>.preserves_reflects_arr arr_cod
	+ in_hhomE map_simp src_cod)
	+ moreover have "trg (\<ll> \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
	+ using t 1
	+ by (metis (no_types, lifting) \<ll>.preserves_cod \<ll>.preserves_reflects_arr arr_cod
	+ in_hhomE map_simp trg_cod)
	+ moreover have "\<guillemotleft>\<ll> \<lbrace>t\<rbrace> : \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ using t 1
	+ apply (elim conjE in_hhomE)
	+ by (intro in_homI, auto)
	+ ultimately show ?thesis by auto
	+ qed
	+ qed
	+ show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow>
	+ \<guillemotleft>\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
	+ proof (simp add: preserves_src preserves_trg)
	+ fix t
	+ assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ assume 1: "Arr t"
	+ show "\<guillemotleft>\<ll>'.map \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>\<ll>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ proof -
	+ have "src (\<ll>'.map \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
	+ using t 1 \<ll>'.preserves_dom arr_dom map_simp \<ll>'.preserves_reflects_arr src_dom
	+ by (metis (no_types, lifting) in_hhomE)
	+ moreover have "trg (\<ll>'.map \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
	+ using t 1 \<ll>'.preserves_dom arr_dom map_simp \<ll>'.preserves_reflects_arr trg_dom
	+ by (metis (no_types, lifting) in_hhomE)
	+ moreover have "\<guillemotleft>\<ll>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Trg t\<rbrace> \<star> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ using t 1 \<ll>'.preserves_hom
	+ apply (intro in_homI)
	+ apply auto[1]
	+ apply fastforce
	+ by fastforce
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ Arr \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow>
	+ \<guillemotleft>\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
	+ proof (simp add: preserves_src preserves_trg)
	+ fix t
	+ assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ assume 1: "Arr t"
	+ show "\<guillemotleft>\<rr> \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<rr> \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<star> \<lbrace>Src t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ proof -
	+ have "src (\<rr> \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
	+ using t 1 \<rr>.preserves_cod arr_cod map_simp \<rr>.preserves_reflects_arr src_cod
	+ by (metis (no_types, lifting) in_hhomE)
	+ moreover have "trg (\<rr> \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
	+ using t 1 \<rr>.preserves_cod arr_cod map_simp \<rr>.preserves_reflects_arr trg_cod
	+ by (metis (no_types, lifting) in_hhomE)
	+ moreover have "\<guillemotleft>\<rr> \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<star> \<lbrace>Src t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ using t 1 by force
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ show "\<And>t. (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow>
	+ \<guillemotleft>\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
	+ proof (simp add: preserves_src preserves_trg)
	+ fix t
	+ assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ assume 1: "Arr t"
	+ show "\<guillemotleft>\<rr>'.map \<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>\<rr>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Src t\<rbrace>\<guillemotright>"
	+ proof -
	+ have "src (\<rr>'.map \<lbrace>t\<rbrace>) = \<lbrace>Src t\<rbrace>"
	+ using t 1 \<rr>'.preserves_dom arr_dom map_simp \<rr>'.preserves_reflects_arr src_dom
	+ by (metis (no_types, lifting) in_hhomE)
	+ moreover have "trg (\<rr>'.map \<lbrace>t\<rbrace>) = \<lbrace>Trg t\<rbrace>"
	+ using t 1 \<rr>'.preserves_dom arr_dom map_simp \<rr>'.preserves_reflects_arr trg_dom
	+ by (metis (no_types, lifting) in_hhomE)
	+ moreover have "\<guillemotleft>\<rr>'.map \<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Src t\<rbrace>\<guillemotright>"
	+ using t 1 src_cod arr_cod \<rr>'.preserves_hom [of "\<lbrace>t\<rbrace>" "\<lbrace>Dom t\<rbrace>" "\<lbrace>Cod t\<rbrace>"]
	+ apply (elim conjE in_hhomE)
	+ by (intro in_homI, auto)
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ show "\<And>t u v.
	+ (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ (Arr u \<Longrightarrow> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Src u\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ (Arr v \<Longrightarrow> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow>
	+ \<guillemotleft>\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
	+ proof (simp add: preserves_src preserves_trg)
	+ fix t u v
	+ assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Trg u\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ assume u: "\<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Trg v\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>"
	+ assume v: "\<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>"
	+ assume tuv: "Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v"
	+ show "\<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
	+ (\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace> \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
	+ proof -
	+ have 1: "VVV.in_hom (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)
	+ (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>) (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
	+ using t u v tuv VVV.hom_char by fastforce
	+ have 4: "VVV.arr (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
	+ using 1 VVV.ide_dom apply (elim VVV.in_homE) by force
	+ have 5: "VVV.arr (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
	+ using 1 VVV.ide_cod apply (elim VVV.in_homE) by force
	+ have 2: "\<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
	+ (\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace> \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
	+ using 1 4 5 HoHV_def HoVH_def \<alpha>_def
	+ \<alpha>.preserves_hom [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" "(\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
	+ "(\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"]
	+ by simp
	+ have 3: "\<guillemotleft>\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright>"
	+ proof
	+ show "arr (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>))"
	+ using 2 by auto
	+ show "src (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Src v\<rbrace>"
	+ proof -
	+ have "src (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = src ((\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace>)"
	+ using 2 src_dom [of "\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by fastforce
	+ also have "... = src \<lbrace>Dom v\<rbrace>"
	+ using 4 VVV.arr_char VV.arr_char hseqI' by simp
	+ also have "... = src (dom \<lbrace>v\<rbrace>)"
	+ using v by auto
	+ also have "... = \<lbrace>Src v\<rbrace>"
	+ using v by auto
	+ finally show ?thesis by auto
	+ qed
	+ show "trg (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Trg t\<rbrace>"
	+ proof -
	+ have "trg (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = trg ((\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace>) \<star> \<lbrace>Dom v\<rbrace>)"
	+ using 2 trg_dom [of "\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by fastforce
	+ also have "... = trg \<lbrace>Dom t\<rbrace>"
	+ using 4 VVV.arr_char VV.arr_char hseqI' by simp
	+ also have "... = trg (dom \<lbrace>t\<rbrace>)"
	+ using t by auto
	+ also have "... = \<lbrace>Trg t\<rbrace>"
	+ using t by auto
	+ finally show ?thesis by auto
	+ qed
	+ qed
	+ show ?thesis using 2 3 by simp
	+ qed
	+ qed
	+ show "\<And>t u v.
	+ (Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ (Arr u \<Longrightarrow> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Src u\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ (Arr v \<Longrightarrow> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>) \<Longrightarrow>
	+ Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow>
	+ \<guillemotleft>\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Src \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Trg \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> \<Rightarrow> \<lbrace>Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
	+ proof (simp add: preserves_src preserves_trg)
	+ fix t u v
	+ assume t: "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Trg u\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ assume u: "\<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Trg v\<rbrace> \<rightarrow> \<lbrace>Trg u\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<Rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>"
	+ assume v: "\<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg v\<rbrace>\<guillemotright> \<and> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<Rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>"
	+ assume tuv: "Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v"
	+ show "\<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
	+ \<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> (\<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace>) \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
	+ proof -
	+ have 1: "VVV.in_hom (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)
	+ (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>) (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
	+ using t u v tuv VVV.hom_char VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char
	+ apply (elim conjE in_hhomE in_homE)
	+ apply (intro VVV.in_homI)
	+ by simp_all
	+ have 4: "VVV.arr (\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
	+ using "1" VVV.in_hom_char by blast
	+ have 5: "VVV.arr (\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"
	+ using "1" VVV.in_hom_char by blast
	+ have 2: "\<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) :
	+ \<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace> \<Rightarrow> (\<lbrace>Cod t\<rbrace> \<star> \<lbrace>Cod u\<rbrace>) \<star> \<lbrace>Cod v\<rbrace>\<guillemotright>"
	+ using 1 4 5 HoHV_def HoVH_def \<alpha>'.map_def
	+ \<alpha>'.preserves_hom [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" "(\<lbrace>Dom t\<rbrace>, \<lbrace>Dom u\<rbrace>, \<lbrace>Dom v\<rbrace>)"
	+ "(\<lbrace>Cod t\<rbrace>, \<lbrace>Cod u\<rbrace>, \<lbrace>Cod v\<rbrace>)"]
	+ by simp
	+ have 3: "\<guillemotleft>\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>) : \<lbrace>Src v\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright>"
	+ proof
	+ show "arr (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>))"
	+ using 2 by auto
	+ show "src (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Src v\<rbrace>"
	+ proof -
	+ have "src (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = src (\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace>)"
	+ using 2 src_dom [of "\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by auto
	+ also have "... = src \<lbrace>Dom v\<rbrace>"
	+ using 4 VVV.arr_char VV.arr_char hseqI' by simp
	+ also have "... = src (dom \<lbrace>v\<rbrace>)"
	+ using v by auto
	+ also have "... = \<lbrace>Src v\<rbrace>"
	+ using v by auto
	+ finally show ?thesis by auto
	+ qed
	+ show "trg (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = \<lbrace>Trg t\<rbrace>"
	+ proof -
	+ have "trg (\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) = trg (\<lbrace>Dom t\<rbrace> \<star> \<lbrace>Dom u\<rbrace> \<star> \<lbrace>Dom v\<rbrace>)"
	+ using 2 trg_dom [of "\<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by auto
	+ also have "... = trg \<lbrace>Dom t\<rbrace>"
	+ using 4 VVV.arr_char VV.arr_char hseqI' by simp
	+ also have "... = trg (dom \<lbrace>t\<rbrace>)"
	+ using t by auto
	+ also have "... = \<lbrace>Trg t\<rbrace>"
	+ using t by auto
	+ finally show ?thesis by auto
	+ qed
	+ qed
	+ show ?thesis using 2 3 by simp
	+ qed
	+ qed
	+ qed
	+
	+ lemma eval_in_hom [intro]:
	+ assumes "Arr t"
	+ shows "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Src t\<rbrace> \<rightarrow> \<lbrace>Trg t\<rbrace>\<guillemotright>" and "\<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<Rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
	+ using assms eval_in_hom' by simp_all
	+
	+ (*
	+ * TODO: It seems to me that the natural useful orientation of these facts is syntax
	+ * to semantics. However, having this as the default makes it impossible to do various
	+ * proofs by simp alone. This has to be sorted out. For right now, I am going to include
	+ * both versions, which will have to be explicitly invoked where needed.
	+ *)
	+ lemma eval_simps:
	+ assumes "Arr f"
	+ shows "arr \<lbrace>f\<rbrace>" and "\<lbrace>Src f\<rbrace> = src \<lbrace>f\<rbrace>" and "\<lbrace>Trg f\<rbrace> = trg \<lbrace>f\<rbrace>"
	+ and "\<lbrace>Dom f\<rbrace> = dom \<lbrace>f\<rbrace>" and "\<lbrace>Cod f\<rbrace> = cod \<lbrace>f\<rbrace>"
	+ using assms eval_in_hom [of f] by auto
	+
	+ lemma eval_simps':
	+ assumes "Arr f"
	+ shows "arr \<lbrace>f\<rbrace>" and "src \<lbrace>f\<rbrace> = \<lbrace>Src f\<rbrace>" and "trg \<lbrace>f\<rbrace> = \<lbrace>Trg f\<rbrace>"
	+ and "dom \<lbrace>f\<rbrace> = \<lbrace>Dom f\<rbrace>" and "cod \<lbrace>f\<rbrace> = \<lbrace>Cod f\<rbrace>"
	+ using assms eval_in_hom by auto
	+
	+ lemma obj_eval_Obj:
	+ shows "Obj t \<Longrightarrow> obj \<lbrace>t\<rbrace>"
	+ apply (induct t)
	+ using obj_def C.obj_def preserves_src apply auto
	+ by metis
	+
	+ lemma ide_eval_Ide:
	+ shows "Ide t \<Longrightarrow> ide \<lbrace>t\<rbrace>"
	+ by (induct t, auto simp add: eval_simps')
	+
	+ lemma arr_eval_Arr [simp]:
	+ assumes "Arr t"
	+ shows "arr \<lbrace>t\<rbrace>"
	+ using assms by (simp add: eval_simps')
	+
	+ (*
	+ * TODO: The next few results want eval_simps oriented from syntax to semantics.
	+ *)
	+
	+ lemma eval_Lunit [simp]:
	+ assumes "Arr t"
	+ shows "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>Cod t\<rbrace>] \<cdot> (trg \<lbrace>t\<rbrace> \<star> \<lbrace>t\<rbrace>)"
	+ using assms \<ll>.is_natural_2 \<ll>_ide_simp by (simp add: eval_simps)
	+
	+ lemma eval_Lunit' [simp]:
	+ assumes "Arr t"
	+ shows "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<l>\<^sup>-\<^sup>1[\<lbrace>Cod t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>"
	+ using assms \<ll>'.is_natural_2 \<ll>_ide_simp by (simp add: eval_simps)
	+
	+ lemma eval_Runit [simp]:
	+ assumes "Arr t"
	+ shows "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>Cod t\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<star> src \<lbrace>t\<rbrace>)"
	+ using assms \<rr>.is_natural_2 \<rr>_ide_simp by (simp add: eval_simps)
	+
	+ lemma eval_Runit' [simp]:
	+ assumes "Arr t"
	+ shows "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<r>\<^sup>-\<^sup>1[\<lbrace>Cod t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>"
	+ using assms \<rr>'.is_natural_2 \<rr>_ide_simp by (simp add: eval_simps)
	+
	+ lemma eval_Assoc [simp]:
	+ assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
	+ shows "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>) \<cdot> ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>)"
	+ proof -
	+ have "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" by simp
	+ also have "... = \<alpha> (VVV.cod (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) \<cdot> HoHV (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
	+ using assms \<alpha>.is_natural_2 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] VVV.arr_char VVV.cod_char
	+ \<alpha>.is_extensional \<alpha>_def
	+ by auto
	+ also have "... = \<alpha> (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>) \<cdot> ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>)"
	+ unfolding HoHV_def \<alpha>_def
	+ using assms VVV.arr_char VV.arr_char VVV.cod_char \<alpha>.is_extensional
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma eval_Assoc' [simp]:
	+ assumes "Arr t" and "Arr u" and "Arr v" and "Src t = Trg u" and "Src u = Trg v"
	+ shows "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>)"
	+ proof -
	+ have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha>'.map (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)" by simp
	+ also have "... = \<alpha>'.map (VVV.cod (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)) \<cdot> HoVH (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
	+ using assms \<alpha>'.is_natural_2 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] VVV.arr_char VVV.cod_char
	+ \<alpha>'.is_extensional
	+ by simp
	+ also have "... = \<alpha>'.map (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>) \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>)"
	+ unfolding HoVH_def
	+ using assms VVV.arr_char VV.arr_char VVV.cod_char \<alpha>'.is_extensional
	+ apply simp
	+ by (metis (no_types, lifting) comp_null(2) hseq_char hseq_char' hcomp_simps(2))
	+ finally show ?thesis
	+ using \<a>'_def by simp
	+ qed
	+
	+ lemma eval_Lunit_Ide [simp]:
	+ assumes "Ide t"
	+ shows "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>t\<rbrace>]"
	+ using assms \<ll>_ide_simp ide_eval_Ide by simp
	+
	+ lemma eval_Lunit'_Ide [simp]:
	+ assumes "Ide t"
	+ shows "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<l>\<^sup>-\<^sup>1[\<lbrace>t\<rbrace>]"
	+ using assms \<ll>_ide_simp ide_eval_Ide by simp
	+
	+ lemma eval_Runit_Ide [simp]:
	+ assumes "Ide t"
	+ shows "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>t\<rbrace>]"
	+ using assms \<rr>_ide_simp ide_eval_Ide by simp
	+
	+ lemma eval_Runit'_Ide [simp]:
	+ assumes "Ide t"
	+ shows "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<r>\<^sup>-\<^sup>1[\<lbrace>t\<rbrace>]"
	+ using assms \<rr>_ide_simp ide_eval_Ide by simp
	+
	+ lemma eval_Assoc_Ide [simp]:
	+ assumes "Ide t" and "Ide u" and "Ide v" and "Src t = Trg u" and "Src u = Trg v"
	+ shows "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
	+ using assms by simp
	+
	+ lemma eval_Assoc'_Ide [simp]:
	+ assumes "Ide t" and "Ide u" and "Ide v" and "Src t = Trg u" and "Src u = Trg v"
	+ shows "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<a>\<^sup>-\<^sup>1[\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>]"
	+ using assms \<a>'_def by simp
	+
	+ lemma iso_eval_Can:
	+ shows "Can t \<Longrightarrow> iso \<lbrace>t\<rbrace>"
	+ proof (induct t; simp add: fsts.intros snds.intros)
	+ show "\<And>x. C.obj x \<Longrightarrow> iso (E x)" by auto
	+ show "\<And>t1 t2. \<lbrakk> iso \<lbrace>t1\<rbrace>; iso \<lbrace>t2\<rbrace>; Can t1 \<and> Can t2 \<and> Src t1 = Trg t2 \<rbrakk> \<Longrightarrow>
	+ iso (\<lbrace>t1\<rbrace> \<star> \<lbrace>t2\<rbrace>)"
	+ using Can_implies_Arr by (simp add: eval_simps')
	+ show "\<And>t1 t2. \<lbrakk> iso \<lbrace>t1\<rbrace>; iso \<lbrace>t2\<rbrace>; Can t1 \<and> Can t2 \<and> Dom t1 = Cod t2 \<rbrakk> \<Longrightarrow>
	+ iso (\<lbrace>t1\<rbrace> \<cdot> \<lbrace>t2\<rbrace>)"
	+ using Can_implies_Arr isos_compose by (simp add: eval_simps')
	+ show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<ll> \<lbrace>t\<rbrace>)"
	+ using \<ll>.preserves_iso by auto
	+ show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<ll>'.map \<lbrace>t\<rbrace>)"
	+ using \<ll>'.preserves_iso by simp
	+ show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<rr> \<lbrace>t\<rbrace>)"
	+ using \<rr>.preserves_iso by auto
	+ show "\<And>t. \<lbrakk> iso \<lbrace>t\<rbrace>; Can t \<rbrakk> \<Longrightarrow> iso (\<rr>'.map \<lbrace>t\<rbrace>)"
	+ using \<rr>'.preserves_iso by simp
	+ fix t1 t2 t3
	+ assume t1: "iso \<lbrace>t1\<rbrace>" and t2: "iso \<lbrace>t2\<rbrace>" and t3: "iso \<lbrace>t3\<rbrace>"
	+ assume 1: "Can t1 \<and> Can t2 \<and> Can t3 \<and> Src t1 = Trg t2 \<and> Src t2 = Trg t3"
	+ have 2: "VVV.iso (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>)"
	+ proof -
	+ have 3: "VxVxV.iso (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>)"
	+ using t1 t2 t3 Can_implies_Arr VxVxV.iso_char VxV.iso_char by simp
	+ moreover have "VVV.arr (VxVxV.inv (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>))"
	+ proof -
	+ have "VxVxV.inv (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>) = (inv \<lbrace>t1\<rbrace>, inv \<lbrace>t2\<rbrace>, inv \<lbrace>t3\<rbrace>)"
	+ using t1 t2 t3 3 by simp
	+ thus ?thesis
	+ using t1 t2 t3 1 Can_implies_Arr VVV.arr_char VV.arr_char
	+ by (simp add: eval_simps')
	+ qed
	+ ultimately show ?thesis
	+ using t1 t2 t3 1 Can_implies_Arr VVV.iso_char VVV.arr_char
	+ by (auto simp add: eval_simps')
	+ qed
	+ show "iso (\<alpha> (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>))"
	+ using 2 \<alpha>_def \<alpha>.preserves_iso by auto
	+ show "iso (\<alpha>'.map (\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>))"
	+ using 2 \<alpha>'.preserves_iso by simp
	+ qed
	+
	+ lemma eval_Inv_Can:
	+ shows "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
	+ proof (induct t)
	+ show "\<And>x. Can \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> \<lbrace>Inv \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace> = inv \<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0\<rbrace>" by auto
	+ show "\<And>x. Can \<^bold>\<langle>x\<^bold>\<rangle> \<Longrightarrow> \<lbrace>Inv \<^bold>\<langle>x\<^bold>\<rangle>\<rbrace> = inv \<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>" by simp
	+ show "\<And>t1 t2. (Can t1 \<Longrightarrow> \<lbrace>Inv t1\<rbrace> = inv \<lbrace>t1\<rbrace>) \<Longrightarrow>
	+ (Can t2 \<Longrightarrow> \<lbrace>Inv t2\<rbrace> = inv \<lbrace>t2\<rbrace>) \<Longrightarrow>
	+ Can (t1 \<^bold>\<star> t2) \<Longrightarrow> \<lbrace>Inv (t1 \<^bold>\<star> t2)\<rbrace> = inv \<lbrace>t1 \<^bold>\<star> t2\<rbrace>"
	+ using iso_eval_Can Can_implies_Arr
	+ by (simp add: eval_simps')
	+ show "\<And>t1 t2. (Can t1 \<Longrightarrow> \<lbrace>Inv t1\<rbrace> = inv \<lbrace>t1\<rbrace>) \<Longrightarrow>
	+ (Can t2 \<Longrightarrow> \<lbrace>Inv t2\<rbrace> = inv \<lbrace>t2\<rbrace>) \<Longrightarrow>
	+ Can (t1 \<^bold>\<cdot> t2) \<Longrightarrow> \<lbrace>Inv (t1 \<^bold>\<cdot> t2)\<rbrace> = inv \<lbrace>t1 \<^bold>\<cdot> t2\<rbrace>"
	+ using iso_eval_Can inv_comp Can_implies_Arr
	+ by (simp add: eval_simps')
	+ fix t
	+ assume I: "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
	+ show "Can \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
	+ proof -
	+ assume t: "Can \<^bold>\<l>\<^bold>[t\<^bold>]"
	+ have "\<lbrace>Inv \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]\<rbrace>" by simp
	+ also have "... = \<ll>'.map (inv \<lbrace>t\<rbrace>)"
	+ using t I by simp
	+ also have "... = \<ll>'.map (cod (inv \<lbrace>t\<rbrace>)) \<cdot> inv \<lbrace>t\<rbrace>"
	+ using t \<ll>'.is_natural_2 iso_inv_iso iso_eval_Can iso_is_arr
	+ by (metis (no_types, lifting) Can.simps(5) map_simp)
	+ also have "... = inv (\<lbrace>t\<rbrace> \<cdot> \<ll> (dom \<lbrace>t\<rbrace>))"
	+ proof -
	+ have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
	+ moreover have "iso (\<ll> (dom \<lbrace>t\<rbrace>))"
	+ using t 1 \<ll>.components_are_iso ide_dom by blast
	+ moreover have "seq \<lbrace>t\<rbrace> (\<ll> (dom \<lbrace>t\<rbrace>))"
	+ using t 1 iso_is_arr by auto
	+ ultimately show ?thesis
	+ using t 1 inv_comp by auto
	+ qed
	+ also have "... = inv \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
	+ using t iso_eval_Can \<ll>_ide_simp lunit_naturality Can_implies_Arr eval_Lunit
	+ by (auto simp add: eval_simps)
	+ finally show ?thesis by blast
	+ qed
	+ show "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
	+ proof -
	+ assume t: "Can (Lunit' t)"
	+ have "\<lbrace>Inv (Lunit' t)\<rbrace> = \<lbrace>Lunit (Inv t)\<rbrace>" by simp
	+ also have "... = \<ll> (inv \<lbrace>t\<rbrace>)"
	+ using t I by simp
	+ also have "... = inv \<lbrace>t\<rbrace> \<cdot> \<ll> (dom (inv \<lbrace>t\<rbrace>))"
	+ using t \<ll>.is_natural_1 iso_inv_iso iso_eval_Can iso_is_arr
	+ by (metis (no_types, lifting) Can.simps(6) map_simp)
	+ also have "... = inv (\<ll>'.map (cod \<lbrace>t\<rbrace>) \<cdot> \<lbrace>t\<rbrace>)"
	+ proof -
	+ have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
	+ moreover have "iso (\<ll>'.map (cod \<lbrace>t\<rbrace>))"
	+ using t 1 \<ll>'.components_are_iso ide_cod by blast
	+ moreover have "seq (\<ll>'.map (cod \<lbrace>t\<rbrace>)) \<lbrace>t\<rbrace>"
	+ using t 1 iso_is_arr by auto
	+ ultimately show ?thesis
	+ using t 1 inv_comp by auto
	+ qed
	+ also have "... = inv \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
	+ using t \<ll>'.is_natural_2 iso_eval_Can iso_is_arr by force
	+ finally show ?thesis by auto
	+ qed
	+ show "Can \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
	+ proof -
	+ assume t: "Can \<^bold>\<r>\<^bold>[t\<^bold>]"
	+ have "\<lbrace>Inv \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]\<rbrace>" by simp
	+ also have "... = \<rr>'.map (inv \<lbrace>t\<rbrace>)"
	+ using t I by simp
	+ also have "... = \<rr>'.map (cod (inv \<lbrace>t\<rbrace>)) \<cdot> inv \<lbrace>t\<rbrace>"
	+ using t \<rr>'.is_natural_2 map_simp iso_inv_iso iso_eval_Can iso_is_arr
	+ by (metis (no_types, lifting) Can.simps(7))
	+ also have "... = inv (\<lbrace>t\<rbrace> \<cdot> \<rr> (dom \<lbrace>t\<rbrace>))"
	+ proof -
	+ have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
	+ moreover have "iso (\<rr> (dom \<lbrace>t\<rbrace>))"
	+ using t 1 \<rr>.components_are_iso ide_dom by blast
	+ moreover have "seq \<lbrace>t\<rbrace> (\<rr> (dom \<lbrace>t\<rbrace>))"
	+ using t 1 iso_is_arr by simp
	+ ultimately show ?thesis
	+ using t 1 inv_comp by auto
	+ qed
	+ also have "... = inv \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
	+ using t \<rr>_ide_simp iso_eval_Can runit_naturality Can_implies_Arr eval_Runit
	+ by (auto simp add: eval_simps)
	+ finally show ?thesis by blast
	+ qed
	+ show "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
	+ proof -
	+ assume t: "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
	+ have "\<lbrace>Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<r>\<^bold>[Inv t\<^bold>]\<rbrace>"
	+ by simp
	+ also have "... = \<rr> (inv \<lbrace>t\<rbrace>)"
	+ using t I by simp
	+ also have "... = inv \<lbrace>t\<rbrace> \<cdot> \<rr> (dom (inv \<lbrace>t\<rbrace>))"
	+ using t \<rr>.is_natural_1 map_simp iso_inv_iso iso_eval_Can iso_is_arr
	+ by (metis (no_types, lifting) Can.simps(8))
	+ also have "... = inv (\<rr>'.map (cod \<lbrace>t\<rbrace>) \<cdot> \<lbrace>t\<rbrace>)"
	+ proof -
	+ have 1: "iso \<lbrace>t\<rbrace>" using t iso_eval_Can by simp
	+ moreover have "iso (\<rr>'.map (cod \<lbrace>t\<rbrace>))"
	+ using t 1 \<rr>'.components_are_iso ide_cod by blast
	+ moreover have "seq (\<rr>'.map (cod \<lbrace>t\<rbrace>)) \<lbrace>t\<rbrace>"
	+ using t 1 iso_is_arr by auto
	+ ultimately show ?thesis
	+ using t 1 inv_comp by auto
	+ qed
	+ also have "... = inv \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
	+ using t \<rr>'.is_natural_2 iso_eval_Can iso_is_arr by auto
	+ finally show ?thesis by auto
	+ qed
	+ next
	+ fix t u v
	+ assume I1: "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
	+ assume I2: "Can u \<Longrightarrow> \<lbrace>Inv u\<rbrace> = inv \<lbrace>u\<rbrace>"
	+ assume I3: "Can v \<Longrightarrow> \<lbrace>Inv v\<rbrace> = inv \<lbrace>v\<rbrace>"
	+ show "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>"
	+ proof -
	+ assume "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
	+ hence tuv: "Can t \<and> Can u \<and> Can v \<and> Src t = Trg u \<and> Src u = Trg v" by simp
	+ have "\<lbrace>Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv t, Inv u, Inv v\<^bold>]\<rbrace>" by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>] \<cdot> (inv \<lbrace>t\<rbrace> \<star> inv \<lbrace>u\<rbrace> \<star> inv \<lbrace>v\<rbrace>)"
	+ using tuv I1 I2 I3 eval_in_hom \<alpha>'.map_ide_simp inv_in_hom iso_eval_Can assoc'_naturality
	+ Can_implies_Arr Src_Inv Trg_Inv eval_Assoc' Dom_Inv Can_Inv cod_inv
	+ by presburger
	+ also have "... = inv ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>) \<cdot> \<alpha> (dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>))"
	+ using tuv iso_eval_Can Can_implies_Arr eval_simps'(2) eval_simps'(3) \<alpha>_def hseqI'
	+ by (simp add: inv_comp)
	+ also have "... = inv (\<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>))"
	+ using tuv Can_implies_Arr \<alpha>_def
	+ by (metis assoc_is_natural_1 arr_eval_Arr eval_simps'(2) eval_simps'(3) fst_conv snd_conv)
	+ also have "... = inv \<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>" by simp
	+ finally show ?thesis by blast
	+ qed
	+ show "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>"
	+ proof -
	+ assume tuv: "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
	+ have t: "Can t" using tuv by simp
	+ have u: "Can u" using tuv by simp
	+ have v: "Can v" using tuv by simp
	+ have "\<lbrace>Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<a>\<^bold>[Inv t, Inv u, Inv v\<^bold>]\<rbrace>" by simp
	+ also have "... = (inv \<lbrace>t\<rbrace> \<star> inv \<lbrace>u\<rbrace> \<star> inv \<lbrace>v\<rbrace>) \<cdot> \<alpha> (cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>)"
	+ using \<alpha>_def tuv I1 I2 I3 iso_eval_Can Can_implies_Arr eval_simps'(2) eval_simps'(3)
	+ apply simp
	+ using assoc_is_natural_1 arr_inv dom_inv src_inv trg_inv by presburger
	+ also have "... = inv (\<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>))"
	+ using tuv inv_comp [of "\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace> \<star> \<lbrace>v\<rbrace>" "\<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>]"]
	+ Can_implies_Arr inv_inv iso_assoc iso_inv_iso \<alpha>_def
	+ by (simp add: eval_simps'(2) eval_simps'(3) hseqI' iso_eval_Can)
	+ also have 1: "... = inv (((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>])"
	+ using tuv assoc'_naturality [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] Can_implies_Arr
	+ eval_simps'(2) eval_simps'(3)
	+ by simp
	+ also have "... = inv \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>"
	+ using tuv 1 Can_implies_Arr eval_Assoc' by auto
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+
	+ lemma eval_VcompNml:
	+ assumes "Nml t" and "Nml u" and "VSeq t u"
	+ shows "\<lbrace>t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
	+ proof -
	+ have "\<And>u. \<lbrakk> Nml t; Nml u; VSeq t u \<rbrakk> \<Longrightarrow> \<lbrace>t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
	+ proof (induct t, simp_all add: eval_simps)
	+ fix u a
	+ assume u: "Nml u"
	+ assume 1: "Arr u \<and> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = Cod u"
	+ show "\<lbrace>u\<rbrace> = cod \<lbrace>u\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
	+ using 1 comp_cod_arr by simp
	+ next
	+ fix u f
	+ assume u: "Nml u"
	+ assume f: "C.arr f"
	+ assume 1: "Arr u \<and> \<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod u"
	+ show "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = E f \<cdot> \<lbrace>u\<rbrace>"
	+ using f u 1 preserves_comp_2 by (cases u; simp)
	+ next
	+ fix u v w
	+ assume I1: "\<And>u. \<lbrakk> Nml v; Nml u; Arr u \<and> Dom v = Cod u \<rbrakk> \<Longrightarrow> \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>v\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
	+ assume I2: "\<And>u. \<lbrakk> Nml w; Nml u; Arr u \<and> Dom w = Cod u \<rbrakk> \<Longrightarrow> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>w\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
	+ assume vw: "Nml (v \<^bold>\<star> w)"
	+ have v: "Nml v \<and> v = Prim (un_Prim v)"
	+ using vw by (simp add: Nml_HcompD)
	+ have w: "Nml w"
	+ using vw by (simp add: Nml_HcompD)
	+ assume u: "Nml u"
	+ assume 1: "Arr v \<and> Arr w \<and> Src v = Trg w \<and> Arr u \<and> Dom v \<^bold>\<star> Dom w = Cod u"
	+ show "\<lbrace>(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> \<lbrace>u\<rbrace>"
	+ using u 1 HcompNml_in_Hom apply (cases u, simp_all)
	+ proof -
	+ fix x y
	+ assume 3: "u = x \<^bold>\<star> y"
	+ have x: "Nml x"
	+ using u 1 3 Nml_HcompD by simp
	+ have y: "Nml y"
	+ using u x 1 3 Nml_HcompD by simp
	+ assume 4: "Arr v \<and> Arr w \<and> Src v = Trg w \<and> Dom v = Cod x \<and> Dom w = Cod y"
	+ have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>"
	+ using v w x y 4 HcompNml_in_Hom by simp
	+ moreover have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>" by simp
	+ moreover have "... = \<lbrace>v\<rbrace> \<cdot> \<lbrace>x\<rbrace> \<star> \<lbrace>w\<rbrace> \<cdot> \<lbrace>y\<rbrace>"
	+ using v w x y 4 I1 [of x] I2 [of y] Nml_implies_Arr by simp
	+ moreover have "... = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)"
	+ using v w x y 4 Nml_implies_Arr interchange [of "\<lbrace>v\<rbrace>" "\<lbrace>x\<rbrace>" "\<lbrace>w\<rbrace>" "\<lbrace>y\<rbrace>"]
	+ by (simp add: eval_simps')
	+ ultimately have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)" by presburger
	+ moreover have "arr \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<and> arr \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>"
	+ using v w x y 4 VcompNml_in_Hom by simp
	+ ultimately show "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)"
	+ by simp
	+ qed
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ lemma eval_red_Hcomp:
	+ assumes "Ide a" and "Ide b"
	+ shows "\<lbrace>(a \<^bold>\<star> b)\<^bold>\<down>\<rbrace> = \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>)"
	+ proof -
	+ have "Nml (a \<^bold>\<star> b) \<Longrightarrow> ?thesis"
	+ proof -
	+ assume 1: "Nml (a \<^bold>\<star> b)"
	+ hence 2: "Nml a \<and> Nml b \<and> Src a = Trg b"
	+ using Nml_HcompD(3-4,7) by simp
	+ have "\<lbrace>(a \<^bold>\<star> b)\<^bold>\<down>\<rbrace> = \<lbrace>a\<rbrace> \<star> \<lbrace>b\<rbrace>"
	+ using 1 Nml_HcompD by simp
	+ also have "... = \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>)"
	+ using assms 1 2 ide_eval_Ide Nmlize_in_Hom red2_Nml Nmlize_Nml
	+ by (simp add: eval_simps')
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "\<not> Nml (a \<^bold>\<star> b) \<Longrightarrow> ?thesis"
	+ using assms Can_red2 by (simp add: Can_red(1) iso_eval_Can)
	+ ultimately show ?thesis by blast
	+ qed
	+
	+ (* TODO: Would the following still be useful if \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 is replaced by Src t? *)
	+ lemma eval_red2_Nml_Prim\<^sub>0:
	+ assumes "Ide t" and "Nml t" and "Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
	+ shows "\<lbrace>t \<^bold>\<Down> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<rbrace> = \<r>[\<lbrace>t\<rbrace>]"
	+ using assms \<rr>_ide_simp
	+ apply (cases t)
	+ apply simp_all
	+ proof -
	+ show "C.obj a \<Longrightarrow> t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> \<ll> (E a) = \<r>[E a]"
	+ using unitor_coincidence obj_eval_Obj [of t] \<ll>_ide_simp by auto
	+ show "\<And>b c. Ide b \<and> Ide c \<and> Src b = Trg c \<Longrightarrow> \<rr> (\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>) = \<r>[\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>]"
	+ using \<rr>_ide_simp by (simp add: eval_simps' ide_eval_Ide)
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ Most of the time when we interpret the @{locale evaluation_map} locale, we are evaluating
	+ terms formed from the arrows in a bicategory as arrows of the bicategory itself.
	+ The following locale streamlines that use case.
	+ \<close>
	+
	+ locale self_evaluation_map =
	+ bicategory
	+ begin
	+
	+ sublocale bicategorical_language V src trg ..
	+
	+ sublocale evaluation_map V src trg V H \<a> \<i> src trg \<open>\<lambda>\<mu>. if arr \<mu> then \<mu> else null\<close>
	+ using src.is_extensional trg.is_extensional
	+ by (unfold_locales, auto)
	+
	+ notation eval ("\<lbrace>_\<rbrace>")
	+ notation Nmlize ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
	+
	+ end
	+
	+ subsection "Coherence"
	+
	+ text \<open>
	+ We define an individual term to be \emph{coherent} if it commutes, up to evaluation,
	+ with the reductions of its domain and codomain. We then formulate the coherence theorem
	+ as the statement ``every formal arrow is coherent''. Because reductions evaluate
	+ to isomorphisms, this implies the standard version of coherence, which says that
	+ ``parallel canonical terms have equal evaluations''.
	+ \<close>
	+
	+ context evaluation_map
	+ begin
	+
	+ abbreviation coherent
	+ where "coherent t \<equiv> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
	+
	+ lemma Nml_implies_coherent:
	+ assumes "Nml t"
	+ shows "coherent t"
	+ using assms Nml_implies_Arr Ide_Dom Ide_Cod Nml_Dom Nml_Cod Nmlize_Nml red_Nml
	+ by (metis Dom_Cod VcompNml_Cod_Nml arr_eval_Arr comp_arr_dom eval_VcompNml
	+ eval_simps(4))
	+
	+ lemma canonical_factorization:
	+ assumes "Arr t"
	+ shows "coherent t \<longleftrightarrow> \<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
	+ proof
	+ assume 1: "coherent t"
	+ have "inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>"
	+ using 1 by simp
	+ also have "... = (inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>t\<rbrace>"
	+ using comp_assoc by simp
	+ also have "... = \<lbrace>t\<rbrace>"
	+ using assms red_in_Hom Ide_Cod Can_red iso_eval_Can comp_cod_arr
	+ by (simp add: comp_inv_arr' eval_simps'(4) eval_simps'(5))
	+ finally show "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
	+ by presburger
	+ next
	+ assume 1: "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
	+ hence "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>" by simp
	+ also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
	+ using comp_assoc by simp
	+ also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
	+ proof -
	+ have "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> = cod \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
	+ using assms red_in_Hom Ide_Cod Can_red iso_eval_Can
	+ inv_is_inverse Nmlize_in_Hom comp_arr_inv
	+ by (simp add: eval_simps')
	+ thus ?thesis
	+ using assms red_in_Hom Ide_Cod Can_red iso_eval_Can
	+ Ide_Dom Nmlize_in_Hom comp_cod_arr
	+ by (auto simp add: eval_simps')
	+ qed
	+ finally show "coherent t" by blast
	+ qed
	+
	+ lemma coherent_iff_coherent_Inv:
	+ assumes "Can t"
	+ shows "coherent t \<longleftrightarrow> coherent (Inv t)"
	+ proof
	+ have 1: "\<And>t. Can t \<Longrightarrow> coherent t \<Longrightarrow> coherent (Inv t)"
	+ proof -
	+ fix t
	+ assume "Can t"
	+ hence t: "Can t \<and> Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and>
	+ arr \<lbrace>t\<rbrace> \<and> iso \<lbrace>t\<rbrace> \<and> inverse_arrows \<lbrace>t\<rbrace> (inv \<lbrace>t\<rbrace>) \<and>
	+ Can \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Arr \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> arr \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> iso \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> VHom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
	+ inverse_arrows \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<and> Inv t \<in> VHom (Cod t) (Dom t)"
	+ using assms Can_implies_Arr Ide_Dom Ide_Cod iso_eval_Can inv_is_inverse
	+ Nmlize_in_Hom Can_Nmlize_Can Inv_in_Hom
	+ by simp
	+ assume coh: "coherent t"
	+ have "\<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace> = (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<cdot> \<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace>"
	+ using t comp_inv_arr red_in_Hom
	+ comp_cod_arr [of "\<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace>" "inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"]
	+ by (auto simp add: eval_simps')
	+ also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>t\<rbrace>"
	+ using t eval_Inv_Can comp_assoc by auto
	+ also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>) \<cdot> inv \<lbrace>t\<rbrace>"
	+ using comp_assoc by simp
	+ also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> inv \<lbrace>t\<rbrace>"
	+ using t coh by simp
	+ also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> inv \<lbrace>t\<rbrace>"
	+ using comp_assoc by simp
	+ also have "... = \<lbrace>\<^bold>\<lfloor>Inv t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (Inv t)\<^bold>\<down>\<rbrace>"
	+ proof -
	+ have "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> inv \<lbrace>t\<rbrace> = \<lbrace>Dom (Inv t)\<^bold>\<down>\<rbrace>"
	+ using t eval_Inv_Can red_in_Hom comp_arr_inv comp_arr_dom
	+ by (simp add: eval_simps')
	+ thus ?thesis
	+ using t Nmlize_Inv eval_Inv_Can by simp
	+ qed
	+ finally show "coherent (Inv t)" by blast
	+ qed
	+ show "coherent t \<Longrightarrow> coherent (Inv t)" using assms 1 by simp
	+ show "coherent (Inv t) \<Longrightarrow> coherent t"
	+ proof -
	+ assume "coherent (Inv t)"
	+ hence "coherent (Inv (Inv t))"
	+ using assms 1 Can_Inv by blast
	+ thus ?thesis using assms by simp
	+ qed
	+ qed
	+
	+ text \<open>
	+ The next two facts are trivially proved by the simplifier, so formal named facts
	+ are not really necessary, but we include them for logical completeness of the
	+ following development, which proves coherence by structural induction.
	+ \<close>
	+
	+ lemma coherent_Prim\<^sub>0:
	+ assumes "C.obj a"
	+ shows "coherent \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
	+ by simp
	+
	+ lemma coherent_Prim:
	+ assumes "Arr \<^bold>\<langle>f\<^bold>\<rangle>"
	+ shows "coherent \<^bold>\<langle>f\<^bold>\<rangle>"
	+ using assms by simp
	+
	+ lemma coherent_Lunit_Ide:
	+ assumes "Ide t"
	+ shows "coherent \<^bold>\<l>\<^bold>[t\<^bold>]"
	+ proof -
	+ have t: "Ide t \<and> Arr t \<and> Dom t = t \<and> Cod t = t \<and>
	+ ide \<lbrace>t\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>t\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>t\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
	+ using assms Ide_in_Hom Ide_Nmlize_Ide
	+ red_in_Hom eval_in_hom ide_eval_Ide
	+ by force
	+ have 1: "Obj (Trg t)" using t by auto
	+ have "\<lbrace>Cod \<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>Trg t\<rbrace> \<star> \<lbrace>t\<^bold>\<down>\<rbrace>)"
	+ using t \<ll>_ide_simp lunit_naturality [of "\<lbrace>t\<^bold>\<down>\<rbrace>"] red_in_Hom
	+ by (simp add: eval_simps')
	+ also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<l>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>Trg t\<rbrace> \<star> \<lbrace>t\<^bold>\<down>\<rbrace>)"
	+ using t 1 lunit_in_hom Nmlize_in_Hom ide_eval_Ide red_in_Hom comp_cod_arr hseqI'
	+ by (auto simp add: eval_simps')
	+ also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace>"
	+ using 1 t Nml_Trg \<ll>_ide_simp by (cases "Trg t"; simp)
	+ finally show ?thesis by simp
	+ qed
	+
	+ text \<open>
	+ Unlike many of the other results, the next one was not quite so straightforward to adapt
	+ from @{session \<open>MonoidalCategory\<close>}.
	+ \<close>
	+
	+ lemma coherent_Runit_Ide:
	+ assumes "Ide t"
	+ shows "coherent \<^bold>\<r>\<^bold>[t\<^bold>]"
	+ proof -
	+ have t: "Ide t \<and> Arr t \<and> Dom t = t \<and> Cod t = t \<and>
	+ ide \<lbrace>t\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>t\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>t\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
	+ using assms Ide_in_Hom Ide_Nmlize_Ide
	+ red_in_Hom eval_in_hom ide_eval_Ide
	+ by force
	+ have "\<lbrace>Cod \<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<rbrace>)"
	+ using t \<rr>_ide_simp red_in_Hom runit_naturality [of "\<lbrace>t\<^bold>\<down>\<rbrace>"]
	+ by (simp add: eval_simps')
	+ also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace>"
	+ proof -
	+ have "\<lbrace>\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace> = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace>)"
	+ using t by (cases t; simp; cases "Src t"; simp)
	+ also have "... = (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace>)"
	+ proof -
	+ have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<in> hom \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
	+ using t Nmlize_in_Hom by auto
	+ moreover have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<in> hom (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>Src t\<rbrace>) \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
	+ proof -
	+ have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<in> hom \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
	+ proof -
	+ have "Src \<^bold>\<lfloor>t\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>Src t\<^bold>\<rfloor> \<and> \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using t Nmlize_Src Nml_Nmlize HcompNml_Nml_Src [of "\<^bold>\<lfloor>t\<^bold>\<rfloor>"]
	+ by simp
	+ thus ?thesis
	+ using t Ide_Nmlize_Ide Nml_Nmlize Obj_Src red2_in_Hom(2)
	+ by (auto simp add: eval_simps')
	+ qed
	+ thus ?thesis using t Nmlize_in_Hom Nmlize_Src by simp
	+ qed
	+ moreover have "\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace> \<in> hom (\<lbrace>t\<rbrace> \<star> \<lbrace>Src t\<rbrace>) (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>Src t\<rbrace>)"
	+ using t red_in_Hom red_Src Obj_Src hseqI'
	+ by (auto simp add: eval_simps')
	+ ultimately show ?thesis using comp_assoc by fastforce
	+ qed
	+ also have "... = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<^bold>\<down>\<rbrace>)"
	+ proof -
	+ have "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src t\<^bold>\<rfloor>\<rbrace> = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>]"
	+ proof -
	+ have "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor>" using t Nml_Nmlize by blast
	+ moreover have "is_Prim\<^sub>0 \<^bold>\<lfloor>Src t\<^bold>\<rfloor>"
	+ using t is_Prim0_Src Nmlize_Src by presburger
	+ ultimately show ?thesis
	+ apply (cases "\<^bold>\<lfloor>t\<^bold>\<rfloor>"; simp; cases "\<^bold>\<lfloor>Src t\<^bold>\<rfloor>"; simp)
	+ using t unitor_coincidence \<ll>_ide_simp \<rr>_ide_simp Nmlize_in_Hom
	+ apply simp_all
	+ using t is_Prim0_Src
	+ apply (cases "\<^bold>\<lfloor>t\<^bold>\<rfloor>"; simp)
	+ using t Nmlize_Src unitor_coincidence preserves_obj by simp
	+ qed
	+ moreover have "\<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<in> hom (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>Src t\<rbrace>) \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
	+ using t Nmlize_in_Hom by (auto simp add: eval_simps'(2))
	+ ultimately show ?thesis
	+ using comp_cod_arr [of "\<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>]"] by fastforce
	+ qed
	+ also have "... = \<r>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Src t\<rbrace>)"
	+ using t red_Src by auto
	+ finally show ?thesis by argo
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+
	+ lemma coherent_Lunit'_Ide:
	+ assumes "Ide a"
	+ shows "coherent \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]"
	+ using assms Ide_implies_Can coherent_Lunit_Ide
	+ coherent_iff_coherent_Inv [of "Lunit a"]
	+ by simp
	+
	+ lemma coherent_Runit'_Ide:
	+ assumes "Ide a"
	+ shows "coherent \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]"
	+ using assms Ide_implies_Can coherent_Runit_Ide
	+ coherent_iff_coherent_Inv [of "Runit a"]
	+ by simp
	+
	+ lemma red2_Nml_Src:
	+ assumes "Ide t" and "Nml t"
	+ shows "\<lbrace>t \<^bold>\<Down> Src t\<rbrace> = \<r>[\<lbrace>t\<rbrace>]"
	+ using assms eval_red2_Nml_Prim\<^sub>0 is_Prim0_Src [of t]
	+ by (cases "Src t"; simp)
	+
	+ lemma red2_Trg_Nml:
	+ assumes "Ide t" and "Nml t"
	+ shows "\<lbrace>Trg t \<^bold>\<Down> t\<rbrace> = \<l>[\<lbrace>t\<rbrace>]"
	+ using assms is_Prim0_Trg [of t] \<ll>_ide_simp ide_eval_Ide
	+ by (cases "Trg t"; simp)
	+
	+ lemma coherence_key_fact:
	+ assumes "Ide a \<and> Nml a" and "Ide b \<and> Nml b" and "Ide c \<and> Nml c"
	+ and "Src a = Trg b" and "Src b = Trg c"
	+ shows "\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
	+ (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ have "is_Prim\<^sub>0 b \<Longrightarrow> ?thesis"
	+ proof -
	+ assume b: "is_Prim\<^sub>0 b"
	+ have "\<lbrace>a \<^bold>\<Down> c\<rbrace> \<cdot> (\<r>[\<lbrace>a\<rbrace>] \<star> \<lbrace>c\<rbrace>) = (\<lbrace>a \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<l>[\<lbrace>c\<rbrace>])) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>Trg c\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ have "Src b = Trg b"
	+ using b by (cases b; simp)
	+ thus ?thesis
	+ using assms triangle [of "\<lbrace>c\<rbrace>" "\<lbrace>a\<rbrace>"] ide_eval_Ide comp_assoc
	+ by (simp add: eval_simps')
	+ qed
	+ thus ?thesis
	+ using assms b HcompNml_Nml_Src [of a] HcompNml_Trg_Nml red2_Nml_Src [of a]
	+ red2_Trg_Nml
	+ by (cases b, simp_all)
	+ qed
	+ moreover have "\<lbrakk> \<not> is_Prim\<^sub>0 b; is_Prim\<^sub>0 c \<rbrakk> \<Longrightarrow> ?thesis"
	+ proof -
	+ assume b: "\<not> is_Prim\<^sub>0 b"
	+ assume c: "is_Prim\<^sub>0 c"
	+ have "\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) = \<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> Src b\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> src \<lbrace>b\<rbrace>)"
	+ using assms b c by (cases c, simp_all add: eval_simps')
	+ also have "... = \<r>[\<lbrace>a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>] \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> src \<lbrace>b\<rbrace>)"
	+ using assms red2_Nml_Src [of "a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b"] Nml_HcompNml(1) Src_HcompNml Ide_HcompNml
	+ by simp
	+ also have "... = \<lbrace>a \<^bold>\<Down> b\<rbrace> \<cdot> \<r>[\<lbrace>a\<rbrace> \<star> \<lbrace>b\<rbrace>]"
	+ proof -
	+ have "\<guillemotleft>\<lbrace>a \<^bold>\<Down> b\<rbrace> : \<lbrace>a\<rbrace> \<star> \<lbrace>b\<rbrace> \<Rightarrow> \<lbrace>a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>\<guillemotright>"
	+ using assms red2_in_Hom eval_in_hom [of "a \<^bold>\<Down> b"] by simp
	+ thus ?thesis
	+ using assms runit_naturality
	+ by (metis (no_types, lifting) arr_dom in_homE src_dom hcomp_simps(1))
	+ qed
	+ also have "... = (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ have "(\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] =
	+ (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<r>[\<lbrace>b\<rbrace>])) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, src \<lbrace>b\<rbrace>]"
	+ using assms c red2_Nml_Src [of b]
	+ by (cases c, simp_all add: eval_simps')
	+ thus ?thesis
	+ using assms runit_hcomp ide_eval_Ide comp_assoc
	+ by (simp add: eval_simps')
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "\<lbrakk> \<not> is_Prim\<^sub>0 b; \<not> is_Prim\<^sub>0 c \<rbrakk> \<Longrightarrow> ?thesis"
	+ proof -
	+ assume b': "\<not> is_Prim\<^sub>0 b"
	+ hence b: "Ide b \<and> Nml b \<and> Arr b \<and> \<not> is_Prim\<^sub>0 b \<and>
	+ ide \<lbrace>b\<rbrace> \<and> arr \<lbrace>b\<rbrace> \<and> \<^bold>\<lfloor>b\<^bold>\<rfloor> = b \<and> b\<^bold>\<down> = b \<and> Dom b = b \<and> Cod b = b"
	+ using assms Ide_Nmlize_Ide Ide_in_Hom ide_eval_Ide by simp
	+ assume c': "\<not> is_Prim\<^sub>0 c"
	+ hence c: "Ide c \<and> Nml c \<and> Arr c \<and> \<not> is_Prim\<^sub>0 c \<and>
	+ ide \<lbrace>c\<rbrace> \<and> arr \<lbrace>c\<rbrace> \<and> \<^bold>\<lfloor>c\<^bold>\<rfloor> = c \<and> c\<^bold>\<down> = c \<and> Dom c = c \<and> Cod c = c"
	+ using assms Ide_Nmlize_Ide Ide_in_Hom ide_eval_Ide by simp
	+ have "\<And>a. Ide a \<and> Nml a \<and> Src a = Trg b \<Longrightarrow>
	+ \<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
	+ = (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ fix a :: "'c term"
	+ show "Ide a \<and> Nml a \<and> Src a = Trg b \<Longrightarrow>
	+ \<lbrace>(a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
	+ = (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ apply (induct a)
	+ using b c HcompNml_in_Hom
	+ apply (simp_all add: HcompNml_Nml_Src HcompNml_Trg_Nml)
	+ proof -
	+ fix f
	+ assume f: "C.ide f \<and> C.arr f \<and> \<^bold>\<langle>src\<^sub>C f\<^bold>\<rangle>\<^sub>0 = Trg b"
	+ show "\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
	+ (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ have "\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
	+ ((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
	+ ((E f \<star> \<lbrace>b\<rbrace>) \<star> \<lbrace>c\<rbrace>)"
	+ proof -
	+ have "((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
	+ ((E f \<star> \<lbrace>b\<rbrace>) \<star> \<lbrace>c\<rbrace>) =
	+ ((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
	+ (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)"
	+ using f b red2_Nml by simp
	+ also have "... = (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
	+ (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)"
	+ proof -
	+ have "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> = E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>"
	+ using assms(5) b c is_Hcomp_HcompNml red2_Nml Nml_HcompNml(1)
	+ is_Hcomp_def
	+ by (metis eval.simps(2) eval.simps(3) red2.simps(4))
	+ thus ?thesis by argo
	+ qed
	+ also have "... = \<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)"
	+ using b c \<alpha>_def by (cases c, simp_all)
	+ finally show ?thesis by argo
	+ qed
	+ also have "... = ((E f \<star> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ have "src (E f) = trg \<lbrace>b\<rbrace>"
	+ using b f preserves_src
	+ by (cases "Trg b", auto simp add: eval_simps')
	+ thus ?thesis
	+ using assms b c f comp_arr_dom comp_assoc
	+ by (auto simp add: eval_simps')
	+ qed
	+ also have "... = (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (E f \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[E f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using assms f b c Ide_HcompNml HcompNml_Prim Nml_HcompNml
	+ is_Hcomp_HcompNml [of b c] \<alpha>_def
	+ by (cases "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c", simp_all)
	+ finally show ?thesis by blast
	+ qed
	+ next
	+ fix x
	+ assume x: "C.obj x \<and> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Trg b"
	+ show "\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>Trg b \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) =
	+ (\<lbrace>Trg b \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>Trg b\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ have 1: "Trg (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c) = Trg b"
	+ using assms b c Trg_HcompNml by blast
	+ have 2: "\<lbrace>Trg b \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> = \<l>[\<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>]"
	+ using assms b c 1 Nml_HcompNml red2_Trg_Nml [of "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c"] Ide_HcompNml
	+ by simp
	+ have "\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>Trg b \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>) = \<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<l>[\<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
	+ using b c 1 2 HcompNml_Trg_Nml red2_Trg_Nml Trg_HcompNml by simp
	+ also have "... = \<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> \<l>[\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>] \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using assms b c lunit_hcomp [of "\<lbrace>b\<rbrace>" "\<lbrace>c\<rbrace>"]
	+ by (metis (no_types, lifting) eval_simps'(3) eval_simps(2))
	+ also have "... = (\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> \<l>[\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>]) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using comp_assoc by simp
	+ also have "... = (\<l>[\<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>] \<cdot> (\<lbrace>Trg b\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using assms b c lunit_naturality [of "\<lbrace>b \<^bold>\<Down> c\<rbrace>"] red2_in_Hom
	+ by (simp add: eval_simps')
	+ also have "... = (\<lbrace>Trg b \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>Trg b\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>Trg b\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using b c 1 2 HcompNml_Trg_Nml red2_Trg_Nml Trg_HcompNml comp_assoc
	+ by simp
	+ finally show ?thesis
	+ by blast
	+ qed
	+ next
	+ fix d e
	+ assume I: "Nml e \<Longrightarrow> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
	+ = (\<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ assume de: "Ide d \<and> Ide e \<and> Src d = Trg e \<and> Nml (d \<^bold>\<star> e) \<and> Src e = Trg b"
	+ show "\<lbrace>((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
	+ = (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ let ?f = "un_Prim d"
	+ have "is_Prim d"
	+ using de Nml_HcompD
	+ by (metis term.disc(12))
	+ hence "d = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.ide ?f"
	+ using de by (cases d; simp)
	+ hence d: "Ide d \<and> Arr d \<and> Dom d = d \<and> Cod d = d \<and> Nml d \<and>
	+ d = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.ide ?f \<and> ide \<lbrace>d\<rbrace> \<and> arr \<lbrace>d\<rbrace>"
	+ using de ide_eval_Ide Nml_Nmlize(1) Ide_in_Hom Nml_HcompD [of d e]
	+ by simp
	+ have "Nml e \<and> \<not> is_Prim\<^sub>0 e"
	+ using de Nml_HcompD by metis
	+ hence e: "Ide e \<and> Arr e \<and> Dom e = e \<and> Cod e = e \<and> Nml e \<and>
	+ \<not> is_Prim\<^sub>0 e \<and> ide \<lbrace>e\<rbrace> \<and> arr \<lbrace>e\<rbrace>"
	+ using de Ide_in_Hom ide_eval_Ide by simp
	+ have 1: "is_Hcomp (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<and> is_Hcomp (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c) \<and> is_Hcomp (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)"
	+ using assms b c e de is_Hcomp_HcompNml [of e b] Nml_HcompNml
	+ is_Hcomp_HcompNml [of b c] is_Hcomp_HcompNml [of e "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c"]
	+ by auto
	+ have eb: "Src e = Trg b"
	+ using assms b c e de by argo
	+ have bc: "Src b = Trg c"
	+ using assms b c by simp
	+ have 4: "is_Hcomp ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)"
	+ using assms b c e eb de 1 is_Hcomp_HcompNml [of e b]
	+ is_Hcomp_HcompNml [of "e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b" c] is_Hcomp_HcompNml [of e b]
	+ Nml_HcompNml(1) [of e b] Src_HcompNml
	+ by auto
	+ have "\<lbrace>((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)
	+ = ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
	+ ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
	+ proof -
	+ have "\<lbrace>((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>
	+ = (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ have "((d \<^bold>\<star> e) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c = (d \<^bold>\<star> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b)) \<^bold>\<Down> c"
	+ using b c d e de 1 HcompNml_Nml Nml_HcompNml HcompNml_assoc
	+ HcompNml_Prim
	+ by (metis term.distinct_disc(4))
	+ also have "... = (d \<^bold>\<Down> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (d \<^bold>\<star> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c)) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[d, e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b, c\<^bold>]"
	+ using b c d e de 1 Nml_HcompNml Nmlize_Nml
	+ by (cases c, simp_all)
	+ also have "... = (d \<^bold>\<star> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (d \<^bold>\<star> ((e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c)) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[d, e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b, c\<^bold>]"
	+ using d 4
	+ apply (cases d, simp_all)
	+ by (cases "(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c", simp_all)
	+ finally show ?thesis
	+ using b c d e HcompNml_in_Hom red2_in_Hom
	+ Nml_HcompNml Ide_HcompNml \<alpha>_def
	+ by simp
	+ qed
	+ moreover have "\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> b\<rbrace>
	+ = (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>]"
	+ proof -
	+ have "(d \<^bold>\<star> e) \<^bold>\<Down> b = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
	+ using b c d e de 1 HcompNml_Prim Nmlize_Nml
	+ by (cases b, simp_all)
	+ also have "... = (d \<^bold>\<star> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
	+ using b c d e de 1 HcompNml_Nml Nml_HcompNml
	+ apply (cases d, simp_all)
	+ by (cases "e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b", simp_all)
	+ finally show ?thesis
	+ using b d e HcompNml_in_Hom red2_in_Hom \<alpha>_def by simp
	+ qed
	+ ultimately show ?thesis by argo
	+ qed
	+ also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
	+ ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<star> \<lbrace>c\<rbrace>) \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
	+ proof -
	+ have "(\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>
	+ = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<star> \<lbrace>c\<rbrace>) \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
	+ using assms b c d e de eb HcompNml_in_Hom red2_in_Hom comp_cod_arr
	+ Ide_HcompNml Nml_HcompNml comp_assoc
	+ interchange [of "\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>" "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>]" "\<lbrace>c\<rbrace>" "\<lbrace>c\<rbrace>"]
	+ by (auto simp add: eval_simps' hseqI')
	+ moreover have "(\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>] =
	+ (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ have "(\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>] =
	+ ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>)) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using comp_assoc by simp
	+ thus ?thesis
	+ using assms b c d e de eb HcompNml_in_Hom red2_in_Hom
	+ Ide_HcompNml Nml_HcompNml comp_cod_arr
	+ by (simp add: eval_simps' hseqI')
	+ qed
	+ ultimately show ?thesis by argo
	+ qed
	+ also have "... = (\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
	+ using assms b c d e de HcompNml_in_Hom red2_in_Hom
	+ Ide_HcompNml Nml_HcompNml ide_eval_Ide
	+ assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e \<^bold>\<Down> b\<rbrace>" "\<lbrace>c\<rbrace>"]
	+ comp_permute [of "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]" "(\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<star> \<lbrace>c\<rbrace>"
	+ "\<lbrace>d\<rbrace> \<star> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>)" "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"]
	+ comp_assoc
	+ by (simp add: eval_simps' hseqI')
	+ also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>))) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
	+ using comp_assoc by simp
	+ also have "... = (((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
	+ (\<lbrace>d\<rbrace> \<star> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>])) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>)"
	+ using assms b c d e de eb I HcompNml_in_Hom red2_in_Hom
	+ Ide_HcompNml Nml_HcompNml whisker_left [of "\<lbrace>d\<rbrace>"]
	+ interchange [of "\<lbrace>d\<rbrace>" "\<lbrace>d\<rbrace>" "\<lbrace>(e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>" "\<lbrace>e \<^bold>\<Down> b\<rbrace> \<star> \<lbrace>c\<rbrace>"]
	+ by (auto simp add: eval_simps' hseqI')
	+ also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
	+ ((\<lbrace>d\<rbrace> \<star> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<star> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<star> \<lbrace>c\<rbrace>))"
	+ using comp_assoc by simp
	+ also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> (\<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>))) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>] \<cdot> \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using assms b c d e de pentagon
	+ by (simp add: eval_simps')
	+ also have "... = (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot>
	+ ((\<lbrace>d\<rbrace> \<star> (\<lbrace>e\<rbrace> \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>]) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using comp_assoc by simp
	+ also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>)) \<cdot>
	+ (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>] \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using assms d e de HcompNml_in_Hom red2_in_Hom Ide_HcompNml Nml_HcompNml
	+ assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e\<rbrace>" "\<lbrace>b \<^bold>\<Down> c\<rbrace>"] comp_cod_arr [of "\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>"]
	+ by (simp add: eval_simps' hseqI')
	+ also have "... = ((\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>]) \<cdot>
	+ ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using comp_assoc by simp
	+ also have "... = \<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ proof -
	+ have "\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>
	+ = (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<star> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<rbrace>]"
	+ proof -
	+ have "(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)
	+ = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>\<rfloor>)) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>]"
	+ using e 1 by (cases "b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c") auto
	+ also have "... = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>]"
	+ using assms Nml_HcompNml Nmlize_Nml by simp
	+ also have "... = (d \<^bold>\<star> (e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<star> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c\<^bold>]"
	+ using d 1
	+ apply (cases "e \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c", simp_all)
	+ by (cases d, simp_all)
	+ finally show ?thesis
	+ using \<alpha>_def by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (\<lbrace>(d \<^bold>\<star> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>) \<star> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
	+ \<a>[\<lbrace>d\<rbrace> \<star> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using comp_assoc by simp
	+ finally show ?thesis by auto
	+ qed
	+ qed
	+ qed
	+ thus ?thesis using assms(1,4) by blast
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+
	+ lemma coherent_Assoc_Ide:
	+ assumes "Ide a" and "Ide b" and "Ide c" and "Src a = Trg b" and "Src b = Trg c"
	+ shows "coherent \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
	+ proof -
	+ have a: "Ide a \<and> Arr a \<and> Dom a = a \<and> Cod a = a \<and>
	+ ide \<lbrace>a\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>a\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>a\<rbrace> \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>"
	+ using assms Ide_in_Hom Ide_Nmlize_Ide ide_eval_Ide red_in_Hom eval_in_hom(2)
	+ by force
	+ have b: "Ide b \<and> Arr b \<and> Dom b = b \<and> Cod b = b \<and>
	+ ide \<lbrace>b\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>b\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>b\<rbrace> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>"
	+ using assms Ide_in_Hom Ide_Nmlize_Ide ide_eval_Ide red_in_Hom(2)
	+ eval_in_hom(2) [of "b\<^bold>\<down>"]
	+ by auto
	+ have c: "Ide c \<and> Arr c \<and> Dom c = c \<and> Cod c = c \<and>
	+ ide \<lbrace>c\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>c\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>c\<rbrace> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>"
	+ using assms Ide_in_Hom Ide_Nmlize_Ide red_in_Hom eval_in_hom(2) [of "c\<^bold>\<down>"]
	+ ide_eval_Ide
	+ by auto
	+ have "\<lbrace>Cod \<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<rbrace>
	+ = (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace> \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)) \<cdot>
	+ \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
	+ using assms a b c red_in_Hom red2_in_Hom Nml_Nmlize Ide_Nmlize_Ide
	+ \<alpha>_def eval_red_Hcomp interchange [of "\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>" "\<lbrace>a\<^bold>\<down>\<rbrace>"] comp_cod_arr [of "\<lbrace>a\<^bold>\<down>\<rbrace>"]
	+ by (simp add: eval_simps' hseqI')
	+ also have "... = ((\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot> \<a>[\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>, \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>, \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>]) \<cdot>
	+ ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)"
	+ using assms red_in_Hom Ide_HcompNml assoc_naturality [of "\<lbrace>a\<^bold>\<down>\<rbrace>" "\<lbrace>b\<^bold>\<down>\<rbrace>" "\<lbrace>c\<^bold>\<down>\<rbrace>"] comp_assoc
	+ by (simp add: eval_simps')
	+ also have "... = (\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)"
	+ using assms Nml_Nmlize Ide_Nmlize_Ide coherence_key_fact by simp
	+ also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<down>\<rbrace>"
	+ using assms a b c red_in_Hom red2_in_Hom Ide_Nmlize_Ide
	+ Nml_Nmlize eval_red_Hcomp HcompNml_assoc
	+ interchange [of "\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>" "\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>" "\<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>" "\<lbrace>c\<^bold>\<down>\<rbrace>"]
	+ comp_cod_arr [of "\<lbrace>c\<^bold>\<down>\<rbrace>" "\<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>"]
	+ apply (simp add: eval_simps' hseqI')
	+ proof -
	+ have "seq \<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> ((\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>))"
	+ using assms c red_in_Hom red2_in_Hom Nml_HcompNml Ide_Nmlize_Ide Ide_HcompNml
	+ Nml_Nmlize
	+ by (simp_all add: eval_simps' hseqI')
	+ moreover have
	+ "cod (\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)) =
	+ \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>"
	+ using assms c red_in_Hom red2_in_Hom Nml_HcompNml Ide_Nmlize_Ide Ide_HcompNml
	+ Nml_Nmlize HcompNml_assoc
	+ by (simp add: eval_simps' hseqI')
	+ ultimately
	+ show "(\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>) =
	+ \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot>
	+ \<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>) \<star> \<lbrace>c\<^bold>\<down>\<rbrace>)"
	+ using comp_cod_arr comp_assoc by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+
	+ lemma coherent_Assoc'_Ide:
	+ assumes "Ide a" and "Ide b" and "Ide c" and "Src a = Trg b" and "Src b = Trg c"
	+ shows "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[a, b, c\<^bold>]"
	+ using assms Ide_implies_Can coherent_Assoc_Ide Inv_Ide coherent_iff_coherent_Inv
	+ Can.simps(10) Inv.simps(10)
	+ by presburger
	+
	+ lemma eval_red2_naturality:
	+ assumes "Nml t" and "Nml u" and "Src t = Trg u"
	+ shows "\<lbrace>Cod t \<^bold>\<Down> Cod u\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) = \<lbrace>t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom t \<^bold>\<Down> Dom u\<rbrace>"
	+ proof -
	+ have *: "\<And>t u. Nml (t \<^bold>\<star> u) \<Longrightarrow> arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>u\<rbrace>"
	+ using Nml_implies_Arr Nml_HcompD by simp
	+ have "is_Prim\<^sub>0 t \<Longrightarrow> ?thesis"
	+ using assms Nml_implies_Arr is_Prim0_Trg \<ll>.naturality [of "\<lbrace>u\<rbrace>"]
	+ by (cases t, simp_all add: eval_simps', cases "Trg t", simp_all)
	+ moreover have "\<not> is_Prim\<^sub>0 t \<and> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
	+ using assms Nml_implies_Arr eval_red2_Nml_Prim\<^sub>0 runit_naturality [of "\<lbrace>t\<rbrace>"]
	+ by (cases u, simp_all add: eval_simps')
	+ moreover have "\<not> is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
	+ using assms * Nml_implies_Arr
	+ apply (induct t, simp_all)
	+ proof -
	+ fix f
	+ assume f: "C.arr f"
	+ assume "\<not> is_Prim\<^sub>0 u"
	+ hence u: "\<not> is_Prim\<^sub>0 u \<and>
	+ Nml u \<and> Nml (Dom u) \<and> Nml (Cod u) \<and> Ide (Dom u) \<and> Ide (Cod u) \<and>
	+ arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
	+ using assms(2) Nml_implies_Arr ide_eval_Ide by simp
	+ hence 1: "\<not> is_Prim\<^sub>0 (Dom u) \<and> \<not> is_Prim\<^sub>0 (Cod u)"
	+ using u by (cases u, simp_all)
	+ assume "\<^bold>\<langle>src\<^sub>C f\<^bold>\<rangle>\<^sub>0 = Trg u"
	+ hence "\<lbrace>\<^bold>\<langle>src\<^sub>C f\<^bold>\<rangle>\<^sub>0\<rbrace> = \<lbrace>Trg u\<rbrace>" by simp
	+ hence fu: "src (E f) = trg \<lbrace>u\<rbrace>"
	+ using f u preserves_src Nml_implies_Arr
	+ by (simp add: eval_simps')
	+ show "\<lbrace>\<^bold>\<langle>C.cod f\<^bold>\<rangle> \<^bold>\<Down> Cod u\<rbrace> \<cdot> (E f \<star> \<lbrace>u\<rbrace>) = (E f \<star> \<lbrace>u\<rbrace>) \<cdot> \<lbrace>\<^bold>\<langle>C.dom f\<^bold>\<rangle> \<^bold>\<Down> Dom u\<rbrace>"
	+ proof -
	+ have "\<lbrace>\<^bold>\<langle>C.cod f\<^bold>\<rangle> \<^bold>\<Down> Cod u\<rbrace> = E (C.cod f) \<star> cod \<lbrace>u\<rbrace>"
	+ using f u 1 Nml_implies_Arr
	+ by (cases "Cod u", simp_all add: eval_simps')
	+ moreover have "\<lbrace>\<^bold>\<langle>C.dom f\<^bold>\<rangle> \<^bold>\<Down> Dom u\<rbrace> = E (C.dom f) \<star> dom \<lbrace>u\<rbrace>"
	+ using f u 1 Nml_implies_Arr
	+ by (cases "Dom u", simp_all add: eval_simps')
	+ moreover have "E f \<star> \<lbrace>u\<rbrace> \<in> hom (E (C.dom f) \<star> \<lbrace>Dom u\<rbrace>) (E (C.cod f) \<star> \<lbrace>Cod u\<rbrace>)"
	+ using f u fu Nml_implies_Arr
	+ by (auto simp add: eval_simps' hseqI')
	+ ultimately show ?thesis
	+ using f u comp_arr_dom comp_cod_arr
	+ by (simp add: fu hseqI')
	+ qed
	+ next
	+ fix v w
	+ assume I2: "\<lbrakk> \<not> is_Prim\<^sub>0 w; Nml w \<rbrakk> \<Longrightarrow>
	+ \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace> \<cdot> (\<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>) = \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>"
	+ assume "\<not> is_Prim\<^sub>0 u"
	+ hence u: "\<not> is_Prim\<^sub>0 u \<and> Arr u \<and> Arr (Dom u) \<and> Arr (Cod u) \<and>
	+ Nml u \<and> Nml (Dom u) \<and> Nml (Cod u) \<and> Ide (Dom u) \<and> Ide (Cod u) \<and>
	+ arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
	+ using assms(2) Nml_implies_Arr ide_eval_Ide by simp
	+ assume vw: "Nml (v \<^bold>\<star> w)"
	+ assume wu: "Src w = Trg u"
	+ let ?f = "un_Prim v"
	+ have "v = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.arr ?f"
	+ using vw by (metis Nml_HcompD(1) Nml_HcompD(2))
	+ hence "Arr v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> C.arr ?f \<and> Nml v" by (cases v; simp)
	+ hence v: "v = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.arr ?f \<and> Arr v \<and> Arr (Dom v) \<and> Arr (Cod v) \<and> Nml v \<and>
	+ Nml (Dom v) \<and> Nml (Cod v) \<and>
	+ arr \<lbrace>v\<rbrace> \<and> arr \<lbrace>Dom v\<rbrace> \<and> arr \<lbrace>Cod v\<rbrace> \<and> ide \<lbrace>Dom v\<rbrace> \<and> ide \<lbrace>Cod v\<rbrace>"
	+ using vw * by (cases v, simp_all)
	+ have "Nml w \<and> \<not> is_Prim\<^sub>0 w"
	+ using vw v by (metis Nml.simps(3))
	+ hence w: "\<not> is_Prim\<^sub>0 w \<and> Arr w \<and> Arr (Dom w) \<and> Arr (Cod w) \<and>
	+ Nml w \<and> Nml (Dom w) \<and> Nml (Cod w) \<and>
	+ Ide (Dom w) \<and> Ide (Cod w) \<and>
	+ arr \<lbrace>w\<rbrace> \<and> arr \<lbrace>Dom w\<rbrace> \<and> arr \<lbrace>Cod w\<rbrace> \<and> ide \<lbrace>Dom w\<rbrace> \<and> ide \<lbrace>Cod w\<rbrace>"
	+ using vw * Nml_implies_Arr ide_eval_Ide by simp
	+ have u': "\<not> is_Prim\<^sub>0 (Dom u) \<and> \<not> is_Prim\<^sub>0 (Cod u)"
	+ using u by (cases u, simp_all)
	+ have w': "\<not> is_Prim\<^sub>0 (Dom w) \<and> \<not> is_Prim\<^sub>0 (Cod w)"
	+ using w by (cases w, simp_all)
	+ have vw': "Src v = Trg w"
	+ using vw Nml_HcompD(7) by simp
	+ have X: "Nml (Dom v \<^bold>\<star> (Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u))"
	+ using u u' v w w' wu vw is_Hcomp_HcompNml Nml_HcompNml
	+ apply (cases v, simp_all)
	+ apply (cases "Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u", simp_all)
	+ apply (cases "Dom v", simp_all)
	+ by (metis Src_Dom Trg_Dom term.disc(21))
	+ have Y: "Nml (Cod v \<^bold>\<star> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u))"
	+ using u u' w w' wu vw is_Hcomp_HcompNml Nml_HcompNml
	+ apply (cases v, simp_all)
	+ apply (cases "Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u", simp_all)
	+ apply (cases "Cod v", simp_all)
	+ by (metis Src_Cod Trg_Cod term.disc(21))
	+ show "\<lbrace>(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u\<rbrace> \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)
	+ = \<lbrace>(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>"
	+ proof -
	+ have "\<lbrace>(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u\<rbrace> \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)
	+ = (\<lbrace>Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u)\<rbrace> \<cdot> (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
	+ proof -
	+ have "(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u
	+ = (Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>)) \<^bold>\<cdot> (Cod v \<^bold>\<star> Cod w \<^bold>\<Down> Cod u) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[Cod v, Cod w, Cod u\<^bold>]"
	+ using u v w by (cases u, simp_all)
	+ hence "\<lbrace>(Cod v \<^bold>\<star> Cod w) \<^bold>\<Down> Cod u\<rbrace>
	+ = \<lbrace>Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u)\<rbrace> \<cdot> (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]"
	+ using u v w \<alpha>_def by simp
	+ thus ?thesis by presburger
	+ qed
	+ also have "... = ((\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod u\<rbrace>) \<cdot> (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot> ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
	+ using u v w Y red2_Nml by simp
	+ also have "... = ((\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot>
	+ ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
	+ using u v w vw' wu comp_cod_arr red2_in_Hom HcompNml_in_Hom comp_reduce
	+ by (simp add: eval_simps' hseqI')
	+ also have "... = (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>] \<cdot>
	+ ((\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<star> \<lbrace>u\<rbrace>)"
	+ using comp_assoc by simp
	+ also have "... = (\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ using u v w vw' wu assoc_naturality [of "\<lbrace>v\<rbrace>" "\<lbrace>w\<rbrace>" "\<lbrace>u\<rbrace>"]
	+ by (simp add: eval_simps')
	+ also have "... = ((\<lbrace>Cod v\<rbrace> \<star> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>)) \<cdot>
	+ \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ using comp_assoc by simp
	+ also have
	+ "... = (\<lbrace>v\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ using v w u vw' wu I2 red2_in_Hom HcompNml_in_Hom comp_cod_arr
	+ interchange [of "\<lbrace>Cod v\<rbrace>" "\<lbrace>v\<rbrace>" "\<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>" "\<lbrace>w\<rbrace> \<star> \<lbrace>u\<rbrace>"]
	+ by (simp add: eval_simps')
	+ also have "... = ((\<lbrace>v\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace>) \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>)) \<cdot>
	+ \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ using v w u vw' wu red2_in_Hom HcompNml_in_Hom comp_arr_dom
	+ interchange [of "\<lbrace>v\<rbrace>" "\<lbrace>Dom v\<rbrace>" "\<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace>" "\<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>"]
	+ by (simp add: eval_simps')
	+ also have "... = (\<lbrace>v\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace>) \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ using comp_assoc by simp
	+ also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ using u u' v w vw' wu is_Hcomp_HcompNml HcompNml_Prim [of "w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u" ?f]
	+ by force
	+ also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot>
	+ (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ proof -
	+ have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>] =
	+ (\<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace>) \<cdot>
	+ (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ using u v w vw' wu comp_arr_dom Nml_HcompNml HcompNml_in_Hom
	+ by (simp add: eval_simps')
	+ also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot>
	+ (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ using comp_assoc by simp
	+ finally show ?thesis by blast
	+ qed
	+ also have "... = \<lbrace>(v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>"
	+ proof -
	+ have "(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u
	+ = (Dom v \<^bold>\<Down> (Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>)) \<^bold>\<cdot> (Dom v \<^bold>\<star> (Dom w \<^bold>\<Down> Dom u)) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[Dom v, Dom w, Dom u\<^bold>]"
	+ using u u' v w vw' wu by (cases u, simp_all)
	+ hence
	+ "\<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>
	+ = \<lbrace>Dom v \<^bold>\<Down> (Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u)\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ using u v w \<alpha>_def by simp
	+ also have
	+ "... = \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ using X HcompNml_Nml red2_Nml by presburger
	+ finally have
	+ "\<lbrace>(Dom v \<^bold>\<star> Dom w) \<^bold>\<Down> Dom u\<rbrace>
	+ = \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<star> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
	+ \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
	+ by blast
	+ thus ?thesis
	+ using assms v w vw' wu HcompNml_assoc by presburger
	+ qed
	+ finally show ?thesis
	+ using vw HcompNml_Nml by simp
	+ qed
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+
	+ lemma coherent_Hcomp:
	+ assumes "Arr t" and "Arr u" and "Src t = Trg u" and "coherent t" and "coherent u"
	+ shows "coherent (t \<^bold>\<star> u)"
	+ proof -
	+ have t: "Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and> Ide \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
	+ arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>Dom t\<rbrace> \<and> ide \<lbrace>Dom t\<rbrace> \<and> arr \<lbrace>Cod t\<rbrace> \<and> ide \<lbrace>Cod t\<rbrace>"
	+ using assms Ide_Nmlize_Ide ide_eval_Ide by auto
	+ have u: "Arr u \<and> Ide (Dom u) \<and> Ide (Cod u) \<and> Ide \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<and>
	+ arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
	+ using assms Ide_Nmlize_Ide ide_eval_Ide by auto
	+ have "\<lbrace>Cod (t \<^bold>\<star> u)\<^bold>\<down>\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>)
	+ = (\<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Cod u\<^bold>\<down>\<rbrace>)) \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>)"
	+ using t u eval_red_Hcomp by simp
	+ also have "... = \<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Cod u\<^bold>\<down>\<rbrace>) \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>)"
	+ using comp_assoc by simp
	+ also have "... = \<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
	+ using assms t u Nmlize_in_Hom red_in_Hom
	+ interchange [of "\<lbrace>Cod t\<^bold>\<down>\<rbrace>" "\<lbrace>t\<rbrace>" "\<lbrace>Cod u\<^bold>\<down>\<rbrace>" "\<lbrace>u\<rbrace>"]
	+ interchange [of "\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>" "\<lbrace>Dom t\<^bold>\<down>\<rbrace>" "\<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>" "\<lbrace>Dom u\<^bold>\<down>\<rbrace>"]
	+ by (simp add: eval_simps')
	+ also have "... = (\<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<star> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>)) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
	+ using comp_assoc by simp
	+ also have "... = (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
	+ using assms t u Nml_Nmlize Nmlize_in_Hom
	+ eval_red2_naturality [of "Nmlize t" "Nmlize u"]
	+ by simp
	+ also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
	+ using comp_assoc by simp
	+ also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>(Dom t \<^bold>\<star> Dom u)\<^bold>\<down>\<rbrace>"
	+ using t u eval_red_Hcomp by simp
	+ finally have "\<lbrace>Cod (t \<^bold>\<star> u)\<^bold>\<down>\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>(Dom t \<^bold>\<star> Dom u)\<^bold>\<down>\<rbrace>"
	+ by blast
	+ thus ?thesis using t u by simp
	+ qed
	+
	+ lemma coherent_Vcomp:
	+ assumes "Arr t" and "Arr u" and "Dom t = Cod u"
	+ and "coherent t" and "coherent u"
	+ shows "coherent (t \<^bold>\<cdot> u)"
	+ proof -
	+ have t: "Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and> Ide \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
	+ arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>Dom t\<rbrace> \<and> ide \<lbrace>Dom t\<rbrace> \<and> arr \<lbrace>Cod t\<rbrace> \<and> ide \<lbrace>Cod t\<rbrace>"
	+ using assms Ide_Nmlize_Ide ide_eval_Ide by auto
	+ have u: "Arr u \<and> Ide (Dom u) \<and> Ide (Cod u) \<and> Ide \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<and>
	+ arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
	+ using assms Ide_Nmlize_Ide ide_eval_Ide by auto
	+ have "\<lbrace>Cod (t \<^bold>\<cdot> u)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
	+ using t u by simp
	+ also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> \<lbrace>u\<rbrace>"
	+ proof -
	+ have "seq \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<lbrace>t\<rbrace>"
	+ using assms t red_in_Hom
	+ by (intro seqI, auto simp add: eval_simps')
	+ moreover have "seq \<lbrace>t\<rbrace> \<lbrace>u\<rbrace>"
	+ using assms t u by (auto simp add: eval_simps')
	+ ultimately show ?thesis
	+ using comp_assoc by auto
	+ qed
	+ also have "... = \<lbrace>\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (t \<^bold>\<cdot> u)\<^bold>\<down>\<rbrace>"
	+ using t u assms red_in_Hom Nml_Nmlize comp_assoc
	+ by (simp add: eval_simps' Nml_implies_Arr eval_VcompNml)
	+ finally show "coherent (t \<^bold>\<cdot> u)" by blast
	+ qed
	+
	+ text \<open>
	+ The main result: ``Every formal arrow is coherent.''
	+ \<close>
	+
	+ theorem coherence:
	+ assumes "Arr t"
	+ shows "coherent t"
	+ proof -
	+ have "Arr t \<Longrightarrow> coherent t"
	+ proof (induct t)
	+ show "\<And>a. Arr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> coherent \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0" by simp
	+ show "\<And>\<mu>. Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<Longrightarrow> coherent \<^bold>\<langle>\<mu>\<^bold>\<rangle>" by simp
	+ fix u v
	+ show "\<lbrakk> Arr u \<Longrightarrow> coherent u; Arr v \<Longrightarrow> coherent v \<rbrakk> \<Longrightarrow> Arr (u \<^bold>\<star> v)
	+ \<Longrightarrow> coherent (u \<^bold>\<star> v)"
	+ using coherent_Hcomp by simp
	+ show "\<lbrakk> Arr u \<Longrightarrow> coherent u; Arr v \<Longrightarrow> coherent v \<rbrakk> \<Longrightarrow> Arr (u \<^bold>\<cdot> v)
	+ \<Longrightarrow> coherent (u \<^bold>\<cdot> v)"
	+ using coherent_Vcomp by simp
	+ next
	+ fix t
	+ assume I: "Arr t \<Longrightarrow> coherent t"
	+ show Lunit: "Arr \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<l>\<^bold>[t\<^bold>]"
	+ using I Ide_Dom coherent_Lunit_Ide Ide_in_Hom
	+ coherent_Vcomp [of t "\<^bold>\<l>\<^bold>[Dom t\<^bold>]"] Nmlize_Vcomp_Arr_Dom
	+ eval_in_hom \<ll>.is_natural_1 [of "\<lbrace>t\<rbrace>"]
	+ by force
	+ show Runit: "Arr \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<r>\<^bold>[t\<^bold>]"
	+ using I Ide_Dom coherent_Runit_Ide Ide_in_Hom ide_eval_Ide
	+ coherent_Vcomp [of t "\<^bold>\<r>\<^bold>[Dom t\<^bold>]"] Nmlize_Vcomp_Arr_Dom \<rr>_ide_simp
	+ eval_in_hom \<rr>.is_natural_1 [of "\<lbrace>t\<rbrace>"]
	+ by force
	+ show "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
	+ proof -
	+ assume "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
	+ hence t: "Arr t" by simp
	+ have "coherent (\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t)"
	+ using t I Ide_Cod coherent_Lunit'_Ide Ide_in_Hom coherent_Vcomp [of "\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>]" t]
	+ Arr.simps(6) Dom.simps(6) Dom_Cod Ide_implies_Arr
	+ by presburger
	+ moreover have "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t\<rbrace>"
	+ using t \<ll>'.is_natural_2 [of "\<lbrace>t\<rbrace>"]
	+ by (simp add: eval_simps(5))
	+ ultimately show ?thesis
	+ using t Nmlize_Vcomp_Cod_Arr by simp
	+ qed
	+ show "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
	+ proof -
	+ assume "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
	+ hence t: "Arr t" by simp
	+ have "coherent (\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t)"
	+ using t I Ide_Cod coherent_Runit'_Ide Ide_in_Hom coherent_Vcomp [of "\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>]" t]
	+ Arr.simps(8) Dom.simps(8) Dom_Cod Ide_implies_Arr
	+ by presburger
	+ moreover have "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t\<rbrace>"
	+ using t \<rr>'.is_natural_2 [of "\<lbrace>t\<rbrace>"]
	+ by (simp add: eval_simps(5))
	+ ultimately show ?thesis
	+ using t Nmlize_Vcomp_Cod_Arr by simp
	+ qed
	+ next
	+ fix t u v
	+ assume I1: "Arr t \<Longrightarrow> coherent t"
	+ assume I2: "Arr u \<Longrightarrow> coherent u"
	+ assume I3: "Arr v \<Longrightarrow> coherent v"
	+ show "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> coherent \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
	+ proof -
	+ assume tuv: "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
	+ have t: "Arr t" using tuv by simp
	+ have u: "Arr u" using tuv by simp
	+ have v: "Arr v" using tuv by simp
	+ have tu: "Src t = Trg u" using tuv by simp
	+ have uv: "Src u = Trg v" using tuv by simp
	+ have "coherent ((t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
	+ proof -
	+ have "Arr (t \<^bold>\<star> u \<^bold>\<star> v) \<and> coherent (t \<^bold>\<star> u \<^bold>\<star> v)"
	+ using t u v tu uv tuv I1 I2 I3 coherent_Hcomp Arr.simps(3) Trg.simps(3)
	+ by presburger
	+ moreover have "Arr \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
	+ using t u v tu uv Ide_Dom by simp
	+ moreover have "coherent \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
	+ using t u v tu uv Src_Dom Trg_Dom Ide_Dom coherent_Assoc_Ide by metis
	+ moreover have "Dom (t \<^bold>\<star> u \<^bold>\<star> v) = Cod \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
	+ using t u v by simp
	+ ultimately show ?thesis
	+ using t u v coherent_Vcomp by blast
	+ qed
	+ moreover have "VPar \<^bold>\<a>\<^bold>[t, u, v\<^bold>] ((t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
	+ using t u v tu uv Ide_Dom by simp
	+ moreover have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>(t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<^bold>\<rfloor>"
	+ proof -
	+ have "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>
	+ = (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom v\<^bold>\<rfloor>)"
	+ proof -
	+ have 1: "Nml \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Nml \<^bold>\<lfloor>u\<^bold>\<rfloor> \<and> Nml \<^bold>\<lfloor>v\<^bold>\<rfloor> \<and>
	+ Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom v\<^bold>\<rfloor>"
	+ using t u v Nml_Nmlize by blast
	+ moreover have "Nml (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>)"
	+ using 1 t u tu Nmlize_Src Nmlize_Trg Nml_HcompNml(1)
	+ by presburger
	+ moreover have "\<And>t. Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
	+ using t Nmlize_Vcomp_Arr_Dom by simp
	+ moreover have "Dom \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor>"
	+ using Nml_Nmlize tuv by blast
	+ ultimately show ?thesis
	+ using t u v tu uv tuv 1 HcompNml_assoc Nml_HcompNml
	+ Nml_Nmlize VcompNml_Nml_Dom [of "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"]
	+ by auto
	+ qed
	+ thus ?thesis
	+ using t u v Nmlize_Vcomp_Arr_Dom VcompNml_HcompNml Nml_Nmlize
	+ by simp
	+ qed
	+ moreover have "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>(t \<^bold>\<star> u \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
	+ using t u v tu uv Ide_Dom comp_cod_arr ide_eval_Ide \<alpha>_def
	+ apply (simp add: eval_simps')
	+ using assoc_is_natural_1 arr_eval_Arr eval_simps'(2-4) by presburger
	+ ultimately show "coherent \<^bold>\<a>\<^bold>[t, u, v\<^bold>]" by argo
	+ qed
	+ show "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
	+ proof -
	+ assume tuv: "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
	+ have t: "Arr t" using tuv by simp
	+ have u: "Arr u" using tuv by simp
	+ have v: "Arr v" using tuv by simp
	+ have tu: "Src t = Trg u" using tuv by simp
	+ have uv: "Src u = Trg v" using tuv by simp
	+ have "coherent (((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
	+ proof -
	+ have "Arr ((t \<^bold>\<star> u) \<^bold>\<star> v) \<and> coherent ((t \<^bold>\<star> u) \<^bold>\<star> v)"
	+ using t u v tu uv tuv I1 I2 I3 coherent_Hcomp Arr.simps(3) Src.simps(3)
	+ by presburger
	+ moreover have "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
	+ using t u v tu uv Ide_Dom by simp
	+ moreover have "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
	+ using t u v tu uv Src_Dom Trg_Dom Ide_Dom coherent_Assoc'_Ide
	+ by metis
	+ moreover have "Dom ((t \<^bold>\<star> u) \<^bold>\<star> v) = Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
	+ using t u v by simp
	+ ultimately show ?thesis
	+ using t u v coherent_Vcomp by metis
	+ qed
	+ moreover have "VPar \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] (((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
	+ using t u v tu uv Ide_Dom by simp
	+ moreover have "\<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<^bold>\<rfloor>"
	+ using t u v tu uv Nmlize_Vcomp_Arr_Dom VcompNml_HcompNml Nml_Nmlize
	+ HcompNml_assoc Nml_HcompNml HcompNml_in_Hom
	+ VcompNml_Nml_Dom [of "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"]
	+ by simp
	+ moreover have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
	+ proof -
	+ have 1: "VVV.arr (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
	+ using tuv \<alpha>'.preserves_reflects_arr arr_eval_Arr eval.simps(10)
	+ by (metis (no_types, lifting))
	+ have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = ((\<lbrace>t\<rbrace> \<star> \<lbrace>u\<rbrace>) \<star> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>]"
	+ proof -
	+ have "VVV.arr (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
	+ using tuv \<alpha>'.preserves_reflects_arr arr_eval_Arr eval.simps(10)
	+ by (metis (no_types, lifting))
	+ thus ?thesis
	+ using t u v \<alpha>'.is_natural_1 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] HoHV_def \<a>'_def
	+ by simp
	+ qed
	+ also have "... = \<lbrace>((t \<^bold>\<star> u) \<^bold>\<star> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
	+ by (simp add: eval_simps'(4) t u v \<a>'_def)
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]" by argo
	+ qed
	+ qed
	+ thus ?thesis using assms by blast
	+ qed
	+
	+ corollary eval_eqI:
	+ assumes "VPar t u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ shows "\<lbrace>t\<rbrace> = \<lbrace>u\<rbrace>"
	+ using assms coherence canonical_factorization by simp
	+
	+ text \<open>
	+ The following allows us to prove that two 1-cells in a bicategory are isomorphic
	+ simply by expressing them as the evaluations of terms having the same normalization.
	+ The benefits are: (1) we do not have to explicitly exhibit the isomorphism,
	+ which is canonical and is obtained by evaluating the reductions of the terms
	+ to their normalizations, and (2) the normalizations can be computed automatically
	+ by the simplifier.
	+ \<close>
	+
	+ lemma canonically_isomorphicI:
	+ assumes "f = \<lbrace>t\<rbrace>" and "g = \<lbrace>u\<rbrace>" and "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
	+ shows "f \<cong> g"
	+ proof -
	+ have "f \<cong> \<lbrace>t\<rbrace>"
	+ using assms isomorphic_reflexive ide_eval_Ide by blast
	+ also have "... \<cong> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
	+ proof -
	+ have "\<guillemotleft>\<lbrace>t\<^bold>\<down>\<rbrace> : \<lbrace>t\<rbrace> \<Rightarrow> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>\<guillemotright> \<and> iso \<lbrace>t\<^bold>\<down>\<rbrace>"
	+ using assms(1,3) Can_red iso_eval_Can red_in_Hom(2) eval_in_hom(2) by fastforce
	+ thus ?thesis
	+ using isomorphic_def by blast
	+ qed
	+ also have "... \<cong> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>"
	+ using assms isomorphic_reflexive
	+ by (simp add: Ide_Nmlize_Ide ide_eval_Ide)
	+ also have "... \<cong> \<lbrace>u\<rbrace>"
	+ proof -
	+ have "\<guillemotleft>\<lbrace>u\<^bold>\<down>\<rbrace> : \<lbrace>u\<rbrace> \<Rightarrow> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>\<guillemotright> \<and> iso \<lbrace>u\<^bold>\<down>\<rbrace>"
	+ using assms(2,4) Can_red iso_eval_Can red_in_Hom(2) eval_in_hom(2) by fastforce
	+ thus ?thesis
	+ using isomorphic_def isomorphic_symmetric by blast
	+ qed
	+ also have "... \<cong> g"
	+ using assms isomorphic_reflexive ide_eval_Ide by blast
	+ finally show ?thesis by simp
	+ qed
	+
	+ end
	+
	+end
	diff --git a/thys/Bicategory/ConcreteCategory.thy b/thys/Bicategory/ConcreteCategory.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/ConcreteCategory.thy
	@@ -0,0 +1,420 @@
	+(* Title: ConcreteCategory
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Concrete Categories"
	+
	+text \<open>
	+ This theory developed in this section provides a uniform way to construct a category from
	+ specified sets of objects and arrows, and proves that the identities and arrows of the
	+ constructed category are appropriately in bijective correspondence with the given sets.
	+ This is a general tool that would more properly appear in @{session \<open>Category3\<close>}
	+ (see \cite{Category3-AFP}) and it will likely eventually be moved there.
	+\<close>
	+
	+theory ConcreteCategory
	+imports Category3.Category
	+begin
	+
	+ datatype ('o, 'a) arr =
	+ Null
	+ \| MkArr 'o 'o 'a
	+
	+ locale concrete_category =
	+ fixes Obj :: "'o set"
	+ and Hom :: "'o \<Rightarrow> 'o \<Rightarrow> 'a set"
	+ and Id :: "'o \<Rightarrow> 'a"
	+ and Comp :: "'o \<Rightarrow> 'o \<Rightarrow> 'o \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow>'a"
	+ assumes Id_in_Hom: "A \<in> Obj \<Longrightarrow> Id A \<in> Hom A A"
	+ and Comp_in_Hom: "\<lbrakk> A \<in> Obj; B \<in> Obj; C \<in> Obj; f \<in> Hom A B; g \<in> Hom B C \<rbrakk>
	+ \<Longrightarrow> Comp C B A g f \<in> Hom A C"
	+ and Comp_Hom_Id: "\<lbrakk> A \<in> Obj; f \<in> Hom A B \<rbrakk> \<Longrightarrow> Comp B A A f (Id A) = f"
	+ and Comp_Id_Hom: "\<lbrakk> B \<in> Obj; f \<in> Hom A B \<rbrakk> \<Longrightarrow> Comp B B A (Id B) f = f"
	+ and Comp_assoc: "\<lbrakk> A \<in> Obj; B \<in> Obj; C \<in> Obj; D \<in> Obj;
	+ f \<in> Hom A B; g \<in> Hom B C; h \<in> Hom C D \<rbrakk> \<Longrightarrow>
	+ Comp D C A h (Comp C B A g f) = Comp D B A (Comp D C B h g) f"
	+ begin
	+
	+ abbreviation MkIde :: "'o \<Rightarrow> ('o, 'a) arr"
	+ where "MkIde A \<equiv> MkArr A A (Id A)"
	+
	+ fun Dom :: "('o, 'a) arr \<Rightarrow> 'o"
	+ where "Dom (MkArr A _ _) = A"
	+ \| "Dom _ = undefined"
	+
	+ fun Cod
	+ where "Cod (MkArr _ B _) = B"
	+ \| "Cod _ = undefined"
	+
	+ fun Map
	+ where "Map (MkArr _ _ F) = F"
	+ \| "Map _ = undefined"
	+
	+ abbreviation Arr
	+ where "Arr f \<equiv> f \<noteq> Null \<and> Dom f \<in> Obj \<and> Cod f \<in> Obj \<and> Map f \<in> Hom (Dom f) (Cod f)"
	+
	+ abbreviation Ide
	+ where "Ide a \<equiv> a \<noteq> Null \<and> Dom a \<in> Obj \<and> Cod a = Dom a \<and> Map a = Id (Dom a)"
	+
	+ definition comp :: "('o, 'a) arr comp"
	+ where "comp g f \<equiv> if Arr f \<and> Arr g \<and> Dom g = Cod f then
	+ MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
	+ else
	+ Null"
	+
	+ interpretation partial_magma comp
	+ using comp_def by (unfold_locales, metis)
	+
	+ lemma null_char:
	+ shows "null = Null"
	+ proof -
	+ let ?P = "\<lambda>n. \<forall>f. comp n f = n \<and> comp f n = n"
	+ have "Null = null"
	+ using comp_def null_def the1_equality [of ?P] by metis
	+ thus ?thesis by simp
	+ qed
	+
	+ lemma ide_char:
	+ shows "ide f \<longleftrightarrow> Ide f"
	+ proof
	+ assume f: "Ide f"
	+ show "ide f"
	+ proof (unfold ide_def)
	+ have "comp f f \<noteq> null"
	+ using f comp_def null_char Id_in_Hom by auto
	+ moreover have "\<forall>g. (comp g f \<noteq> null \<longrightarrow> comp g f = g) \<and>
	+ (comp f g \<noteq> null \<longrightarrow> comp f g = g)"
	+ proof
	+ fix g
	+ have "comp g f \<noteq> null \<longrightarrow> comp g f = g"
	+ using f comp_def null_char Comp_Hom_Id Id_in_Hom
	+ by (cases g, auto)
	+ moreover have "comp f g \<noteq> null \<longrightarrow> comp f g = g"
	+ using f comp_def null_char Comp_Id_Hom Id_in_Hom
	+ by (cases g, auto)
	+ ultimately show "(comp g f \<noteq> null \<longrightarrow> comp g f = g) \<and>
	+ (comp f g \<noteq> null \<longrightarrow> comp f g = g)"
	+ by blast
	+ qed
	+ ultimately show "comp f f \<noteq> null \<and>
	+ (\<forall>g. (comp g f \<noteq> null \<longrightarrow> comp g f = g) \<and>
	+ (comp f g \<noteq> null \<longrightarrow> comp f g = g))"
	+ by blast
	+ qed
	+ next
	+ assume f: "ide f"
	+ have 1: "Arr f \<and> Dom f = Cod f"
	+ using f ide_def comp_def null_char by metis
	+ moreover have "Map f = Id (Dom f)"
	+ proof -
	+ let ?g = "MkIde (Dom f)"
	+ have g: "Arr f \<and> Arr ?g \<and> Dom ?g = Cod f"
	+ using 1 Id_in_Hom
	+ by (intro conjI, simp_all)
	+ hence 2: "comp ?g f \<noteq> null"
	+ using 1 comp_def null_char by simp
	+ have "comp ?g f = MkArr (Dom f) (Dom f) (Map f)"
	+ using g comp_def Comp_Id_Hom by auto
	+ moreover have "comp ?g f = ?g"
	+ using f 2 ide_def by blast
	+ ultimately show ?thesis by simp
	+ qed
	+ ultimately show "Ide f" by auto
	+ qed
	+
	+ lemma ide_MkIde [simp]:
	+ assumes "A \<in> Obj"
	+ shows "ide (MkIde A)"
	+ using assms ide_char Id_in_Hom by simp
	+
	+ lemma in_domains_char:
	+ shows "a \<in> domains f \<longleftrightarrow> Arr f \<and> a = MkIde (Dom f)"
	+ proof
	+ assume a: "a \<in> domains f"
	+ have "Ide a"
	+ using a domains_def ide_char comp_def null_char by auto
	+ moreover have "Arr f \<and> Dom f = Cod a"
	+ proof -
	+ have "comp f a \<noteq> null"
	+ using a domains_def by simp
	+ thus ?thesis
	+ using a domains_def comp_def [of f a] null_char by metis
	+ qed
	+ ultimately show "Arr f \<and> a = MkIde (Dom f)"
	+ by (cases a, auto)
	+ next
	+ assume a: "Arr f \<and> a = MkIde (Dom f)"
	+ show "a \<in> domains f"
	+ using a Id_in_Hom comp_def null_char domains_def by auto
	+ qed
	+
	+ lemma in_codomains_char:
	+ shows "b \<in> codomains f \<longleftrightarrow> Arr f \<and> b = MkIde (Cod f)"
	+ proof
	+ assume b: "b \<in> codomains f"
	+ have "Ide b"
	+ using b codomains_def ide_char comp_def null_char by auto
	+ moreover have "Arr f \<and> Dom b = Cod f"
	+ proof -
	+ have "comp b f \<noteq> null"
	+ using b codomains_def by simp
	+ thus ?thesis
	+ using b codomains_def comp_def [of b f] null_char by metis
	+ qed
	+ ultimately show "Arr f \<and> b = MkIde (Cod f)"
	+ by (cases b, auto)
	+ next
	+ assume b: "Arr f \<and> b = MkIde (Cod f)"
	+ show "b \<in> codomains f"
	+ using b Id_in_Hom comp_def null_char codomains_def by auto
	+ qed
	+
	+ lemma arr_char:
	+ shows "arr f \<longleftrightarrow> Arr f"
	+ using arr_def in_domains_char in_codomains_char by auto
	+
	+ lemma arrI:
	+ assumes "f \<noteq> Null" and "Dom f \<in> Obj" "Cod f \<in> Obj" "Map f \<in> Hom (Dom f) (Cod f)"
	+ shows "arr f"
	+ using assms arr_char by blast
	+
	+ lemma arrE:
	+ assumes "arr f"
	+ and "\<lbrakk> f \<noteq> Null; Dom f \<in> Obj; Cod f \<in> Obj; Map f \<in> Hom (Dom f) (Cod f) \<rbrakk> \<Longrightarrow> T"
	+ shows T
	+ using assms arr_char by simp
	+
	+ lemma arr_MkArr [simp]:
	+ assumes "A \<in> Obj" and "B \<in> Obj" and "f \<in> Hom A B"
	+ shows "arr (MkArr A B f)"
	+ using assms arr_char by simp
	+
	+ lemma MkArr_Map:
	+ assumes "arr f"
	+ shows "MkArr (Dom f) (Cod f) (Map f) = f"
	+ using assms arr_char by (cases f, auto)
	+
	+ lemma Arr_comp:
	+ assumes "arr f" and "arr g" and "Dom g = Cod f"
	+ shows "Arr (comp g f)"
	+ unfolding comp_def
	+ using assms arr_char Comp_in_Hom by simp
	+
	+ lemma Dom_comp [simp]:
	+ assumes "arr f" and "arr g" and "Dom g = Cod f"
	+ shows "Dom (comp g f) = Dom f"
	+ unfolding comp_def
	+ using assms arr_char by simp
	+
	+ lemma Cod_comp [simp]:
	+ assumes "arr f" and "arr g" and "Dom g = Cod f"
	+ shows "Cod (comp g f) = Cod g"
	+ unfolding comp_def
	+ using assms arr_char by simp
	+
	+ lemma Map_comp [simp]:
	+ assumes "arr f" and "arr g" and "Dom g = Cod f"
	+ shows "Map (comp g f) = Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f)"
	+ unfolding comp_def
	+ using assms arr_char by simp
	+
	+ lemma seq_char:
	+ shows "seq g f \<longleftrightarrow> arr f \<and> arr g \<and> Dom g = Cod f"
	+ using arr_char not_arr_null null_char comp_def Arr_comp by metis
	+
	+ interpretation category comp
	+ proof
	+ show "\<And>g f. comp g f \<noteq> null \<Longrightarrow> seq g f"
	+ using arr_char comp_def null_char Comp_in_Hom by auto
	+ show 1: "\<And>f. (domains f \<noteq> {}) = (codomains f \<noteq> {})"
	+ using in_domains_char in_codomains_char by auto
	+ show "\<And>f g h. seq h g \<Longrightarrow> seq (comp h g) f \<Longrightarrow> seq g f"
	+ by (auto simp add: seq_char)
	+ show "\<And>f g h. seq h (comp g f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
	+ using seq_char comp_def Comp_in_Hom by (metis Cod_comp)
	+ show "\<And>f g h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (comp h g) f"
	+ using Comp_in_Hom
	+ by (auto simp add: comp_def seq_char)
	+ show "\<And>g f h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> comp (comp h g) f = comp h (comp g f)"
	+ using seq_char comp_def Comp_assoc Comp_in_Hom Dom_comp Cod_comp Map_comp
	+ by auto
	+ qed
	+
	+ proposition is_category:
	+ shows "category comp"
	+ ..
	+
	+ lemma dom_char:
	+ shows "dom f = (if arr f then MkIde (Dom f) else null)"
	+ using dom_def in_domains_char dom_in_domains has_domain_iff_arr by auto
	+
	+ lemma cod_char:
	+ shows "cod f = (if arr f then MkIde (Cod f) else null)"
	+ using cod_def in_codomains_char cod_in_codomains has_codomain_iff_arr by auto
	+
	+ lemma comp_char:
	+ shows "comp g f = (if seq g f then
	+ MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
	+ else
	+ null)"
	+ using comp_def seq_char arr_char null_char by auto
	+
	+ lemma in_hom_char:
	+ shows "in_hom f a b \<longleftrightarrow> arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b"
	+ proof
	+ show "in_hom f a b \<Longrightarrow> arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b"
	+ using arr_char dom_char cod_char by auto
	+ show "arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b \<Longrightarrow> in_hom f a b"
	+ using arr_char dom_char cod_char ide_char Id_in_Hom MkArr_Map in_homI by metis
	+ qed
	+
	+ lemma Dom_in_Obj:
	+ assumes "arr f"
	+ shows "Dom f \<in> Obj"
	+ using assms arr_char by simp
	+
	+ lemma Cod_in_Obj:
	+ assumes "arr f"
	+ shows "Cod f \<in> Obj"
	+ using assms arr_char by simp
	+
	+ lemma Map_in_Hom:
	+ assumes "arr f"
	+ shows "Map f \<in> Hom (Dom f) (Cod f)"
	+ using assms arr_char by simp
	+
	+ lemma MkArr_in_hom:
	+ assumes "A \<in> Obj" and "B \<in> Obj" and "f \<in> Hom A B"
	+ shows "in_hom (MkArr A B f) (MkIde A) (MkIde B)"
	+ using assms arr_char dom_char cod_char ide_MkIde by auto
	+
	+ lemma Dom_dom [simp]:
	+ assumes "arr f"
	+ shows "Dom (dom f) = Dom f"
	+ using assms MkArr_Map dom_char by simp
	+
	+ lemma Cod_dom [simp]:
	+ assumes "arr f"
	+ shows "Cod (dom f) = Dom f"
	+ using assms MkArr_Map dom_char by simp
	+
	+ lemma Dom_cod [simp]:
	+ assumes "arr f"
	+ shows "Dom (cod f) = Cod f"
	+ using assms MkArr_Map cod_char by simp
	+
	+ lemma Cod_cod [simp]:
	+ assumes "arr f"
	+ shows "Cod (cod f) = Cod f"
	+ using assms MkArr_Map cod_char by simp
	+
	+ lemma Map_dom [simp]:
	+ assumes "arr f"
	+ shows "Map (dom f) = Id (Dom f)"
	+ using assms MkArr_Map dom_char by simp
	+
	+ lemma Map_cod [simp]:
	+ assumes "arr f"
	+ shows "Map (cod f) = Id (Cod f)"
	+ using assms MkArr_Map cod_char by simp
	+
	+ lemma Map_ide:
	+ assumes "ide a"
	+ shows "Map a = Id (Dom a)" and "Map a = Id (Cod a)"
	+ proof -
	+ show "Map a = Id (Dom a)"
	+ using assms ide_char dom_char [of a] Map_dom ideD(1) by metis
	+ show "Map a = Id (Cod a)"
	+ using assms ide_char dom_char [of a] Map_cod ideD(1) by metis
	+ qed
	+
	+ (*
	+ * TODO: The next two ought to be simps, but they cause looping when they find themselves
	+ * in combination with dom_char and cod_char.
	+ *)
	+ lemma MkIde_Dom:
	+ assumes "arr a"
	+ shows "MkIde (Dom a) = dom a"
	+ using assms arr_char dom_char by (cases a, auto)
	+
	+ lemma MkIde_Cod:
	+ assumes "arr a"
	+ shows "MkIde (Cod a) = cod a"
	+ using assms arr_char cod_char by (cases a, auto)
	+
	+ lemma MkIde_Dom' [simp]:
	+ assumes "ide a"
	+ shows "MkIde (Dom a) = a"
	+ using assms MkIde_Dom by simp
	+
	+ lemma MkIde_Cod' [simp]:
	+ assumes "ide a"
	+ shows "MkIde (Cod a) = a"
	+ using assms MkIde_Cod by simp
	+
	+ lemma dom_MkArr [simp]:
	+ assumes "arr (MkArr A B F)"
	+ shows "dom (MkArr A B F) = MkIde A"
	+ using assms dom_char by simp
	+
	+ lemma cod_MkArr [simp]:
	+ assumes "arr (MkArr A B F)"
	+ shows "cod (MkArr A B F) = MkIde B"
	+ using assms cod_char by simp
	+
	+ lemma comp_MkArr [simp]:
	+ assumes "arr (MkArr A B F)" and "arr (MkArr B C G)"
	+ shows "comp (MkArr B C G) (MkArr A B F) = MkArr A C (Comp C B A G F)"
	+ using assms comp_char [of "MkArr B C G" "MkArr A B F"] by simp
	+
	+ proposition bij_betw_ide_Obj:
	+ shows "MkIde \<in> Obj \<rightarrow> Collect ide"
	+ and "Dom \<in> Collect ide \<rightarrow> Obj"
	+ and "A \<in> Obj \<Longrightarrow> Dom (MkIde A) = A"
	+ and "a \<in> Collect ide \<Longrightarrow> MkIde (Dom a) = a"
	+ and "bij_betw Dom (Collect ide) Obj"
	+ proof -
	+ show 1: "MkIde \<in> Obj \<rightarrow> Collect ide"
	+ using ide_MkIde by simp
	+ show 2: "Dom \<in> Collect ide \<rightarrow> Obj"
	+ using arr_char ideD(1) by simp
	+ show 3: "\<And>A. A \<in> Obj \<Longrightarrow> Dom (MkIde A) = A"
	+ by simp
	+ show 4: "\<And>a. a \<in> Collect ide \<Longrightarrow> MkIde (Dom a) = a"
	+ using MkIde_Dom by simp
	+ show "bij_betw Dom (Collect ide) Obj"
	+ using 1 2 3 4 bij_betwI by blast
	+ qed
	+
	+ proposition bij_betw_hom_Hom:
	+ assumes "ide a" and "ide b"
	+ shows "Map \<in> hom a b \<rightarrow> Hom (Dom a) (Dom b)"
	+ and "MkArr (Dom a) (Dom b) \<in> Hom (Dom a) (Dom b) \<rightarrow> hom a b"
	+ and "\<And>f. f \<in> hom a b \<Longrightarrow> MkArr (Dom a) (Dom b) (Map f) = f"
	+ and "\<And>F. F \<in> Hom (Dom a) (Dom b) \<Longrightarrow> Map (MkArr (Dom a) (Dom b) F) = F"
	+ and "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
	+ proof -
	+ show 1: "Map \<in> hom a b \<rightarrow> Hom (Dom a) (Dom b)"
	+ using Map_in_Hom cod_char dom_char in_hom_char by fastforce
	+ show 2: "MkArr (Dom a) (Dom b) \<in> Hom (Dom a) (Dom b) \<rightarrow> hom a b"
	+ using assms Dom_in_Obj MkArr_in_hom [of "Dom a" "Dom b"] by simp
	+ show 3: "\<And>f. f \<in> hom a b \<Longrightarrow> MkArr (Dom a) (Dom b) (Map f) = f"
	+ using MkArr_Map by auto
	+ show 4: "\<And>F. F \<in> Hom (Dom a) (Dom b) \<Longrightarrow> Map (MkArr (Dom a) (Dom b) F) = F"
	+ by simp
	+ show "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
	+ using 1 2 3 4 bij_betwI by blast
	+ qed
	+
	+ lemma arr_eqI:
	+ assumes "arr t" and "arr t'" and "Dom t = Dom t'" and "Cod t = Cod t'" and "Map t = Map t'"
	+ shows "t = t'"
	+ using assms MkArr_Map by metis
	+
	+ end
	+
	+ sublocale concrete_category \<subseteq> category comp
	+ using is_category by auto
	+
	+end
	diff --git a/thys/Bicategory/InternalAdjunction.thy b/thys/Bicategory/InternalAdjunction.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/InternalAdjunction.thy
	@@ -0,0 +1,3466 @@
	+(* Title: InternalAdjunction
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Adjunctions in a Bicategory"
	+
	+theory InternalAdjunction
	+imports CanonicalIsos Strictness
	+begin
	+
	+ text \<open>
	+ An \emph{internal adjunction} in a bicategory is a four-tuple \<open>(f, g, \<eta>, \<epsilon>)\<close>,
	+ where \<open>f\<close> and \<open>g\<close> are antiparallel 1-cells and \<open>\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>\<close> and
	+ \<open>\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g\<guillemotright>\<close> are 2-cells, such that the familiar ``triangle''
	+ (or ``zig-zag'') identities are satisfied. We state the triangle identities
	+ in two equivalent forms, each of which is convenient in certain situations.
	+ \<close>
	+
	+ locale adjunction_in_bicategory =
	+ adjunction_data_in_bicategory +
	+ assumes triangle_left: "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ and triangle_right: "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ begin
	+
	+ lemma triangle_left':
	+ shows "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] = f"
	+ using triangle_left triangle_equiv_form by simp
	+
	+ lemma triangle_right':
	+ shows "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
	+ using triangle_right triangle_equiv_form by simp
	+
	+ end
	+
	+ text \<open>
	+ Internal adjunctions have a number of properties, which we now develop,
	+ that generalize those of ordinary adjunctions involving functors and
	+ natural transformations.
	+ \<close>
	+
	+ context bicategory
	+ begin
	+
	+ lemma adjunction_unit_determines_counit:
	+ assumes "adjunction_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ and "adjunction_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g \<eta> \<epsilon>'"
	+ shows "\<epsilon> = \<epsilon>'"
	+ proof -
	+ interpret E: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using assms(1) by auto
	+ interpret E': adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'
	+ using assms(2) by auto
	+ text \<open>
	+ Note that since we want to prove the the result for an arbitrary bicategory,
	+ not just in for a strict bicategory, the calculation is a little more involved
	+ than one might expect from a treatment that suppresses canonical isomorphisms.
	+ \<close>
	+ have "\<epsilon> \<cdot> \<r>[f \<star> g] = \<r>[trg f] \<cdot> (\<epsilon> \<star> trg f)"
	+ using runit_naturality [of \<epsilon>] by simp
	+ have 1: "\<r>[f \<star> g] = (f \<star> \<r>[g]) \<cdot> \<a>[f, g, src g]"
	+ using E.antipar runit_hcomp by simp
	+
	+ have "\<epsilon> = \<epsilon> \<cdot> (f \<star> \<r>[g] \<cdot> (g \<star> \<epsilon>') \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g])"
	+ using E'.triangle_right' comp_arr_dom by simp
	+ also have "... = \<epsilon> \<cdot> (f \<star> \<r>[g]) \<cdot> (f \<star> g \<star> \<epsilon>') \<cdot> (f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ using E.antipar whisker_left hseqI' by simp
	+ also have "... = \<epsilon> \<cdot> ((f \<star> \<r>[g]) \<cdot> (f \<star> g \<star> \<epsilon>')) \<cdot> (f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ using comp_assoc by simp
	+ also have "... = \<epsilon> \<cdot> \<r>[f \<star> g] \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, src g] \<cdot> (f \<star> g \<star> \<epsilon>')) \<cdot>
	+ (f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ proof -
	+ have "f \<star> \<r>[g] = \<r>[f \<star> g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, src g]"
	+ using E.antipar(1) runit_hcomp(3) by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (\<epsilon> \<cdot> \<r>[f \<star> g]) \<cdot> ((f \<star> g) \<star> \<epsilon>') \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
	+ (f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ using E.antipar E'.counit_in_hom assoc'_naturality [of f g \<epsilon>'] comp_assoc by simp
	+ also have "... = \<r>[trg f] \<cdot> ((\<epsilon> \<star> trg f) \<cdot> ((f \<star> g) \<star> \<epsilon>')) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
	+ (f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ using E.antipar E.counit_in_hom runit_naturality [of \<epsilon>] comp_assoc by simp
	+ also have "... = (\<l>[src g] \<cdot> (src g \<star> \<epsilon>')) \<cdot> (\<epsilon> \<star> f \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
	+ (f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ proof -
	+ have "(\<epsilon> \<star> trg f) \<cdot> ((f \<star> g) \<star> \<epsilon>') = (src g \<star> \<epsilon>') \<cdot> (\<epsilon> \<star> f \<star> g)"
	+ using E.antipar interchange E.counit_in_hom comp_arr_dom comp_cod_arr
	+ by (metis E'.counit_simps(1-3) E.counit_simps(1-3))
	+ thus ?thesis
	+ using E.antipar comp_assoc unitor_coincidence by simp
	+ qed
	+ also have "... = \<epsilon>' \<cdot> \<l>[f \<star> g] \<cdot> (\<epsilon> \<star> f \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
	+ (f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ proof -
	+ have "\<l>[src g] \<cdot> (src g \<star> \<epsilon>') = \<epsilon>' \<cdot> \<l>[f \<star> g]"
	+ using E.antipar lunit_naturality [of \<epsilon>'] by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<epsilon>' \<cdot> (\<l>[f] \<star> g) \<cdot> (\<a>\<^sup>-\<^sup>1[trg f, f, g] \<cdot> (\<epsilon> \<star> f \<star> g)) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
	+ (f \<star> \<a>[g, f, g]) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ using E.antipar lunit_hcomp comp_assoc by simp
	+ also have "... = \<epsilon>' \<cdot> (\<l>[f] \<star> g) \<cdot> ((\<epsilon> \<star> f) \<star> g) \<cdot> (\<a>\<^sup>-\<^sup>1[f \<star> g, f, g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot>
	+ (f \<star> \<a>[g, f, g])) \<cdot> (f \<star> \<eta> \<star> g) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ using E.antipar assoc'_naturality [of \<epsilon> f g] comp_assoc by simp
	+ also have "... = \<epsilon>' \<cdot> (\<l>[f] \<star> g) \<cdot> ((\<epsilon> \<star> f) \<star> g) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> g) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g \<star> f, g] \<cdot> (f \<star> \<eta> \<star> g)) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[f \<star> g, f, g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g] \<cdot> (f \<star> \<a>[g, f, g]) =
	+ (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> f, g]"
	+ using 1 E.antipar iso_assoc' iso_inv_iso pentagon' comp_assoc
	+ invert_side_of_triangle(2)
	+ [of "\<a>\<^sup>-\<^sup>1[f \<star> g, f, g] \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> g]"
	+ "(\<a>\<^sup>-\<^sup>1[f, g, f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> f, g]" "f \<star> \<a>\<^sup>-\<^sup>1[g, f, g]"]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<epsilon>' \<cdot> (\<l>[f] \<star> g) \<cdot> ((\<epsilon> \<star> f) \<star> g) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> g) \<cdot>
	+ ((f \<star> \<eta>) \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[f, trg g, g] \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ using E.antipar assoc'_naturality [of f \<eta> g] comp_assoc by simp
	+ also have "... = \<epsilon>' \<cdot> (\<l>[f] \<star> g) \<cdot> ((\<epsilon> \<star> f) \<star> g) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> g) \<cdot>
	+ ((f \<star> \<eta>) \<star> g) \<cdot> (\<r>\<^sup>-\<^sup>1[f] \<star> g)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[f, trg g, g] \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g]) = \<r>\<^sup>-\<^sup>1[f] \<star> g"
	+ proof -
	+ have "\<r>\<^sup>-\<^sup>1[f] \<star> g = inv (\<r>[f] \<star> g)"
	+ using E.antipar by simp
	+ also have "... = inv ((f \<star> \<l>[g]) \<cdot> \<a>[f, trg g, g])"
	+ using E.antipar by (simp add: triangle)
	+ also have "... = \<a>\<^sup>-\<^sup>1[f, trg g, g] \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[g])"
	+ using E.antipar hseqI' inv_comp by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<epsilon>' \<cdot> (\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] \<star> g)"
	+ using E.antipar whisker_right hseqI' by simp
	+ also have "... = \<epsilon>'"
	+ using E.triangle_left' comp_arr_dom by simp
	+ finally show ?thesis by simp
	+ qed
	+
	+ end
	+
	+ subsection "Adjoint Transpose"
	+
	+ context adjunction_in_bicategory
	+ begin
	+
	+ interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ text \<open>
	+ Just as for an ordinary adjunction between categories, an adjunction in a bicategory
	+ determines bijections between hom-sets. There are two versions of this relationship:
	+ depending on whether the transposition is occurring on the left (\emph{i.e.}~``output'')
	+ side or the right (\emph{i.e.}~``input'') side.
	+ \<close>
	+
	+ definition trnl\<^sub>\<eta>
	+ where "trnl\<^sub>\<eta> v \<mu> \<equiv> (g \<star> \<mu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
	+
	+ definition trnl\<^sub>\<epsilon>
	+ where "trnl\<^sub>\<epsilon> u \<nu> \<equiv> \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> \<nu>)"
	+
	+ lemma adjoint_transpose_left:
	+ assumes "ide u" and "ide v" and "src f = trg v" and "src g = trg u"
	+ shows "trnl\<^sub>\<eta> v \<in> hom (f \<star> v) u \<rightarrow> hom v (g \<star> u)"
	+ and "trnl\<^sub>\<epsilon> u \<in> hom v (g \<star> u) \<rightarrow> hom (f \<star> v) u"
	+ and "\<guillemotleft>\<mu> : f \<star> v \<Rightarrow> u\<guillemotright> \<Longrightarrow> trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> v \<mu>) = \<mu>"
	+ and "\<guillemotleft>\<nu> : v \<Rightarrow> g \<star> u\<guillemotright> \<Longrightarrow> trnl\<^sub>\<eta> v (trnl\<^sub>\<epsilon> u \<nu>) = \<nu>"
	+ and "bij_betw (trnl\<^sub>\<eta> v) (hom (f \<star> v) u) (hom v (g \<star> u))"
	+ and "bij_betw (trnl\<^sub>\<epsilon> u) (hom v (g \<star> u)) (hom (f \<star> v) u)"
	+ proof -
	+ show A: "trnl\<^sub>\<eta> v \<in> hom (f \<star> v) u \<rightarrow> hom v (g \<star> u)"
	+ using assms antipar trnl\<^sub>\<eta>_def by fastforce
	+ show B: "trnl\<^sub>\<epsilon> u \<in> hom v (g \<star> u) \<rightarrow> hom (f \<star> v) u"
	+ using assms antipar trnl\<^sub>\<epsilon>_def by fastforce
	+ show C: "\<And>\<mu>. \<guillemotleft>\<mu> : f \<star> v \<Rightarrow> u\<guillemotright> \<Longrightarrow> trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> v \<mu>) = \<mu>"
	+ proof -
	+ fix \<mu>
	+ assume \<mu>: "\<guillemotleft>\<mu> : f \<star> v \<Rightarrow> u\<guillemotright>"
	+ have "trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> v \<mu>) =
	+ \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> (g \<star> \<mu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v])"
	+ using trnl\<^sub>\<eta>_def trnl\<^sub>\<epsilon>_def by simp
	+ also have "... = \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> g \<star> \<mu>)) \<cdot> (f \<star> \<a>[g, f, v]) \<cdot>
	+ (f \<star> \<eta> \<star> v) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[v])"
	+ using assms \<mu> antipar whisker_left comp_assoc hseqI' by auto
	+ also have "... = \<l>[u] \<cdot> ((\<epsilon> \<star> u) \<cdot> ((f \<star> g) \<star> \<mu>)) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) \<cdot>
	+ (f \<star> \<eta> \<star> v) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[v])"
	+ using assms \<mu> antipar assoc'_naturality [of f g \<mu>] comp_assoc by fastforce
	+ also have "... = \<l>[u] \<cdot> (trg u \<star> \<mu>) \<cdot>
	+ (\<epsilon> \<star> f \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) \<cdot>
	+ (f \<star> \<eta> \<star> v) \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[v])"
	+ proof -
	+ have "(\<epsilon> \<star> u) \<cdot> ((f \<star> g) \<star> \<mu>) = (trg u \<star> \<mu>) \<cdot> (\<epsilon> \<star> f \<star> v)"
	+ using assms \<mu> antipar comp_cod_arr comp_arr_dom
	+ interchange [of "trg u" \<epsilon> \<mu> "f \<star> v"] interchange [of \<epsilon> "f \<star> g" u \<mu>]
	+ by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<l>[u] \<cdot> (trg u \<star> \<mu>) \<cdot> \<a>[trg f, f, v] \<cdot>
	+ ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<star> v) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, trg v, v] \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[v])"
	+ proof -
	+ have 1: "(\<epsilon> \<star> f \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) \<cdot> (f \<star> \<eta> \<star> v) =
	+ \<a>[trg f, f, v] \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, trg v, v]"
	+ proof -
	+ have "(\<epsilon> \<star> f \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) \<cdot> (f \<star> \<eta> \<star> v) =
	+ (\<epsilon> \<star> f \<star> v) \<cdot>
	+ \<a>[f \<star> g, f, v] \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> f, v] \<cdot>
	+ (f \<star> \<eta> \<star> v)"
	+ proof -
	+ have "(\<epsilon> \<star> f \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) \<cdot> (f \<star> \<eta> \<star> v) =
	+ (\<epsilon> \<star> f \<star> v) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v])) \<cdot> (f \<star> \<eta> \<star> v)"
	+ using comp_assoc by simp
	+ also have "... = (\<epsilon> \<star> f \<star> v) \<cdot>
	+ \<a>[f \<star> g, f, v] \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> f, v] \<cdot>
	+ (f \<star> \<eta> \<star> v)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[f, g, f \<star> v] \<cdot> (f \<star> \<a>[g, f, v]) =
	+ \<a>[f \<star> g, f, v] \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, g \<star> f, v]"
	+ using assms antipar canI_associator_0 whisker_can_left_0 whisker_can_right_0
	+ canI_associator_hcomp(1-3)
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ also have "... = ((\<epsilon> \<star> f \<star> v) \<cdot> \<a>[f \<star> g, f, v]) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> ((f \<star> \<eta>) \<star> v) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, trg v, v]"
	+ using assms \<mu> antipar assoc'_naturality [of f \<eta> v] comp_assoc by simp
	+ also have "... = (\<a>[trg f, f, v] \<cdot> ((\<epsilon> \<star> f) \<star> v)) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> ((f \<star> \<eta>) \<star> v) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, trg v, v]"
	+ using assms \<mu> antipar assoc_naturality [of \<epsilon> f v] by simp
	+ also have "... = \<a>[trg f, f, v] \<cdot>
	+ (((\<epsilon> \<star> f) \<star> v) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<star> v) \<cdot> ((f \<star> \<eta>) \<star> v)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, trg v, v]"
	+ using comp_assoc by simp
	+ also have "... = \<a>[trg f, f, v] \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, trg v, v]"
	+ using assms \<mu> antipar whisker_right hseqI' by simp
	+ finally show ?thesis by simp
	+ qed
	+ show ?thesis
	+ using 1 comp_assoc by metis
	+ qed
	+ also have "... = \<l>[u] \<cdot> (trg u \<star> \<mu>) \<cdot>
	+ \<a>[trg f, f, v] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> v) \<cdot> \<a>\<^sup>-\<^sup>1[f, trg v, v] \<cdot> (f \<star> \<l>\<^sup>-\<^sup>1[v])"
	+ using assms \<mu> antipar triangle_left by simp
	+ also have "... = \<l>[u] \<cdot> (trg u \<star> \<mu>) \<cdot> can (\<^bold>\<langle>trg u\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>v\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>v\<^bold>\<rangle>)"
	+ using assms \<mu> antipar canI_unitor_0 canI_associator_1
	+ canI_associator_1(1-2) [of f v] whisker_can_right_0 whisker_can_left_0
	+ by simp
	+ also have "... = \<l>[u] \<cdot> (trg u \<star> \<mu>) \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> v]"
	+ unfolding can_def using assms antipar comp_arr_dom comp_cod_arr \<ll>_ide_simp
	+ by simp
	+ also have "... = (\<l>[u] \<cdot> \<l>\<^sup>-\<^sup>1[u]) \<cdot> \<mu>"
	+ using assms \<mu> lunit'_naturality [of \<mu>] comp_assoc by auto
	+ also have "... = \<mu>"
	+ using assms \<mu> comp_cod_arr iso_lunit comp_arr_inv inv_is_inverse by auto
	+ finally show "trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> v \<mu>) = \<mu>" by simp
	+ qed
	+ show D: "\<And>\<nu>. \<guillemotleft>\<nu> : v \<Rightarrow> g \<star> u\<guillemotright> \<Longrightarrow> trnl\<^sub>\<eta> v (trnl\<^sub>\<epsilon> u \<nu>) = \<nu>"
	+ proof -
	+ fix \<nu>
	+ assume \<nu>: "\<guillemotleft>\<nu> : v \<Rightarrow> g \<star> u\<guillemotright>"
	+ have "trnl\<^sub>\<eta> v (trnl\<^sub>\<epsilon> u \<nu>) =
	+ (g \<star> \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> \<nu>)) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
	+ using trnl\<^sub>\<eta>_def trnl\<^sub>\<epsilon>_def by simp
	+ also have "... = (g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> (g \<star> f \<star> \<nu>) \<cdot>
	+ \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
	+ using assms \<nu> antipar interchange [of g "g \<cdot> g \<cdot> g"] comp_assoc hseqI' by auto
	+ also have "... = ((g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot>
	+ \<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u)) \<cdot> (trg v \<star> \<nu>) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
	+ proof -
	+ have "(g \<star> f \<star> \<nu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v] =
	+ \<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u) \<cdot> (trg v \<star> \<nu>) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
	+ proof -
	+ have "(g \<star> f \<star> \<nu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v] =
	+ \<a>[g, f, g \<star> u] \<cdot> ((g \<star> f) \<star> \<nu>) \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
	+ proof -
	+ have "(g \<star> f \<star> \<nu>) \<cdot> \<a>[g, f, v] = \<a>[g, f, g \<star> u] \<cdot> ((g \<star> f) \<star> \<nu>)"
	+ using assms \<nu> antipar assoc_naturality [of g f \<nu>] by auto
	+ thus ?thesis
	+ using assms comp_assoc by metis
	+ qed
	+ also have "... = \<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u) \<cdot> (trg v \<star> \<nu>) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
	+ proof -
	+ have "((g \<star> f) \<star> \<nu>) \<cdot> (\<eta> \<star> v) = (\<eta> \<star> g \<star> u) \<cdot> (trg v \<star> \<nu>)"
	+ using assms \<nu> antipar comp_arr_dom comp_cod_arr
	+ interchange [of "g \<star> f" \<eta> \<nu> v] interchange [of \<eta> "trg v" "g \<star> u" \<nu>]
	+ by auto
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis using comp_assoc by simp
	+ qed
	+ also have "... = \<l>[g \<star> u] \<cdot> (trg v \<star> \<nu>) \<cdot> \<l>\<^sup>-\<^sup>1[v]"
	+ proof -
	+ have "(g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u) =
	+ \<l>[g \<star> u]"
	+ proof -
	+ have "(g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u) =
	+ (g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot>
	+ ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<star> u) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[trg v, g, u]"
	+ proof -
	+ have "(g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> (\<eta> \<star> g \<star> u) =
	+ (g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot>
	+ ((\<eta> \<star> g \<star> u) \<cdot> \<a>[trg v, g, u]) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
	+ using assms antipar comp_arr_dom comp_assoc hseqI' comp_assoc_assoc'(1) by simp
	+ also have "... = (g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot>
	+ (\<a>[g \<star> f, g, u] \<cdot> ((\<eta> \<star> g) \<star> u)) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
	+ using assms antipar assoc_naturality [of \<eta> g u] by simp
	+ also have "... = (g \<star> \<l>[u]) \<cdot> (g \<star> \<epsilon> \<star> u) \<cdot>
	+ ((g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u]) \<cdot>
	+ ((\<eta> \<star> g) \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
	+ using comp_assoc by simp
	+ also have "... = (g \<star> \<l>[u]) \<cdot> ((\<a>[g, trg u, u] \<cdot> \<a>\<^sup>-\<^sup>1[g, trg u, u]) \<cdot> (g \<star> \<epsilon> \<star> u)) \<cdot>
	+ ((g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u]) \<cdot>
	+ ((\<eta> \<star> g) \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
	+ proof -
	+ have "(\<a>[g, trg u, u] \<cdot> \<a>\<^sup>-\<^sup>1[g, trg u, u]) \<cdot> (g \<star> \<epsilon> \<star> u) = g \<star> \<epsilon> \<star> u"
	+ using assms antipar comp_cod_arr hseqI' comp_assoc_assoc'(1) by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot> (\<a>\<^sup>-\<^sup>1[g, trg u, u] \<cdot> (g \<star> \<epsilon> \<star> u)) \<cdot>
	+ (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u] \<cdot>
	+ ((\<eta> \<star> g) \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
	+ using comp_assoc by simp
	+ also have "... = (g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot> (((g \<star> \<epsilon>) \<star> u) \<cdot> (\<a>\<^sup>-\<^sup>1[g, f \<star> g, u] \<cdot>
	+ (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u]) \<cdot>
	+ ((\<eta> \<star> g) \<star> u)) \<cdot> \<a>\<^sup>-\<^sup>1[trg v, g, u]"
	+ using assms antipar assoc'_naturality [of g \<epsilon> u] comp_assoc by simp
	+ also have "... = (g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot>
	+ ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<star> u) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[trg v, g, u]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[g, f \<star> g, u] \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u] =
	+ \<a>[g, f, g] \<star> u"
	+ using assms antipar canI_associator_0 whisker_can_left_0 whisker_can_right_0
	+ canI_associator_hcomp
	+ by simp
	+ hence "((g \<star> \<epsilon>) \<star> u) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[g, f \<star> g, u] \<cdot> (g \<star> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> \<a>[g, f, g \<star> u] \<cdot> \<a>[g \<star> f, g, u]) \<cdot>
	+ ((\<eta> \<star> g) \<star> u) =
	+ (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<star> u"
	+ using assms antipar whisker_right hseqI' by simp
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ also have "... = (g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot> (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg g, g, u]"
	+ using assms antipar triangle_right by simp
	+ also have "... = can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>) (\<^bold>\<langle>trg g\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>)"
	+ proof -
	+ have "(g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot> (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg g, g, u] =
	+ ((g \<star> \<l>[u]) \<cdot> \<a>[g, trg u, u] \<cdot> (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[trg g, g, u])"
	+ using comp_assoc by simp
	+ moreover have "... = can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>) (\<^bold>\<langle>trg g\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>u\<^bold>\<rangle>)"
	+ using assms antipar canI_unitor_0 canI_associator_1 [of g u] inv_can
	+ whisker_can_left_0 whisker_can_right_0
	+ by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = \<l>[g \<star> u]"
	+ unfolding can_def using assms comp_arr_dom comp_cod_arr \<ll>_ide_simp by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (\<l>[g \<star> u] \<cdot> \<l>\<^sup>-\<^sup>1[g \<star> u]) \<cdot> \<nu>"
	+ using assms \<nu> lunit'_naturality comp_assoc by auto
	+ also have "... = \<nu>"
	+ using assms \<nu> comp_cod_arr iso_lunit comp_arr_inv inv_is_inverse by auto
	+ finally show "trnl\<^sub>\<eta> v (trnl\<^sub>\<epsilon> u \<nu>) = \<nu>" by simp
	+ qed
	+ show "bij_betw (trnl\<^sub>\<eta> v) (hom (f \<star> v) u) (hom v (g \<star> u))"
	+ using A B C D by (intro bij_betwI, auto)
	+ show "bij_betw (trnl\<^sub>\<epsilon> u) (hom v (g \<star> u)) (hom (f \<star> v) u)"
	+ using A B C D by (intro bij_betwI, auto)
	+ qed
	+
	+ lemma trnl\<^sub>\<epsilon>_comp:
	+ assumes "ide u" and "seq \<mu> \<nu>" and "src f = trg \<mu>"
	+ shows "trnl\<^sub>\<epsilon> u (\<mu> \<cdot> \<nu>) = trnl\<^sub>\<epsilon> u \<mu> \<cdot> (f \<star> \<nu>)"
	+ using assms trnl\<^sub>\<epsilon>_def whisker_left [of f \<mu> \<nu>] comp_assoc by auto
	+
	+ definition trnr\<^sub>\<eta>
	+ where "trnr\<^sub>\<eta> v \<mu> \<equiv> (\<mu> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+
	+ definition trnr\<^sub>\<epsilon>
	+ where "trnr\<^sub>\<epsilon> u \<nu> \<equiv> \<r>[u] \<cdot> (u \<star> \<epsilon>) \<cdot> \<a>[u, f, g] \<cdot> (\<nu> \<star> g)"
	+
	+ lemma adjoint_transpose_right:
	+ assumes "ide u" and "ide v" and "src v = trg g" and "src u = trg f"
	+ shows "trnr\<^sub>\<eta> v \<in> hom (v \<star> g) u \<rightarrow> hom v (u \<star> f)"
	+ and "trnr\<^sub>\<epsilon> u \<in> hom v (u \<star> f) \<rightarrow> hom (v \<star> g) u"
	+ and "\<guillemotleft>\<mu> : v \<star> g \<Rightarrow> u\<guillemotright> \<Longrightarrow> trnr\<^sub>\<epsilon> u (trnr\<^sub>\<eta> v \<mu>) = \<mu>"
	+ and "\<guillemotleft>\<nu> : v \<Rightarrow> u \<star> f\<guillemotright> \<Longrightarrow> trnr\<^sub>\<eta> v (trnr\<^sub>\<epsilon> u \<nu>) = \<nu>"
	+ and "bij_betw (trnr\<^sub>\<eta> v) (hom (v \<star> g) u) (hom v (u \<star> f))"
	+ and "bij_betw (trnr\<^sub>\<epsilon> u) (hom v (u \<star> f)) (hom (v \<star> g) u)"
	+ proof -
	+ show A: "trnr\<^sub>\<eta> v \<in> hom (v \<star> g) u \<rightarrow> hom v (u \<star> f)"
	+ using assms antipar trnr\<^sub>\<eta>_def by fastforce
	+ show B: "trnr\<^sub>\<epsilon> u \<in> hom v (u \<star> f) \<rightarrow> hom (v \<star> g) u"
	+ using assms antipar trnr\<^sub>\<epsilon>_def by fastforce
	+ show C: "\<And>\<mu>. \<guillemotleft>\<mu> : v \<star> g \<Rightarrow> u\<guillemotright> \<Longrightarrow> trnr\<^sub>\<epsilon> u (trnr\<^sub>\<eta> v \<mu>) = \<mu>"
	+ proof -
	+ fix \<mu>
	+ assume \<mu>: "\<guillemotleft>\<mu> : v \<star> g \<Rightarrow> u\<guillemotright>"
	+ have "trnr\<^sub>\<epsilon> u (trnr\<^sub>\<eta> v \<mu>) =
	+ \<r>[u] \<cdot> (u \<star> \<epsilon>) \<cdot> \<a>[u, f, g] \<cdot> ((\<mu> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[v] \<star> g)"
	+ unfolding trnr\<^sub>\<epsilon>_def trnr\<^sub>\<eta>_def by simp
	+ also have "... = \<r>[u] \<cdot> (u \<star> \<epsilon>) \<cdot> (\<a>[u, f, g] \<cdot> ((\<mu> \<star> f) \<star> g)) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
	+ using assms \<mu> antipar whisker_right comp_assoc hseqI' by auto
	+ also have "... = \<r>[u] \<cdot> (u \<star> \<epsilon>) \<cdot> ((\<mu> \<star> f \<star> g) \<cdot> \<a>[v \<star> g, f, g]) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
	+ using assms \<mu> antipar assoc_naturality [of \<mu> f g] by auto
	+ also have "... = \<r>[u] \<cdot> ((u \<star> \<epsilon>) \<cdot> (\<mu> \<star> f \<star> g)) \<cdot> \<a>[v \<star> g, f, g] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
	+ using comp_assoc by auto
	+ also have "... = \<r>[u] \<cdot> (\<mu> \<star> src u) \<cdot> ((v \<star> g) \<star> \<epsilon>) \<cdot> \<a>[v \<star> g, f, g] \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
	+ proof -
	+ have "(u \<star> \<epsilon>) \<cdot> (\<mu> \<star> f \<star> g) = (\<mu> \<star> src u) \<cdot> ((v \<star> g) \<star> \<epsilon>)"
	+ using assms \<mu> antipar comp_arr_dom comp_cod_arr
	+ interchange [of \<mu> "v \<star> g" "src u" \<epsilon>] interchange [of u \<mu> \<epsilon> "f \<star> g"]
	+ by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<r>[u] \<cdot> (\<mu> \<star> src u) \<cdot>
	+ (((v \<star> g) \<star> \<epsilon>) \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g)) \<cdot>
	+ (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
	+ using comp_assoc by simp
	+ also have "... = \<r>[u] \<cdot> (\<mu> \<star> src u) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot>
	+ \<a>[v, src v, g]) \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
	+ proof -
	+ have "((v \<star> g) \<star> \<epsilon>) \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) =
	+ \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot> \<a>[v, src v, g]"
	+ proof -
	+ have "((v \<star> g) \<star> \<epsilon>) \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g) =
	+ ((\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> \<a>[v, g, src u]) \<cdot> ((v \<star> g) \<star> \<epsilon>)) \<cdot>
	+ \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g)"
	+ using assms antipar comp_cod_arr hseqI' comp_assoc_assoc'(2) by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (\<a>[v, g, src u] \<cdot> ((v \<star> g) \<star> \<epsilon>)) \<cdot>
	+ \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> ((v \<star> \<eta>) \<star> g)"
	+ using comp_assoc by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> ((v \<star> g \<star> \<epsilon>) \<cdot> \<a>[v, g, f \<star> g]) \<cdot>
	+ \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[v, g \<star> f, g] \<cdot> \<a>[v, g \<star> f, g]) \<cdot> ((v \<star> \<eta>) \<star> g)"
	+ proof -
	+ have "\<a>[v, g, src u] \<cdot> ((v \<star> g) \<star> \<epsilon>) = (v \<star> g \<star> \<epsilon>) \<cdot> \<a>[v, g, f \<star> g]"
	+ using assms antipar assoc_naturality [of v g \<epsilon>] by simp
	+ moreover have "(\<a>\<^sup>-\<^sup>1[v, g \<star> f, g] \<cdot> \<a>[v, g \<star> f, g]) \<cdot> ((v \<star> \<eta>) \<star> g) = (v \<star> \<eta>) \<star> g"
	+ using assms antipar comp_cod_arr hseqI' comp_assoc_assoc'(2) by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> g \<star> \<epsilon>) \<cdot>
	+ \<a>[v, g, f \<star> g] \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[v, g \<star> f, g] \<cdot> \<a>[v, g \<star> f, g] \<cdot> ((v \<star> \<eta>) \<star> g)"
	+ using comp_assoc by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> ((v \<star> g \<star> \<epsilon>) \<cdot>
	+ (\<a>[v, g, f \<star> g] \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[v, g \<star> f, g]) \<cdot> (v \<star> \<eta> \<star> g)) \<cdot> \<a>[v, src v, g]"
	+ using assms antipar assoc_naturality [of v \<eta> g] comp_assoc by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot>
	+ ((v \<star> g \<star> \<epsilon>) \<cdot> (v \<star> \<a>[g, f, g]) \<cdot> (v \<star> \<eta> \<star> g)) \<cdot>
	+ \<a>[v, src v, g]"
	+ proof -
	+ have "\<a>[v, g, f \<star> g] \<cdot> \<a>[v \<star> g, f, g] \<cdot> (\<a>\<^sup>-\<^sup>1[v, g, f] \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[v, g \<star> f, g] =
	+ v \<star> \<a>[g, f, g]"
	+ using assms antipar canI_associator_0 canI_associator_hcomp
	+ whisker_can_left_0 whisker_can_right_0
	+ by simp
	+ thus ?thesis
	+ using assms antipar whisker_left by simp
	+ qed
	+ also have "... = \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot>
	+ (v \<star> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot>
	+ \<a>[v, src v, g]"
	+ using assms antipar whisker_left hseqI' by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis by auto
	+ qed
	+ also have "... = \<r>[u] \<cdot> (\<mu> \<star> src u) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot>
	+ \<a>[v, src v, g] \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g)"
	+ using triangle_right comp_assoc by simp
	+ also have "... = \<r>[u] \<cdot> (\<mu> \<star> src u) \<cdot> \<r>\<^sup>-\<^sup>1[v \<star> g]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot> \<a>[v, src v, g] \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g) = \<r>\<^sup>-\<^sup>1[v \<star> g]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot> \<a>[v, src v, g] \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g) =
	+ \<a>\<^sup>-\<^sup>1[v, g, trg f] \<cdot> can (\<^bold>\<langle>v\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) (\<^bold>\<langle>v\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
	+ using assms canI_unitor_0 canI_associator_1(2-3) whisker_can_left_0(1)
	+ whisker_can_right_0
	+ by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[v, g, src g] \<cdot> can (\<^bold>\<langle>v\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) (\<^bold>\<langle>v\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
	+ using antipar by simp
	+ (* TODO: There should be an alternate version of whisker_can_left for this. *)
	+ also have "... = \<a>\<^sup>-\<^sup>1[v, g, src g] \<cdot> (v \<star> can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) \<^bold>\<langle>g\<^bold>\<rangle>)"
	+ using assms canI_unitor_0(2) whisker_can_left_0 by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[v, g, src g] \<cdot> (v \<star> \<r>\<^sup>-\<^sup>1[g])"
	+ using assms canI_unitor_0(2) by simp
	+ also have "... = \<r>\<^sup>-\<^sup>1[v \<star> g]"
	+ using assms runit_hcomp(2) by simp
	+ finally have "\<a>\<^sup>-\<^sup>1[v, g, src u] \<cdot> (v \<star> \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot> \<a>[v, src v, g] \<cdot> (\<r>\<^sup>-\<^sup>1[v] \<star> g) =
	+ \<r>\<^sup>-\<^sup>1[v \<star> g]"
	+ by simp
	+ thus ?thesis by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (\<r>[u] \<cdot> \<r>\<^sup>-\<^sup>1[u]) \<cdot> \<mu>"
	+ using assms \<mu> runit'_naturality [of \<mu>] comp_assoc by auto
	+ also have "... = \<mu>"
	+ using \<mu> comp_cod_arr iso_runit inv_is_inverse comp_arr_inv by auto
	+ finally show "trnr\<^sub>\<epsilon> u (trnr\<^sub>\<eta> v \<mu>) = \<mu>" by simp
	+ qed
	+ show D: "\<And>\<nu>. \<guillemotleft>\<nu> : v \<Rightarrow> u \<star> f\<guillemotright> \<Longrightarrow> trnr\<^sub>\<eta> v (trnr\<^sub>\<epsilon> u \<nu>) = \<nu>"
	+ proof -
	+ fix \<nu>
	+ assume \<nu>: "\<guillemotleft>\<nu> : v \<Rightarrow> u \<star> f\<guillemotright>"
	+ have "trnr\<^sub>\<eta> v (trnr\<^sub>\<epsilon> u \<nu>) =
	+ (\<r>[u] \<cdot> (u \<star> \<epsilon>) \<cdot> \<a>[u, f, g] \<cdot> (\<nu> \<star> g) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ unfolding trnr\<^sub>\<eta>_def trnr\<^sub>\<epsilon>_def by simp
	+ also have "... = (\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[u, f, g] \<star> f) \<cdot>
	+ (((\<nu> \<star> g) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f]) \<cdot> (v \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ using assms \<nu> antipar whisker_right [of f] comp_assoc hseqI' by auto
	+ also have "... = (\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[u, f, g] \<star> f) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[u \<star> f, g, f] \<cdot> (\<nu> \<star> g \<star> f)) \<cdot> (v \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ using assms \<nu> antipar assoc'_naturality [of \<nu> g f] by auto
	+ also have "... = (\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[u, f, g] \<star> f) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u \<star> f, g, f] \<cdot> ((\<nu> \<star> g \<star> f) \<cdot> (v \<star> \<eta>)) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ using comp_assoc by simp
	+ also have "... = (\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[u, f, g] \<star> f) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u \<star> f, g, f] \<cdot> (((u \<star> f) \<star> \<eta>) \<cdot> (\<nu> \<star> src v)) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ proof -
	+ have "(\<nu> \<star> g \<star> f) \<cdot> (v \<star> \<eta>) = ((u \<star> f) \<star> \<eta>) \<cdot> (\<nu> \<star> src v)"
	+ using assms \<nu> antipar interchange [of "u \<star> f" \<nu> \<eta> "src v"]
	+ interchange [of \<nu> v "g \<star> f" \<eta>] comp_arr_dom comp_cod_arr
	+ by auto
	+ thus ?thesis by simp
	+ qed
	+ also have "... = ((\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot>
	+ ((\<a>[u, f, g] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[u \<star> f, g, f]) \<cdot>
	+ ((u \<star> f) \<star> \<eta>)) \<cdot> (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ using comp_assoc by simp
	+ also have "... = ((\<r>[u] \<star> f) \<cdot> ((u \<star> \<epsilon>) \<star> f) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[u, f \<star> g, f] \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[f, g, f]) \<cdot> \<a>[u, f, g \<star> f]) \<cdot>
	+ ((u \<star> f) \<star> \<eta>)) \<cdot> (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ using assms antipar canI_associator_hcomp canI_associator_0 whisker_can_left_0
	+ whisker_can_right_0
	+ by simp
	+ also have "... = ((\<r>[u] \<star> f) \<cdot> (((u \<star> \<epsilon>) \<star> f) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[u, f \<star> g, f]) \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[f, g, f]) \<cdot> (\<a>[u, f, g \<star> f]) \<cdot>
	+ ((u \<star> f) \<star> \<eta>)) \<cdot> (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ using comp_assoc by simp
	+ also have "... = ((\<r>[u] \<star> f) \<cdot> (\<a>\<^sup>-\<^sup>1[u, src u, f] \<cdot> (u \<star> \<epsilon> \<star> f)) \<cdot>
	+ (u \<star> \<a>\<^sup>-\<^sup>1[f, g, f]) \<cdot> ((u \<star> f \<star> \<eta>) \<cdot> \<a>[u, f, src f])) \<cdot>
	+ (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ using assms antipar assoc'_naturality [of u \<epsilon> f] assoc_naturality [of u f \<eta>]
	+ by auto
	+ also have "... = (\<r>[u] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[u, src u, f] \<cdot>
	+ ((u \<star> \<epsilon> \<star> f) \<cdot> (u \<star> \<a>\<^sup>-\<^sup>1[f, g, f]) \<cdot> (u \<star> f \<star> \<eta>)) \<cdot> \<a>[u, f, src f] \<cdot>
	+ (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ using comp_assoc by simp
	+ also have "... = (\<r>[u] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[u, src u, f] \<cdot>
	+ (u \<star> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) \<cdot> \<a>[u, f, src f] \<cdot>
	+ (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ using assms antipar whisker_left hseqI' by auto
	+ also have "... = ((\<r>[u] \<star> f) \<cdot> (\<a>\<^sup>-\<^sup>1[u, src u, f] \<cdot> (u \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot> \<a>[u, f, src f])) \<cdot>
	+ (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ using assms antipar triangle_left comp_assoc by simp
	+ also have "... = \<r>[u \<star> f] \<cdot> (\<nu> \<star> src v) \<cdot> \<r>\<^sup>-\<^sup>1[v]"
	+ proof -
	+ have "(\<r>[u] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[u, src u, f] \<cdot> (u \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot> \<a>[u, f, src f] =
	+ ((u \<star> \<l>[f]) \<cdot> (\<a>[u, src u, f] \<cdot> \<a>\<^sup>-\<^sup>1[u, src u, f])) \<cdot>
	+ (u \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot> \<a>[u, f, src f]"
	+ using assms ide_left ide_right antipar triangle comp_assoc by metis
	+ also have "... = (u \<star> \<r>[f]) \<cdot> \<a>[u, f, src f]"
	+ using assms antipar canI_associator_1 canI_unitor_0 whisker_can_left_0
	+ whisker_can_right_0 canI_associator_1
	+ by simp
	+ also have "... = \<r>[u \<star> f]"
	+ using assms antipar runit_hcomp by simp
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = (\<r>[u \<star> f] \<cdot> \<r>\<^sup>-\<^sup>1[u \<star> f]) \<cdot> \<nu>"
	+ using assms \<nu> runit'_naturality [of \<nu>] comp_assoc by auto
	+ also have "... = \<nu>"
	+ using assms \<nu> comp_cod_arr comp_arr_inv inv_is_inverse iso_runit by auto
	+ finally show "trnr\<^sub>\<eta> v (trnr\<^sub>\<epsilon> u \<nu>) = \<nu>" by auto
	+ qed
	+ show "bij_betw (trnr\<^sub>\<eta> v) (hom (v \<star> g) u) (hom v (u \<star> f))"
	+ using A B C D by (intro bij_betwI, auto)
	+ show "bij_betw (trnr\<^sub>\<epsilon> u) (hom v (u \<star> f)) (hom (v \<star> g) u)"
	+ using A B C D by (intro bij_betwI, auto)
	+ qed
	+
	+ lemma trnr\<^sub>\<eta>_comp:
	+ assumes "ide v" and "seq \<mu> \<nu>" and "src \<mu> = trg f"
	+ shows "trnr\<^sub>\<eta> v (\<mu> \<cdot> \<nu>) = (\<mu> \<star> f) \<cdot> trnr\<^sub>\<eta> v \<nu>"
	+ using assms trnr\<^sub>\<eta>_def whisker_right comp_assoc by auto
	+
	+ end
	+
	+ text \<open>
	+ It is useful to have at hand the simpler versions of the preceding results that
	+ hold in a normal bicategory and in a strict bicategory.
	+ \<close>
	+
	+ locale adjunction_in_normal_bicategory =
	+ normal_bicategory +
	+ adjunction_in_bicategory
	+ begin
	+
	+ lemma triangle_left:
	+ shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = f"
	+ using triangle_left strict_lunit strict_runit by simp
	+
	+ lemma triangle_right:
	+ shows "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = g"
	+ using triangle_right strict_lunit strict_runit by simp
	+
	+ lemma trnr\<^sub>\<eta>_eq:
	+ assumes "ide u" and "ide v"
	+ and "src v = trg g" and "src u = trg f"
	+ and "\<mu> \<in> hom (v \<star> g) u"
	+ shows "trnr\<^sub>\<eta> v \<mu> = (\<mu> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>)"
	+ unfolding trnr\<^sub>\<eta>_def
	+ using assms antipar strict_runit' comp_arr_ide [of "\<r>\<^sup>-\<^sup>1[v]" "v \<star> \<eta>"] hcomp_arr_obj hseqI'
	+ by auto
	+
	+ lemma trnr\<^sub>\<epsilon>_eq:
	+ assumes "ide u" and "ide v"
	+ and "src v = trg g" and "src u = trg f"
	+ and "\<nu> \<in> hom v (u \<star> f)"
	+ shows "trnr\<^sub>\<epsilon> u \<nu> = (u \<star> \<epsilon>) \<cdot> \<a>[u, f, g] \<cdot> (\<nu> \<star> g)"
	+ unfolding trnr\<^sub>\<epsilon>_def
	+ using assms antipar strict_runit comp_ide_arr hcomp_arr_obj hseqI' by auto
	+
	+ lemma trnl\<^sub>\<eta>_eq:
	+ assumes "ide u" and "ide v"
	+ and "src f = trg v" and "src g = trg u"
	+ and "\<mu> \<in> hom (f \<star> v) u"
	+ shows "trnl\<^sub>\<eta> v \<mu> = (g \<star> \<mu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v)"
	+ using assms trnl\<^sub>\<eta>_def antipar strict_lunit comp_arr_dom hcomp_obj_arr hseqI' by auto
	+
	+ lemma trnl\<^sub>\<epsilon>_eq:
	+ assumes "ide u" and "ide v"
	+ and "src f = trg v" and "src g = trg u"
	+ and "\<nu> \<in> hom v (g \<star> u)"
	+ shows "trnl\<^sub>\<epsilon> u \<nu> = (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> \<nu>)"
	+ using assms trnl\<^sub>\<epsilon>_def antipar strict_lunit comp_cod_arr hcomp_obj_arr hseqI' by auto
	+
	+ end
	+
	+ locale adjunction_in_strict_bicategory =
	+ strict_bicategory +
	+ adjunction_in_normal_bicategory
	+ begin
	+
	+ lemma triangle_left:
	+ shows "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f"
	+ using ide_left ide_right antipar triangle_left strict_assoc' comp_cod_arr
	+ by (metis dom_eqI ideD(1) seqE)
	+
	+ lemma triangle_right:
	+ shows "(g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
	+ using ide_left ide_right antipar triangle_right strict_assoc comp_cod_arr
	+ by (metis ideD(1) ideD(2) seqE)
	+
	+ lemma trnr\<^sub>\<eta>_eq:
	+ assumes "ide u" and "ide v"
	+ and "src v = trg g" and "src u = trg f"
	+ and "\<mu> \<in> hom (v \<star> g) u"
	+ shows "trnr\<^sub>\<eta> v \<mu> = (\<mu> \<star> f) \<cdot> (v \<star> \<eta>)"
	+ proof -
	+ have "trnr\<^sub>\<eta> v \<mu> = (\<mu> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>)"
	+ using assms trnr\<^sub>\<eta>_eq [of u v \<mu>] by simp
	+ also have "... = (\<mu> \<star> f) \<cdot> (v \<star> \<eta>)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[v, g, f] \<cdot> (v \<star> \<eta>) = (v \<star> \<eta>)"
	+ proof -
	+ have "ide \<a>\<^sup>-\<^sup>1[v, g, f]"
	+ using assms antipar strict_assoc' by simp
	+ moreover have "seq \<a>\<^sup>-\<^sup>1[v, g, f] (v \<star> \<eta>)"
	+ using assms antipar hseqI' by simp
	+ ultimately show ?thesis
	+ using comp_ide_arr by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma trnr\<^sub>\<epsilon>_eq:
	+ assumes "ide u" and "ide v"
	+ and "src v = trg g" and "src u = trg f"
	+ and "\<nu> \<in> hom v (u \<star> f)"
	+ shows "trnr\<^sub>\<epsilon> u \<nu> = (u \<star> \<epsilon>) \<cdot> (\<nu> \<star> g)"
	+ proof -
	+ have "trnr\<^sub>\<epsilon> u \<nu> = (u \<star> \<epsilon>) \<cdot> \<a>[u, f, g] \<cdot> (\<nu> \<star> g)"
	+ using assms trnr\<^sub>\<epsilon>_eq [of u v \<nu>] by simp
	+ also have "... = (u \<star> \<epsilon>) \<cdot> (\<nu> \<star> g)"
	+ proof -
	+ have "\<a>[u, f, g] \<cdot> (\<nu> \<star> g) = (\<nu> \<star> g)"
	+ proof -
	+ have "ide \<a>[u, f, g]"
	+ using assms antipar strict_assoc by simp
	+ moreover have "seq \<a>[u, f, g] (\<nu> \<star> g)"
	+ using assms antipar by force
	+ ultimately show ?thesis
	+ using comp_ide_arr by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma trnl\<^sub>\<eta>_eq:
	+ assumes "ide u" and "ide v"
	+ and "src f = trg v" and "src g = trg u"
	+ and "\<mu> \<in> hom (f \<star> v) u"
	+ shows "trnl\<^sub>\<eta> v \<mu> = (g \<star> \<mu>) \<cdot> (\<eta> \<star> v)"
	+ proof -
	+ have "trnl\<^sub>\<eta> v \<mu> = (g \<star> \<mu>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v)"
	+ using assms trnl\<^sub>\<eta>_eq [of u v \<mu>] by simp
	+ also have "... = (g \<star> \<mu>) \<cdot> (\<eta> \<star> v)"
	+ proof -
	+ have "seq \<a>[g, f, v] (\<eta> \<star> v)"
	+ using assms antipar unit_in_hom hseqI'
	+ apply (intro seqI hseqI) by auto
	+ thus ?thesis
	+ using assms antipar trnl\<^sub>\<eta>_eq strict_assoc comp_ide_arr [of "\<a>[g, f, v]" "\<eta> \<star> v"]
	+ by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+
	+ lemma trnl\<^sub>\<epsilon>_eq:
	+ assumes "ide u" and "ide v"
	+ and "src f = trg v" and "src g = trg u"
	+ and "\<nu> \<in> hom v (g \<star> u)"
	+ shows "trnl\<^sub>\<epsilon> u \<nu> = (\<epsilon> \<star> u) \<cdot> (f \<star> \<nu>)"
	+ proof -
	+ have "trnl\<^sub>\<epsilon> u \<nu> = (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> \<nu>)"
	+ using assms trnl\<^sub>\<epsilon>_eq [of u v \<nu>] by simp
	+ also have "... = ((\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u]) \<cdot> (f \<star> \<nu>)"
	+ using comp_assoc by simp
	+ also have "... = (\<epsilon> \<star> u) \<cdot> (f \<star> \<nu>)"
	+ proof -
	+ have "seq (\<epsilon> \<star> u) \<a>\<^sup>-\<^sup>1[f, g, u]"
	+ using assms antipar unit_in_hom hseqI'
	+ apply (intro seqI hseqI) by auto
	+ thus ?thesis
	+ using assms antipar trnl\<^sub>\<epsilon>_eq strict_assoc' comp_arr_ide ide_left ide_right
	+ by metis
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ end
	+
	+ subsection "Preservation Properties for Adjunctions"
	+
	+ text \<open>
	+ Here we show that adjunctions are preserved under isomorphisms of the
	+ left and right adjoints.
	+ \<close>
	+
	+ context bicategory
	+ begin
	+
	+ interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ definition adjoint_pair
	+ where "adjoint_pair f g \<equiv> \<exists>\<eta> \<epsilon>. adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+
	+ (* These would normally be called "maps", but that name is too heavily used already. *)
	+ abbreviation is_left_adjoint
	+ where "is_left_adjoint f \<equiv> \<exists>g. adjoint_pair f g"
	+
	+ abbreviation is_right_adjoint
	+ where "is_right_adjoint g \<equiv> \<exists>f. adjoint_pair f g"
	+
	+ lemma adjoint_pair_antipar:
	+ assumes "adjoint_pair f g"
	+ shows "ide f" and "ide g" and "src f = trg g" and "src g = trg f"
	+ proof -
	+ obtain \<eta> \<epsilon> where A: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms adjoint_pair_def by auto
	+ interpret A: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using A by auto
	+ show "ide f" by simp
	+ show "ide g" by simp
	+ show "src f = trg g" using A.antipar by simp
	+ show "src g = trg f" using A.antipar by simp
	+ qed
	+
	+ lemma left_adjoint_is_ide:
	+ assumes "is_left_adjoint f"
	+ shows "ide f"
	+ using assms adjoint_pair_antipar by auto
	+
	+ lemma right_adjoint_is_ide:
	+ assumes "is_right_adjoint f"
	+ shows "ide f"
	+ using assms adjoint_pair_antipar by auto
	+
	+ lemma adjunction_preserved_by_iso_right:
	+ assumes "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ and "\<guillemotleft>\<phi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<phi>"
	+ shows "adjunction_in_bicategory V H \<a> \<i> src trg f g' ((\<phi> \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (f \<star> inv \<phi>))"
	+ proof
	+ interpret A: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using assms by auto
	+ show "ide f" by simp
	+ show "ide g'"
	+ using assms(2) isomorphic_def by auto
	+ show "\<guillemotleft>(\<phi> \<star> f) \<cdot> \<eta> : src f \<Rightarrow> g' \<star> f\<guillemotright>"
	+ using assms A.antipar by fastforce
	+ show "\<guillemotleft>\<epsilon> \<cdot> (f \<star> inv \<phi>) : f \<star> g' \<Rightarrow> src g'\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>f \<star> inv \<phi> : f \<star> g' \<Rightarrow> f \<star> g\<guillemotright>"
	+ using assms A.antipar by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g'\<guillemotright>"
	+ using assms A.counit_in_hom A.antipar by auto
	+ qed
	+ show "(\<epsilon> \<cdot> (f \<star> inv \<phi>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g', f] \<cdot> (f \<star> (\<phi> \<star> f) \<cdot> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ proof -
	+ have "(\<epsilon> \<cdot> (f \<star> inv \<phi>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g', f] \<cdot> (f \<star> (\<phi> \<star> f) \<cdot> \<eta>) =
	+ (\<epsilon> \<star> f) \<cdot> (((f \<star> inv \<phi>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g', f]) \<cdot> (f \<star> \<phi> \<star> f) \<cdot> (f \<star> \<eta>)"
	+ using assms A.antipar whisker_right whisker_left hseqI' comp_assoc by auto
	+ also have "... = (\<epsilon> \<star> f) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> inv \<phi> \<star> f)) \<cdot> (f \<star> \<phi> \<star> f) \<cdot> (f \<star> \<eta>)"
	+ using assms A.antipar assoc'_naturality [of f "inv \<phi>" f] by auto
	+ also have "... = (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> ((f \<star> inv \<phi> \<star> f) \<cdot> (f \<star> \<phi> \<star> f)) \<cdot> (f \<star> \<eta>)"
	+ using comp_assoc by simp
	+ also have "... = (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> g \<star> f) \<cdot> (f \<star> \<eta>)"
	+ using assms A.antipar comp_inv_arr inv_is_inverse hseqI' whisker_left
	+ whisker_right [of f "inv \<phi>" \<phi>]
	+ by auto
	+ also have "... = (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)"
	+ using assms A.antipar comp_cod_arr hseqI' by simp
	+ also have "... = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ using A.triangle_left by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "(g' \<star> \<epsilon> \<cdot> (f \<star> inv \<phi>)) \<cdot> \<a>[g', f, g'] \<cdot> ((\<phi> \<star> f) \<cdot> \<eta> \<star> g') = \<r>\<^sup>-\<^sup>1[g'] \<cdot> \<l>[g']"
	+ proof -
	+ have "(g' \<star> \<epsilon> \<cdot> (f \<star> inv \<phi>)) \<cdot> \<a>[g', f, g'] \<cdot> ((\<phi> \<star> f) \<cdot> \<eta> \<star> g') =
	+ (g' \<star> \<epsilon>) \<cdot> ((g' \<star> f \<star> inv \<phi>) \<cdot> \<a>[g', f, g']) \<cdot> ((\<phi> \<star> f) \<star> g') \<cdot> (\<eta> \<star> g')"
	+ using assms hseqI' A.antipar whisker_left whisker_right comp_assoc by auto
	+ also have "... = (g' \<star> \<epsilon>) \<cdot> (\<a>[g', f, g] \<cdot> ((g' \<star> f) \<star> inv \<phi>)) \<cdot> ((\<phi> \<star> f) \<star> g') \<cdot> (\<eta> \<star> g')"
	+ using assms A.antipar assoc_naturality [of g' f "inv \<phi>"] by auto
	+ also have "... = (g' \<star> \<epsilon>) \<cdot> \<a>[g', f, g] \<cdot> (((g' \<star> f) \<star> inv \<phi>) \<cdot> ((\<phi> \<star> f) \<star> g')) \<cdot> (\<eta> \<star> g')"
	+ using comp_assoc by simp
	+ also have "... = (g' \<star> \<epsilon>) \<cdot> (\<a>[g', f, g] \<cdot> ((\<phi> \<star> f) \<star> g)) \<cdot> ((g \<star> f) \<star> inv \<phi>) \<cdot> (\<eta> \<star> g')"
	+ proof -
	+ have "((g' \<star> f) \<star> inv \<phi>) \<cdot> ((\<phi> \<star> f) \<star> g') = (\<phi> \<star> f) \<star> inv \<phi>"
	+ using assms A.antipar comp_arr_dom comp_cod_arr hseqI'
	+ interchange [of "g' \<star> f" "\<phi> \<star> f" "inv \<phi>" g']
	+ by auto
	+ also have "... = ((\<phi> \<star> f) \<star> g) \<cdot> ((g \<star> f) \<star> inv \<phi>)"
	+ using assms A.antipar comp_arr_dom comp_cod_arr
	+ interchange [of "\<phi> \<star> f" "g \<star> f" g "inv \<phi>"] hseqI'
	+ by auto
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((g' \<star> \<epsilon>) \<cdot> (\<phi> \<star> f \<star> g)) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> (trg g \<star> inv \<phi>)"
	+ proof -
	+ have "\<a>[g', f, g] \<cdot> ((\<phi> \<star> f) \<star> g) = (\<phi> \<star> f \<star> g) \<cdot> \<a>[g, f, g]"
	+ using assms A.antipar assoc_naturality [of \<phi> f g] by auto
	+ moreover have "((g \<star> f) \<star> inv \<phi>) \<cdot> (\<eta> \<star> g') = (\<eta> \<star> g) \<cdot> (trg g \<star> inv \<phi>)"
	+ using assms A.antipar comp_arr_dom comp_cod_arr
	+ interchange [of "g \<star> f" \<eta> "inv \<phi>" g'] interchange [of \<eta> "trg g" g "inv \<phi>"]
	+ by auto
	+ ultimately show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((\<phi> \<star> src g) \<cdot> (g \<star> \<epsilon>)) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> (trg g \<star> inv \<phi>)"
	+ using assms A.antipar comp_arr_dom comp_cod_arr
	+ interchange [of g' \<phi> \<epsilon> "f \<star> g"] interchange [of \<phi> g "src g" \<epsilon>]
	+ by auto
	+ also have "... = (\<phi> \<star> src g) \<cdot> ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot> (trg g \<star> inv \<phi>)"
	+ using comp_assoc by simp
	+ also have "... = ((\<phi> \<star> src g) \<cdot> \<r>\<^sup>-\<^sup>1[g]) \<cdot> \<l>[g] \<cdot> (trg g \<star> inv \<phi>)"
	+ using assms A.antipar A.triangle_right comp_cod_arr comp_assoc
	+ by simp
	+ also have "... = (\<r>\<^sup>-\<^sup>1[g'] \<cdot> \<phi>) \<cdot> inv \<phi> \<cdot> \<l>[g']"
	+ using assms A.antipar runit'_naturality [of \<phi>] lunit_naturality [of "inv \<phi>"]
	+ by auto
	+ also have "... = \<r>\<^sup>-\<^sup>1[g'] \<cdot> (\<phi> \<cdot> inv \<phi>) \<cdot> \<l>[g']"
	+ using comp_assoc by simp
	+ also have "... = \<r>\<^sup>-\<^sup>1[g'] \<cdot> \<l>[g']"
	+ using assms comp_cod_arr comp_arr_inv' by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma adjunction_preserved_by_iso_left:
	+ assumes "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
	+ shows "adjunction_in_bicategory V H \<a> \<i> src trg f' g ((g \<star> \<phi>) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g))"
	+ proof
	+ interpret A: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using assms by auto
	+ show "ide g" by simp
	+ show "ide f'"
	+ using assms(2) isomorphic_def by auto
	+ show "\<guillemotleft>(g \<star> \<phi>) \<cdot> \<eta> : src f' \<Rightarrow> g \<star> f'\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>\<eta> : src f' \<Rightarrow> g \<star> f\<guillemotright>"
	+ using assms A.unit_in_hom by auto
	+ show "\<guillemotleft>g \<star> \<phi> : g \<star> f \<Rightarrow> g \<star> f'\<guillemotright>"
	+ using assms A.antipar by fastforce
	+ qed
	+ show "\<guillemotleft>\<epsilon> \<cdot> (inv \<phi> \<star> g) : f' \<star> g \<Rightarrow> src g\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>inv \<phi> \<star> g : f' \<star> g \<Rightarrow> f \<star> g\<guillemotright>"
	+ using assms A.antipar by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g\<guillemotright>"
	+ using assms A.antipar by auto
	+ qed
	+ show "(g \<star> \<epsilon> \<cdot> (inv \<phi> \<star> g)) \<cdot> \<a>[g, f', g] \<cdot> ((g \<star> \<phi>) \<cdot> \<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ proof -
	+ have "(g \<star> \<epsilon> \<cdot> (inv \<phi> \<star> g)) \<cdot> \<a>[g, f', g] \<cdot> ((g \<star> \<phi>) \<cdot> \<eta> \<star> g) =
	+ (g \<star> \<epsilon>) \<cdot> ((g \<star> inv \<phi> \<star> g) \<cdot> \<a>[g, f', g]) \<cdot> ((g \<star> \<phi>) \<star> g) \<cdot> (\<eta> \<star> g)"
	+ using assms A.antipar whisker_left whisker_right hseqI' comp_assoc by auto
	+ also have "... = (g \<star> \<epsilon>) \<cdot> (\<a>[g, f, g] \<cdot> ((g \<star> inv \<phi>) \<star> g)) \<cdot> ((g \<star> \<phi>) \<star> g) \<cdot> (\<eta> \<star> g)"
	+ using assms A.antipar assoc_naturality [of g "inv \<phi>" g] by auto
	+ also have "... = (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (((g \<star> inv \<phi>) \<star> g) \<cdot> ((g \<star> \<phi>) \<star> g)) \<cdot> (\<eta> \<star> g)"
	+ using comp_assoc by simp
	+ also have "... = (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> ((g \<star> f) \<star> g) \<cdot> (\<eta> \<star> g)"
	+ using assms A.antipar comp_inv_arr inv_is_inverse hseqI' whisker_right
	+ whisker_left [of g "inv \<phi>" \<phi>]
	+ by auto
	+ also have "... = (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)"
	+ using assms A.antipar comp_cod_arr hseqI' by simp
	+ also have "... = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ using A.triangle_right by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "(\<epsilon> \<cdot> (inv \<phi> \<star> g) \<star> f') \<cdot> \<a>\<^sup>-\<^sup>1[f', g, f'] \<cdot> (f' \<star> (g \<star> \<phi>) \<cdot> \<eta>) = \<l>\<^sup>-\<^sup>1[f'] \<cdot> \<r>[f']"
	+ proof -
	+ have "(\<epsilon> \<cdot> (inv \<phi> \<star> g) \<star> f') \<cdot> \<a>\<^sup>-\<^sup>1[f', g, f'] \<cdot> (f' \<star> (g \<star> \<phi>) \<cdot> \<eta>) =
	+ (\<epsilon> \<star> f') \<cdot> (((inv \<phi> \<star> g) \<star> f') \<cdot> \<a>\<^sup>-\<^sup>1[f', g, f']) \<cdot> (f' \<star> g \<star> \<phi>) \<cdot> (f' \<star> \<eta>)"
	+ using assms hseqI' A.antipar whisker_right whisker_left comp_assoc
	+ by auto
	+ also have "... = (\<epsilon> \<star> f') \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f'] \<cdot> (inv \<phi> \<star> g \<star> f')) \<cdot> (f' \<star> g \<star> \<phi>) \<cdot> (f' \<star> \<eta>)"
	+ using assms A.antipar assoc'_naturality [of "inv \<phi>" g f'] by auto
	+ also have "... = (\<epsilon> \<star> f') \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f'] \<cdot> ((inv \<phi> \<star> g \<star> f') \<cdot> (f' \<star> g \<star> \<phi>)) \<cdot> (f' \<star> \<eta>)"
	+ using comp_assoc by simp
	+ also have "... = (\<epsilon> \<star> f') \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, f'] \<cdot> (f \<star> g \<star> \<phi>)) \<cdot> (inv \<phi> \<star> g \<star> f) \<cdot> (f' \<star> \<eta>)"
	+ proof -
	+ have "(inv \<phi> \<star> g \<star> f') \<cdot> (f' \<star> g \<star> \<phi>) = inv \<phi> \<star> g \<star> \<phi>"
	+ using assms A.antipar comp_arr_dom comp_cod_arr hseqI'
	+ interchange [of "inv \<phi>" f' "g \<star> f'" "g \<star> \<phi>"]
	+ by auto
	+ also have "... = (f \<star> g \<star> \<phi>) \<cdot> (inv \<phi> \<star> g \<star> f)"
	+ using assms A.antipar comp_arr_dom comp_cod_arr hseqI'
	+ interchange [of f "inv \<phi>" "g \<star> \<phi>" "g \<star> f"]
	+ by auto
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((\<epsilon> \<star> f') \<cdot> ((f \<star> g) \<star> \<phi>)) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> (inv \<phi> \<star> src f)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[f, g, f'] \<cdot> (f \<star> g \<star> \<phi>) = ((f \<star> g) \<star> \<phi>) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f]"
	+ using assms A.antipar assoc'_naturality [of f g \<phi>] by auto
	+ moreover have "(inv \<phi> \<star> g \<star> f) \<cdot> (f' \<star> \<eta>) = (f \<star> \<eta>) \<cdot> (inv \<phi> \<star> src f)"
	+ using assms A.antipar comp_arr_dom comp_cod_arr
	+ interchange [of "inv \<phi>" f' "g \<star> f" \<eta>] interchange [of f "inv \<phi>" \<eta> "src f"]
	+ by auto
	+ ultimately show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((trg f \<star> \<phi>) \<cdot> (\<epsilon> \<star> f)) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> (inv \<phi> \<star> src f)"
	+ using assms A.antipar comp_arr_dom comp_cod_arr
	+ interchange [of \<epsilon> "f \<star> g" f' \<phi>] interchange [of "trg f" \<epsilon> \<phi> f]
	+ by auto
	+ also have "... = (trg f \<star> \<phi>) \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) \<cdot> (inv \<phi> \<star> src f)"
	+ using comp_assoc by simp
	+ also have "... = ((trg f \<star> \<phi>) \<cdot> \<l>\<^sup>-\<^sup>1[f]) \<cdot> \<r>[f] \<cdot> (inv \<phi> \<star> src f)"
	+ using assms A.antipar A.triangle_left comp_cod_arr comp_assoc
	+ by simp
	+ also have "... = (\<l>\<^sup>-\<^sup>1[f'] \<cdot> \<phi>) \<cdot> inv \<phi> \<cdot> \<r>[f']"
	+ using assms A.antipar lunit'_naturality runit_naturality [of "inv \<phi>"] by auto
	+ also have "... = \<l>\<^sup>-\<^sup>1[f'] \<cdot> (\<phi> \<cdot> inv \<phi>) \<cdot> \<r>[f']"
	+ using comp_assoc by simp
	+ also have "... = \<l>\<^sup>-\<^sup>1[f'] \<cdot> \<r>[f']"
	+ using assms comp_cod_arr comp_arr_inv inv_is_inverse by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma adjoint_pair_preserved_by_iso:
	+ assumes "adjoint_pair f g"
	+ and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
	+ and "\<guillemotleft>\<psi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<psi>"
	+ shows "adjoint_pair f' g'"
	+ proof -
	+ obtain \<eta> \<epsilon> where A: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms adjoint_pair_def by auto
	+ have "adjunction_in_bicategory V H \<a> \<i> src trg f g' ((\<psi> \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (f \<star> inv \<psi>))"
	+ using assms A adjunction_preserved_by_iso_right by blast
	+ hence "adjunction_in_bicategory V H \<a> \<i> src trg f' g'
	+ ((g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta>) ((\<epsilon> \<cdot> (f \<star> inv \<psi>)) \<cdot> (inv \<phi> \<star> g'))"
	+ using assms adjunction_preserved_by_iso_left by blast
	+ thus ?thesis using adjoint_pair_def by auto
	+ qed
	+
	+ lemma left_adjoint_preserved_by_iso:
	+ assumes "is_left_adjoint f"
	+ and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
	+ shows "is_left_adjoint f'"
	+ proof -
	+ obtain g where g: "adjoint_pair f g"
	+ using assms by auto
	+ have "adjoint_pair f' g"
	+ using assms g adjoint_pair_preserved_by_iso [of f g \<phi> f' g g]
	+ adjoint_pair_antipar [of f g]
	+ by auto
	+ thus ?thesis by auto
	+ qed
	+
	+ lemma right_adjoint_preserved_by_iso:
	+ assumes "is_right_adjoint g"
	+ and "\<guillemotleft>\<phi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<phi>"
	+ shows "is_right_adjoint g'"
	+ proof -
	+ obtain f where f: "adjoint_pair f g"
	+ using assms by auto
	+ have "adjoint_pair f g'"
	+ using assms f adjoint_pair_preserved_by_iso [of f g f f \<phi> g']
	+ adjoint_pair_antipar [of f g]
	+ by auto
	+ thus ?thesis by auto
	+ qed
	+
	+ lemma left_adjoint_preserved_by_iso':
	+ assumes "is_left_adjoint f" and "f \<cong> f'"
	+ shows "is_left_adjoint f'"
	+ using assms isomorphic_def left_adjoint_preserved_by_iso by blast
	+
	+ lemma right_adjoint_preserved_by_iso':
	+ assumes "is_right_adjoint g" and "g \<cong> g'"
	+ shows "is_right_adjoint g'"
	+ using assms isomorphic_def right_adjoint_preserved_by_iso by blast
	+
	+ lemma obj_self_adjunction:
	+ assumes "obj a"
	+ shows "adjunction_in_bicategory V H \<a> \<i> src trg a a \<l>\<^sup>-\<^sup>1[a] \<r>[a]"
	+ proof
	+ show 1: "ide a"
	+ using assms by auto
	+ show "\<guillemotleft>\<l>\<^sup>-\<^sup>1[a] : src a \<Rightarrow> a \<star> a\<guillemotright>"
	+ using assms 1 by auto
	+ show "\<guillemotleft>\<r>[a] : a \<star> a \<Rightarrow> src a\<guillemotright>"
	+ using assms 1 by fastforce
	+ show "(\<r>[a] \<star> a) \<cdot> \<a>\<^sup>-\<^sup>1[a, a, a] \<cdot> (a \<star> \<l>\<^sup>-\<^sup>1[a]) = \<l>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a]"
	+ using assms 1 canI_unitor_1 canI_associator_1(2) canI_associator_3
	+ whisker_can_right_1 whisker_can_left_1 can_Ide_self
	+ by simp
	+ show "(a \<star> \<r>[a]) \<cdot> \<a>[a, a, a] \<cdot> (\<l>\<^sup>-\<^sup>1[a] \<star> a) = \<r>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a]"
	+ using assms 1 canI_unitor_1 canI_associator_1(2) canI_associator_3
	+ whisker_can_right_1 whisker_can_left_1 can_Ide_self
	+ by simp
	+ qed
	+
	+ lemma obj_is_self_adjoint:
	+ assumes "obj a"
	+ shows "adjoint_pair a a" and "is_left_adjoint a" and "is_right_adjoint a"
	+ using assms obj_self_adjunction adjoint_pair_def by auto
	+
	+ end
	+
	+ subsection "Pseudofunctors and Adjunctions"
	+
	+ context pseudofunctor
	+ begin
	+
	+ lemma preserves_adjunction:
	+ assumes "adjunction_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
	+ shows "adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
	+ (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
	+ proof -
	+ interpret adjunction_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>
	+ using assms by auto
	+ interpret A: adjunction_data_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>F f\<close> \<open>F g\<close> \<open>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)\<close>
	+ \<open>D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)\<close>
	+ using adjunction_data_in_bicategory_axioms preserves_adjunction_data by auto
	+ show "adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
	+ (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
	+ proof
	+ show "(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) =
	+ D.lunit' (F f) \<cdot>\<^sub>D \<r>\<^sub>D[F f]"
	+ proof -
	+ have 1: "D.iso (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)))"
	+ using antipar C.VV.ide_char C.VV.arr_char D.iso_is_arr FF_def
	+ by (intro D.isos_compose D.seqI, simp_all)
	+ have "(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) =
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
	+ \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ proof -
	+ have "\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] =
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
	+ \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f))"
	+ proof -
	+ have "\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f))) =
	+ D.inv (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f))"
	+ proof -
	+ have "D.inv (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F f]) =
	+ D.inv (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f))"
	+ using antipar assoc_coherence by simp
	+ moreover
	+ have "D.inv (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F f]) =
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)))"
	+ proof -
	+ have "D.seq (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f))) \<a>\<^sub>D[F f, F g, F f]"
	+ using antipar by fastforce
	+ thus ?thesis
	+ using 1 antipar D.comp_assoc
	+ D.inv_comp [of "\<a>\<^sub>D[F f, F g, F f]" "\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f))"]
	+ by auto
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ moreover have 2: "D.iso (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f))"
	+ using antipar D.isos_compose C.VV.ide_char C.VV.arr_char \<Phi>_simps(4) D.hseqI'
	+ by simp
	+ ultimately have "\<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] =
	+ D.inv (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
	+ (\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)))"
	+ using 1 2 antipar D.invert_side_of_triangle(2) D.inv_inv D.iso_inv_iso D.arr_inv
	+ by metis
	+ moreover have "D.inv (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) =
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]"
	+ proof -
	+ have "D.inv (F \<a>\<^sub>C[f, g, f] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) =
	+ D.inv (\<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]"
	+ using antipar D.isos_compose C.VV.ide_char C.VV.arr_char \<Phi>_simps(4) D.hseqI'
	+ preserves_inv D.inv_comp D.iso_is_arr
	+ by simp
	+ also have "... = (D.inv (\<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f))) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]"
	+ using antipar D.inv_comp C.VV.ide_char C.VV.arr_char \<Phi>_simps(4) D.hseqI'
	+ by simp
	+ also have "... = ((D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f))) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]"
	+ using antipar C.VV.ide_char C.VV.arr_char by simp
	+ also have "... = (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]"
	+ using D.comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
	+ \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ proof -
	+ have "... = ((D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
	+ \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D
	+ ((F f \<star>\<^sub>D D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)))"
	+ proof -
	+ have "D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) \<star>\<^sub>D F f =
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)"
	+ using ide_left ide_right antipar D.whisker_right \<Psi>_char(2)
	+ by (metis A.counit_simps(1) A.ide_left D.comp_assoc)
	+ moreover have "F f \<star>\<^sub>D D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) =
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ using antipar \<Psi>_char(2) D.whisker_left by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ (((\<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f \<star>\<^sub>C g, f))) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D
	+ (((F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Phi> (g, f)))) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)))"
	+ using D.comp_assoc by simp
	+ also have "... = (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
	+ \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ proof -
	+ have "((F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Phi> (g, f)))) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) =
	+ F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)"
	+ proof -
	+ have "(F f \<star>\<^sub>D \<Phi> (g, f)) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Phi> (g, f))) = F f \<star>\<^sub>D F (g \<star>\<^sub>C f)"
	+ using antipar \<Psi>_char(2) D.comp_arr_inv D.inv_is_inverse
	+ D.whisker_left [of "F f" "\<Phi> (g, f)" "D.inv (\<Phi> (g, f))"]
	+ by simp
	+ moreover have "D.seq (F f \<star>\<^sub>D F (g \<star>\<^sub>C f)) (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ using antipar by fastforce
	+ ultimately show ?thesis
	+ using D.comp_cod_arr by auto
	+ qed
	+ moreover have "((\<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f \<star>\<^sub>C g, f)) =
	+ D.inv (\<Phi> (f \<star>\<^sub>C g, f))"
	+ using antipar D.comp_arr_inv D.inv_is_inverse D.comp_cod_arr
	+ D.whisker_right [of "F f" "\<Phi> (f, g)" "D.inv (\<Phi> (f, g))"]
	+ by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (trg\<^sub>C f, f)) \<cdot>\<^sub>D F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D
	+ ((\<Phi> (f \<star>\<^sub>C g, f) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, f))) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f]) \<cdot>\<^sub>D
	+ ((\<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C f))) \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>)) \<cdot>\<^sub>D
	+ \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ proof -
	+ have "(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
	+ \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) =
	+ ((D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F \<epsilon> \<star>\<^sub>D F f)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D
	+ \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D
	+ ((F f \<star>\<^sub>D F \<eta>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)))"
	+ using antipar D.comp_assoc D.whisker_left D.whisker_right \<Psi>_char(2)
	+ by simp
	+ moreover have "F \<epsilon> \<star>\<^sub>D F f = D.inv (\<Phi> (trg\<^sub>C f, f)) \<cdot>\<^sub>D F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f)"
	+ using antipar \<Phi>.naturality [of "(\<epsilon>, f)"] C.VV.arr_char FF_def C.hseqI'
	+ D.invert_side_of_triangle(1)
	+ by simp
	+ moreover have "F f \<star>\<^sub>D F \<eta> = D.inv (\<Phi> (f, g \<star>\<^sub>C f)) \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>) \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f)"
	+ using antipar \<Phi>.naturality [of "(f, \<eta>)"] C.VV.arr_char FF_def C.hseqI'
	+ D.invert_side_of_triangle(1)
	+ by simp
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = ((D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))) \<cdot>\<^sub>D
	+ (F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>)) \<cdot>\<^sub>D
	+ \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ using antipar D.comp_arr_inv' D.comp_cod_arr C.hseqI' D.comp_assoc by simp
	+ also have "... = D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
	+ F ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>)) \<cdot>\<^sub>D
	+ \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ proof -
	+ have "(D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f)) =
	+ D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f))"
	+ proof -
	+ have "D.iso (\<Phi> (trg\<^sub>C f, f))"
	+ using antipar by simp
	+ moreover have "D.iso (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"
	+ using antipar \<Psi>_char(2) by simp
	+ moreover have "D.seq (\<Phi> (trg\<^sub>C f, f)) (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"
	+ using antipar D.iso_is_arr calculation(2)
	+ apply (intro D.seqI D.hseqI) by auto
	+ ultimately show ?thesis
	+ using antipar D.inv_comp \<Psi>_char(2) by simp
	+ qed
	+ moreover have "F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>) =
	+ F ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>))"
	+ using antipar C.hseqI' by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = (D.lunit' (F f) \<cdot>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D
	+ F (C.lunit' f \<cdot>\<^sub>C \<r>\<^sub>C[f]) \<cdot>\<^sub>D
	+ (D.inv (F \<r>\<^sub>C[f]) \<cdot>\<^sub>D \<r>\<^sub>D[F f])"
	+ proof -
	+ have "F ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>)) = F (C.lunit' f \<cdot>\<^sub>C \<r>\<^sub>C[f])"
	+ using triangle_left by simp
	+ moreover have "D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)) =
	+ D.lunit' (F f) \<cdot>\<^sub>D F \<l>\<^sub>C[f]"
	+ proof -
	+ have 0: "D.iso (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f))"
	+ using \<Psi>_char(2) D.hseqI'
	+ apply (intro D.isos_compose D.seqI) by auto
	+ show ?thesis
	+ proof -
	+ have 1: "D.iso (F \<l>\<^sub>C[f])"
	+ using C.iso_lunit preserves_iso by auto
	+ moreover have "D.iso (F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f))"
	+ by (metis (no_types) A.ide_left D.iso_lunit ide_left lunit_coherence)
	+ moreover have "D.inv (D.inv (F \<l>\<^sub>C[f])) = F \<l>\<^sub>C[f]"
	+ using 1 D.inv_inv by blast
	+ ultimately show ?thesis
	+ by (metis 0 D.inv_comp D.invert_side_of_triangle(2) D.iso_inv_iso
	+ D.iso_is_arr ide_left lunit_coherence)
	+ qed
	+ qed
	+ moreover have "\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)) = D.inv (F \<r>\<^sub>C[f]) \<cdot>\<^sub>D \<r>\<^sub>D[F f]"
	+ using ide_left runit_coherence preserves_iso C.iso_runit D.invert_side_of_triangle(1)
	+ by (metis A.ide_left D.runit_simps(1))
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = D.lunit' (F f) \<cdot>\<^sub>D
	+ ((F \<l>\<^sub>C[f] \<cdot>\<^sub>D F (C.lunit' f)) \<cdot>\<^sub>D (F \<r>\<^sub>C[f] \<cdot>\<^sub>D D.inv (F \<r>\<^sub>C[f]))) \<cdot>\<^sub>D
	+ \<r>\<^sub>D[F f]"
	+ using D.comp_assoc by simp
	+ also have "... = D.lunit' (F f) \<cdot>\<^sub>D \<r>\<^sub>D[F f]"
	+ using D.comp_cod_arr C.iso_runit C.iso_lunit preserves_iso D.comp_arr_inv'
	+ preserves_inv
	+ by force
	+ finally show ?thesis by blast
	+ qed
	+ show "(F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g) =
	+ D.runit' (F g) \<cdot>\<^sub>D \<l>\<^sub>D[F g]"
	+ proof -
	+ have "\<a>\<^sub>D[F g, F f, F g] =
	+ D.inv (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D F g)"
	+ proof -
	+ have "D.iso (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g)))"
	+ using antipar D.iso_is_arr
	+ by (intro D.isos_compose D.seqI, auto)
	+ have "F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D F g) =
	+ \<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D \<a>\<^sub>D[F g, F f, F g]"
	+ using antipar assoc_coherence by simp
	+ moreover have "D.seq (F \<a>\<^sub>C[g, f, g]) (\<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D F g))"
	+ proof (intro D.seqI)
	+ show 1: "D.hseq (\<Phi> (g, f)) (F g)"
	+ using antipar C.VV.arr_char D.hseqI' by simp
	+ show "D.arr (\<Phi> (g \<star>\<^sub>C f, g))"
	+ using antipar C.VV.arr_char by simp
	+ show "D.dom (\<Phi> (g \<star>\<^sub>C f, g)) = D.cod (\<Phi> (g, f) \<star>\<^sub>D F g)"
	+ proof -
	+ have "D.iso (\<Phi> (g, f) \<star>\<^sub>D F g)"
	+ using antipar by simp
	+ moreover have "D.iso (\<Phi> (g \<star>\<^sub>C f, g))"
	+ using antipar by simp
	+ ultimately show ?thesis
	+ using ide_left ide_right A.ide_right antipar D.iso_is_arr D.ide_char
	+ C.ide_hcomp C.ideD(1) C.src_hcomp' D.hcomp_simps(4) \<Phi>_simps(4-5)
	+ by metis
	+ qed
	+ show "D.arr (F \<a>\<^sub>C[g, f, g])"
	+ using antipar by simp
	+ show "D.dom (F \<a>\<^sub>C[g, f, g]) = D.cod (\<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D F g))"
	+ proof -
	+ have "D.iso (\<Phi> (g, f) \<star>\<^sub>D F g)"
	+ using antipar by simp
	+ moreover have "D.seq (\<Phi> (g \<star>\<^sub>C f, g)) (\<Phi> (g, f) \<star>\<^sub>D F g)"
	+ using antipar D.iso_is_arr by (intro D.seqI, auto)
	+ ultimately show ?thesis
	+ using antipar by simp
	+ qed
	+ qed
	+ ultimately show ?thesis
	+ using \<open>D.iso (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g)))\<close> D.invert_side_of_triangle(1)
	+ D.comp_assoc
	+ by auto
	+ qed
	+ hence "(F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g) =
	+ (F g \<star>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D
	+ \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D F g) \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
	+ using D.comp_assoc by simp
	+ also have "... = ((F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D
	+ (\<Phi> (g, f) \<star>\<^sub>D F g) \<cdot>\<^sub>D ((D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D
	+ (F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g))"
	+ proof -
	+ have "F g \<star>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D \<Phi> (f, g) =
	+ (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))"
	+ proof -
	+ have "D.seq (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) (\<Phi> (f, g))"
	+ using antipar D.comp_assoc by simp
	+ thus ?thesis
	+ using antipar D.whisker_left by simp
	+ qed
	+ moreover have "D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g =
	+ (D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D (F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
	+ using antipar D.whisker_right by simp
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D
	+ (((F g \<star>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D D.inv (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, f \<star>\<^sub>C g))) \<cdot>\<^sub>D F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D
	+ ((\<Phi> (g, f) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
	+ (F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
	+ proof -
	+ have "D.inv (\<Phi> (g, f \<star>\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) =
	+ D.inv (F g \<star>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D D.inv (\<Phi> (g, f \<star>\<^sub>C g))"
	+ proof -
	+ have "D.iso (\<Phi> (g, f \<star>\<^sub>C g))"
	+ using antipar by simp
	+ moreover have "D.iso (F g \<star>\<^sub>D \<Phi> (f, g))"
	+ using antipar by simp
	+ moreover have "D.seq (\<Phi> (g, f \<star>\<^sub>C g)) (F g \<star>\<^sub>D \<Phi> (f, g))"
	+ using antipar \<Phi>_in_hom A.ide_right D.iso_is_arr
	+ apply (intro D.seqI D.hseqI) by auto
	+ ultimately show ?thesis
	+ using antipar D.inv_comp by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, f \<star>\<^sub>C g)) \<cdot>\<^sub>D F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D
	+ (F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
	+ proof -
	+ have "((\<Phi> (g, f) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
	+ (F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g) =
	+ (F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
	+ proof -
	+ have "(\<Phi> (g, f) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) = F (g \<star>\<^sub>C f) \<star>\<^sub>D F g"
	+ using antipar D.comp_arr_inv'
	+ D.whisker_right [of "F g" "\<Phi> (g, f)" "D.inv (\<Phi> (g, f))"]
	+ by simp
	+ thus ?thesis
	+ using antipar D.comp_cod_arr D.whisker_right D.hseqI' by simp
	+ qed
	+ moreover have "((F g \<star>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D D.inv (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, f \<star>\<^sub>C g)) =
	+ D.inv (\<Phi> (g, f \<star>\<^sub>C g))"
	+ using antipar D.comp_arr_inv' D.comp_cod_arr
	+ D.whisker_left [of "F g" "\<Phi> (f, g)" "D.inv (\<Phi> (f, g))"]
	+ by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D
	+ ((F g \<star>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D D.inv (\<Phi> (g, f \<star>\<^sub>C g))) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D
	+ (\<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (F \<eta> \<star>\<^sub>D F g)) \<cdot>\<^sub>D
	+ (\<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
	+ using antipar D.whisker_left D.whisker_right \<Psi>_char(2) D.comp_assoc by simp
	+ also have "... = (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D
	+ (F (g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>D F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D F (\<eta> \<star>\<^sub>C g)) \<cdot>\<^sub>D
	+ \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (src\<^sub>C f) \<star>\<^sub>D F g)"
	+ proof -
	+ have "(F g \<star>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D D.inv (\<Phi> (g, f \<star>\<^sub>C g)) = D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D F (g \<star>\<^sub>C \<epsilon>)"
	+ using antipar C.VV.arr_char \<Phi>.naturality [of "(g, \<epsilon>)"] FF_def C.hseqI'
	+ D.invert_opposite_sides_of_square
	+ by simp
	+ moreover have "\<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (F \<eta> \<star>\<^sub>D F g) = F (\<eta> \<star>\<^sub>C g) \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g)"
	+ using antipar C.VV.arr_char \<Phi>.naturality [of "(\<eta>, g)"] FF_def by simp
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = ((F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D
	+ F (C.runit' g)) \<cdot>\<^sub>D (F \<l>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (src\<^sub>C f) \<star>\<^sub>D F g))"
	+ proof -
	+ have "F (g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>D F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D F (\<eta> \<star>\<^sub>C g) = F (C.runit' g) \<cdot>\<^sub>D F \<l>\<^sub>C[g]"
	+ using ide_left ide_right antipar triangle_right
	+ by (metis C.comp_in_homE C.seqI' preserves_comp triangle_in_hom(2))
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = D.runit' (F g) \<cdot>\<^sub>D \<l>\<^sub>D[F g]"
	+ proof -
	+ have "D.inv \<r>\<^sub>D[F g] =
	+ (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D F (C.runit' g)"
	+ proof -
	+ have "D.runit' (F g) = D.inv (F \<r>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)))"
	+ using runit_coherence by simp
	+ also have
	+ "... = (F g \<star>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D F (C.runit' g)"
	+ proof -
	+ have "D.inv (F \<r>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))) =
	+ D.inv (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) \<cdot>\<^sub>D F (C.runit' g)"
	+ proof -
	+ have "D.iso (F \<r>\<^sub>C[g])"
	+ using preserves_iso by simp
	+ moreover have 1: "D.iso (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)))"
	+ using preserves_iso \<Psi>_char(2) D.arrI D.seqE ide_right runit_coherence D.hseqI'
	+ by (intro D.isos_compose D.seqI D.hseqI, auto)
	+ moreover have "D.seq (F \<r>\<^sub>C[g]) (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)))"
	+ using ide_right A.ide_right D.runit_simps(1) runit_coherence by metis
	+ ultimately have "D.inv (F \<r>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))) =
	+ D.inv (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D F (C.runit' g)"
	+ using C.iso_runit preserves_inv D.inv_comp by simp
	+ moreover have "D.inv (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))) =
	+ D.inv (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
	+ proof -
	+ have "D.seq (\<Phi> (g, src\<^sub>C g)) (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))"
	+ using 1 antipar preserves_iso \<Psi>_char(2) by fast
	+ (*
	+ * TODO: The fact that auto cannot do this step is probably what is blocking
	+ * the whole thing from being done by auto.
	+ *)
	+ thus ?thesis
	+ using 1 antipar preserves_iso \<Psi>_char(2) D.inv_comp by auto
	+ qed
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ thus ?thesis
	+ using antipar \<Psi>_char(2) preserves_iso by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using antipar lunit_coherence by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+
	+ lemma preserves_adjoint_pair:
	+ assumes "C.adjoint_pair f g"
	+ shows "D.adjoint_pair (F f) (F g)"
	+ using assms C.adjoint_pair_def D.adjoint_pair_def preserves_adjunction by blast
	+
	+ lemma preserves_left_adjoint:
	+ assumes "C.is_left_adjoint f"
	+ shows "D.is_left_adjoint (F f)"
	+ using assms preserves_adjoint_pair by auto
	+
	+ lemma preserves_right_adjoint:
	+ assumes "C.is_right_adjoint g"
	+ shows "D.is_right_adjoint (F g)"
	+ using assms preserves_adjoint_pair by auto
	+
	+ end
	+
	+ context equivalence_pseudofunctor
	+ begin
	+
	+ lemma reflects_adjunction:
	+ assumes "C.ide f" and "C.ide g"
	+ and "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>" and "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>"
	+ and "adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
	+ (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
	+ shows "adjunction_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
	+ proof -
	+ let ?\<eta>' = "D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)"
	+ let ?\<epsilon>' = "D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)"
	+ interpret A': adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> \<open>F g\<close> ?\<eta>' ?\<epsilon>'
	+ using assms(5) by auto
	+ interpret A: adjunction_data_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>
	+ using assms(1-4) by (unfold_locales, auto)
	+ show ?thesis
	+ proof
	+ show "(\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>) = \<l>\<^sub>C\<^sup>-\<^sup>1[f] \<cdot>\<^sub>C \<r>\<^sub>C[f]"
	+ proof -
	+ have 1: "C.par ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>)) (\<l>\<^sub>C\<^sup>-\<^sup>1[f] \<cdot>\<^sub>C \<r>\<^sub>C[f])"
	+ using assms A.antipar C.hseqI' by simp
	+ moreover have "F ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>)) = F (\<l>\<^sub>C\<^sup>-\<^sup>1[f] \<cdot>\<^sub>C \<r>\<^sub>C[f])"
	+ proof -
	+ have "F ((\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>C \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>C (f \<star>\<^sub>C \<eta>)) =
	+ F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>)"
	+ using 1 by auto
	+ also have "... =
	+ (F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f)) \<cdot>\<^sub>D
	+ (\<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, g \<star>\<^sub>C f)) \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>))"
	+ using assms A.antipar preserves_assoc(2) D.comp_assoc by auto
	+ also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D ((F \<epsilon> \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F f)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D
	+ ((F f \<star>\<^sub>D D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<eta>)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f, src\<^sub>C f))"
	+ proof -
	+ have "F (\<epsilon> \<star>\<^sub>C f) \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, f) = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (F \<epsilon> \<star>\<^sub>D F f)"
	+ using assms \<Phi>.naturality [of "(\<epsilon>, f)"] FF_def C.VV.arr_char by simp
	+ moreover have "D.inv (\<Phi> (f, g \<star>\<^sub>C f)) \<cdot>\<^sub>D F (f \<star>\<^sub>C \<eta>) =
	+ (F f \<star>\<^sub>D F \<eta>) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
	+ proof -
	+ have "F (f \<star>\<^sub>C \<eta>) \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) = \<Phi> (f, g \<star>\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<eta>)"
	+ using assms \<Phi>.naturality [of "(f, \<eta>)"] FF_def C.VV.arr_char A.antipar
	+ by simp
	+ thus ?thesis
	+ using assms A.antipar \<Phi>_components_are_iso C.VV.arr_char \<Phi>_in_hom
	+ FF_def D.hseqI'
	+ D.invert_opposite_sides_of_square
	+ [of "\<Phi> (f, g \<star>\<^sub>C f)" "F f \<star>\<^sub>D F \<eta>" "F (f \<star>\<^sub>C \<eta>)" "\<Phi> (f, src\<^sub>C f)"]
	+ by fastforce
	+ qed
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta>) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
	+ using assms A.antipar \<Phi>_in_hom A.ide_left A.ide_right A'.ide_left A'.ide_right
	+ D.whisker_left [of "F f" "D.inv (\<Phi> (g, f))" "F \<eta>"]
	+ D.whisker_right [of "F f" "F \<epsilon>" "\<Phi> (f, g)"]
	+ by (metis A'.counit_in_vhom A'.unit_simps(1)D.arrI D.comp_assoc
	+ D.src.preserves_reflects_arr D.src_vcomp D.vseq_implies_hpar(1) \<Phi>_simps(2))
	+ also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D ?\<epsilon>' \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D ?\<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
	+ proof -
	+ have "F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) = \<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D ?\<epsilon>'"
	+ proof -
	+ have "D.iso (\<Psi> (trg\<^sub>C f))"
	+ using A.ide_left C.ideD(1) \<Psi>_char(2) by blast
	+ thus ?thesis
	+ by (metis A'.counit_simps(1) D.comp_assoc D.comp_cod_arr D.inv_is_inverse
	+ D.seqE D.comp_arr_inv)
	+ qed
	+ moreover have "D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> = ?\<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))"
	+ using assms(2) \<Psi>_char D.comp_arr_inv D.inv_is_inverse D.comp_assoc D.comp_cod_arr
	+ by (metis A'.unit_simps(1) A.antipar(1) C.ideD(1) C.obj_trg
	+ D.invert_side_of_triangle(2))
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D ((\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ (?\<epsilon>' \<star>\<^sub>D F f)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D ((F f \<star>\<^sub>D ?\<eta>') \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
	+ using assms A.antipar A'.antipar \<Psi>_char D.whisker_left D.whisker_right
	+ by simp
	+ also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ ((?\<epsilon>' \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D ?\<eta>')) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
	+ using D.comp_assoc by simp
	+ also have "... = (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f]) \<cdot>\<^sub>D
	+ \<r>\<^sub>D[F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
	+ using A'.triangle_left D.comp_assoc by simp
	+ also have "... = F \<l>\<^sub>C\<^sup>-\<^sup>1[f] \<cdot>\<^sub>D F \<r>\<^sub>C[f]"
	+ using assms A.antipar preserves_lunit(2) preserves_runit(1) by simp
	+ also have "... = F (\<l>\<^sub>C\<^sup>-\<^sup>1[f] \<cdot>\<^sub>C \<r>\<^sub>C[f])"
	+ using assms by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using is_faithful by blast
	+ qed
	+ show "(g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>C \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>C (\<eta> \<star>\<^sub>C g) = \<r>\<^sub>C\<^sup>-\<^sup>1[g] \<cdot>\<^sub>C \<l>\<^sub>C[g]"
	+ proof -
	+ have 1: "C.par ((g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>C \<a>\<^sub>C g f g \<cdot>\<^sub>C (\<eta> \<star>\<^sub>C g)) (\<r>\<^sub>C\<^sup>-\<^sup>1[g] \<cdot>\<^sub>C \<l>\<^sub>C[g])"
	+ using assms A.antipar C.hseqI' by auto
	+ moreover have "F ((g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>C \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>C (\<eta> \<star>\<^sub>C g)) = F (\<r>\<^sub>C\<^sup>-\<^sup>1[g] \<cdot>\<^sub>C \<l>\<^sub>C[g])"
	+ proof -
	+ have "F ((g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>C \<a>\<^sub>C g f g \<cdot>\<^sub>C (\<eta> \<star>\<^sub>C g)) =
	+ F (g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>D F \<a>\<^sub>C[g, f, g] \<cdot>\<^sub>D F (\<eta> \<star>\<^sub>C g)"
	+ using 1 by auto
	+ also have "... = (F (g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>D \<Phi> (g, f \<star>\<^sub>C g)) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Phi> (g \<star>\<^sub>C f, g)) \<cdot>\<^sub>D F (\<eta> \<star>\<^sub>C g))"
	+ using assms A.antipar preserves_assoc(1) [of g f g] D.comp_assoc by auto
	+ also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D ((F g \<star>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D (F \<eta> \<star>\<^sub>D F g)) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ proof -
	+ have "F (g \<star>\<^sub>C \<epsilon>) \<cdot>\<^sub>D \<Phi> (g, f \<star>\<^sub>C g) = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<epsilon>)"
	+ using assms \<Phi>.naturality [of "(g, \<epsilon>)"] FF_def C.VV.arr_char by auto
	+ moreover have "D.inv (\<Phi> (g \<star>\<^sub>C f, g)) \<cdot>\<^sub>D F (\<eta> \<star>\<^sub>C g) =
	+ (F \<eta> \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ proof -
	+ have "F (\<eta> \<star>\<^sub>C g) \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) = \<Phi> (g \<star>\<^sub>C f, g) \<cdot>\<^sub>D (F \<eta> \<star>\<^sub>D F g)"
	+ using assms \<Phi>.naturality [of "(\<eta>, g)"] FF_def C.VV.arr_char A.antipar
	+ by auto
	+ thus ?thesis
	+ using assms A.antipar \<Phi>_components_are_iso C.VV.arr_char FF_def D.hseqI'
	+ D.invert_opposite_sides_of_square
	+ [of "\<Phi> (g \<star>\<^sub>C f, g)" "F \<eta> \<star>\<^sub>D F g" "F (\<eta> \<star>\<^sub>C g)" "\<Phi> (trg\<^sub>C g, g)"]
	+ by fastforce
	+ qed
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have " ... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ proof -
	+ have "(F g \<star>\<^sub>D F \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Phi> (f, g)) = F g \<star>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)"
	+ using assms A.antipar D.whisker_left
	+ by (metis A'.counit_simps(1) A'.ide_right D.seqE)
	+ moreover have "(D.inv (\<Phi> (g, f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D (F \<eta> \<star>\<^sub>D F g) =
	+ D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<star>\<^sub>D F g"
	+ using assms A.antipar D.whisker_right by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D ?\<epsilon>') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D
	+ (?\<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ proof -
	+ have "F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) = \<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D ?\<epsilon>'"
	+ using \<Psi>_char D.comp_arr_inv D.inv_is_inverse D.comp_assoc D.comp_cod_arr
	+ by (metis A'.counit_simps(1) C.ideD(1) C.obj_trg D.seqE assms(1))
	+ moreover have "D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> = ?\<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))"
	+ using \<Psi>_char D.comp_arr_inv D.inv_is_inverse D.comp_assoc D.comp_cod_arr
	+ by (metis A'.unit_simps(1) A.unit_simps(1) A.unit_simps(5)
	+ C.obj_trg D.invert_side_of_triangle(2))
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D
	+ ((F g \<star>\<^sub>D ?\<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[F g, F f, F g] \<cdot>\<^sub>D (?\<eta>' \<star>\<^sub>D F g)) \<cdot>\<^sub>D
	+ (D.inv (\<Psi> (src\<^sub>C f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ using assms A.antipar \<Psi>_char D.whisker_left D.whisker_right D.comp_assoc
	+ by simp
	+ also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F g] \<cdot>\<^sub>D
	+ \<l>\<^sub>D[F g] \<cdot>\<^sub>D (D.inv (\<Psi> (src\<^sub>C f)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ using A'.triangle_right D.comp_assoc by simp
	+ also have "... = F \<r>\<^sub>C\<^sup>-\<^sup>1[g] \<cdot>\<^sub>D F \<l>\<^sub>C[g]"
	+ using assms A.antipar preserves_lunit(1) preserves_runit(2) D.comp_assoc
	+ by simp
	+ also have "... = F (\<r>\<^sub>C\<^sup>-\<^sup>1[g] \<cdot>\<^sub>C \<l>\<^sub>C[g])"
	+ using assms by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using is_faithful by blast
	+ qed
	+ qed
	+ qed
	+
	+ lemma reflects_adjoint_pair:
	+ assumes "C.ide f" and "C.ide g"
	+ and "src\<^sub>C f = trg\<^sub>C g" and "src\<^sub>C g = trg\<^sub>C f"
	+ and "D.adjoint_pair (F f) (F g)"
	+ shows "C.adjoint_pair f g"
	+ proof -
	+ obtain \<eta>' \<epsilon>' where A': "adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g) \<eta>' \<epsilon>'"
	+ using assms D.adjoint_pair_def by auto
	+ interpret A': adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> \<open>F g\<close> \<eta>' \<epsilon>'
	+ using A' by auto
	+ have 1: "\<guillemotleft>\<Phi> (g, f) \<cdot>\<^sub>D \<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)) : F (src\<^sub>C f) \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C f)\<guillemotright>"
	+ using assms \<Psi>_char [of "src\<^sub>C f"] A'.unit_in_hom
	+ by (intro D.comp_in_homI, auto)
	+ have 2: "\<guillemotleft>\<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D \<epsilon>' \<cdot>\<^sub>D D.inv (\<Phi> (f, g)): F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
	+ using assms \<Phi>_in_hom [of f g] \<Psi>_char [of "trg\<^sub>C f"] A'.counit_in_hom
	+ by (intro D.comp_in_homI, auto)
	+ obtain \<eta> where \<eta>: "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright> \<and>
	+ F \<eta> = \<Phi> (g, f) \<cdot>\<^sub>D \<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))"
	+ using assms 1 A'.unit_in_hom \<Phi>_in_hom locally_full by fastforce
	+ have \<eta>': "\<eta>' = D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)"
	+ using assms 1 \<eta> \<Phi>_in_hom \<Phi>.components_are_iso C.VV.ide_char C.VV.arr_char D.iso_inv_iso
	+ \<Phi>_components_are_iso \<Psi>_char(2)
	+ D.invert_side_of_triangle(1) [of "F \<eta>" "\<Phi> (g, f)" "\<eta>' \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))"]
	+ D.invert_side_of_triangle(2) [of "D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta>" \<eta>' "D.inv (\<Psi> (src\<^sub>C f))"]
	+ by (metis (no_types, lifting) C.ideD(1) C.obj_trg D.arrI D.comp_assoc D.inv_inv)
	+ obtain \<epsilon> where \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C trg\<^sub>C f\<guillemotright> \<and>
	+ F \<epsilon> = \<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D \<epsilon>' \<cdot>\<^sub>D D.inv (\<Phi> (f, g))"
	+ using assms 2 A'.counit_in_hom \<Phi>_in_hom locally_full by fastforce
	+ have \<epsilon>': "\<epsilon>' = D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)"
	+ using assms 2 \<epsilon> \<Phi>_in_hom \<Phi>.components_are_iso C.VV.ide_char C.VV.arr_char D.iso_inv_iso
	+ \<Psi>_char(2) D.comp_assoc
	+ D.invert_side_of_triangle(1) [of "F \<epsilon>" "\<Psi> (trg\<^sub>C f)" "\<epsilon>' \<cdot>\<^sub>D D.inv (\<Phi> (f, g))"]
	+ D.invert_side_of_triangle(2) [of "D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon>" \<epsilon>' "D.inv (\<Phi> (f, g))"]
	+ by (metis (no_types, lifting) C.arrI C.ideD(1) C.obj_trg D.inv_inv \<Phi>_components_are_iso
	+ preserves_arr)
	+ have "adjunction_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
	+ (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
	+ using A'.adjunction_in_bicategory_axioms \<eta>' \<epsilon>' by simp
	+ hence "adjunction_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
	+ using assms \<eta> \<epsilon> reflects_adjunction by simp
	+ thus ?thesis
	+ using C.adjoint_pair_def by auto
	+ qed
	+
	+ lemma reflects_left_adjoint:
	+ assumes "C.ide f" and "D.is_left_adjoint (F f)"
	+ shows "C.is_left_adjoint f"
	+ proof -
	+ obtain g' where g': "D.adjoint_pair (F f) g'"
	+ using assms D.adjoint_pair_def by auto
	+ obtain g where g: "\<guillemotleft>g : trg\<^sub>C f \<rightarrow>\<^sub>C src\<^sub>C f\<guillemotright> \<and> C.ide g \<and> D.isomorphic (F g) g'"
	+ using assms g' locally_essentially_surjective [of "trg\<^sub>C f" "src\<^sub>C f" g']
	+ D.adjoint_pair_antipar [of "F f" g']
	+ by auto
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : g' \<Rightarrow>\<^sub>D F g\<guillemotright> \<and> D.iso \<phi>"
	+ using g D.isomorphic_def D.isomorphic_symmetric by metis
	+ have "D.adjoint_pair (F f) (F g)"
	+ using assms g g' \<phi> D.adjoint_pair_preserved_by_iso [of "F f" g' "F f" "F f" \<phi> "F g"]
	+ by auto
	+ thus ?thesis
	+ using assms g reflects_adjoint_pair [of f g] D.adjoint_pair_antipar C.in_hhom_def
	+ by auto
	+ qed
	+
	+ lemma reflects_right_adjoint:
	+ assumes "C.ide g" and "D.is_right_adjoint (F g)"
	+ shows "C.is_right_adjoint g"
	+ proof -
	+ obtain f' where f': "D.adjoint_pair f' (F g)"
	+ using assms D.adjoint_pair_def by auto
	+ obtain f where f: "\<guillemotleft>f : trg\<^sub>C g \<rightarrow>\<^sub>C src\<^sub>C g\<guillemotright> \<and> C.ide f \<and> D.isomorphic (F f) f'"
	+ using assms f' locally_essentially_surjective [of "trg\<^sub>C g" "src\<^sub>C g" f']
	+ D.adjoint_pair_antipar [of f' "F g"]
	+ by auto
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : f' \<Rightarrow>\<^sub>D F f\<guillemotright> \<and> D.iso \<phi>"
	+ using f D.isomorphic_def D.isomorphic_symmetric by metis
	+ have "D.adjoint_pair (F f) (F g)"
	+ using assms f f' \<phi> D.adjoint_pair_preserved_by_iso [of f' "F g" \<phi> "F f" "F g" "F g"]
	+ by auto
	+ thus ?thesis
	+ using assms f reflects_adjoint_pair [of f g] D.adjoint_pair_antipar C.in_hhom_def
	+ by auto
	+ qed
	+
	+ end
	+
	+ subsection "Composition of Adjunctions"
	+
	+ text \<open>
	+ We first consider the strict case, then extend to all bicategories using strictification.
	+ \<close>
	+
	+ locale composite_adjunction_in_strict_bicategory =
	+ strict_bicategory V H \<a> \<i> src trg +
	+ fg: adjunction_in_strict_bicategory V H \<a> \<i> src trg f g \<zeta> \<xi> +
	+ hk: adjunction_in_strict_bicategory V H \<a> \<i> src trg h k \<sigma> \<tau>
	+ for V :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and f :: "'a"
	+ and g :: "'a"
	+ and \<zeta> :: "'a"
	+ and \<xi> :: "'a"
	+ and h :: "'a"
	+ and k :: "'a"
	+ and \<sigma> :: "'a"
	+ and \<tau> :: "'a" +
	+ assumes composable: "src h = trg f"
	+ begin
	+
	+ abbreviation \<eta>
	+ where "\<eta> \<equiv> (g \<star> \<sigma> \<star> f) \<cdot> \<zeta>"
	+
	+ abbreviation \<epsilon>
	+ where "\<epsilon> \<equiv> \<tau> \<cdot> (h \<star> \<xi> \<star> k)"
	+
	+ interpretation adjunction_data_in_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
	+ proof
	+ show "ide (h \<star> f)"
	+ using composable by simp
	+ show "ide (g \<star> k)"
	+ using fg.antipar hk.antipar composable by simp
	+ show "\<guillemotleft>\<eta> : src (h \<star> f) \<Rightarrow> (g \<star> k) \<star> h \<star> f\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>\<zeta> : src (h \<star> f) \<Rightarrow> g \<star> f\<guillemotright>"
	+ using fg.antipar hk.antipar composable \<open>ide (h \<star> f)\<close> by auto
	+ show "\<guillemotleft>g \<star> \<sigma> \<star> f : g \<star> f \<Rightarrow> (g \<star> k) \<star> h \<star> f\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>g \<star> \<sigma> \<star> f : g \<star> trg f \<star> f \<Rightarrow> g \<star> (k \<star> h) \<star> f\<guillemotright>"
	+ using fg.antipar hk.antipar composable hk.unit_in_hom
	+ by (simp add: ide_in_hom(2))
	+ thus ?thesis
	+ using hcomp_obj_arr hcomp_assoc by fastforce
	+ qed
	+ qed
	+ show "\<guillemotleft>\<epsilon> : (h \<star> f) \<star> g \<star> k \<Rightarrow> src (g \<star> k)\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>h \<star> \<xi> \<star> k : (h \<star> f) \<star> g \<star> k \<Rightarrow> h \<star> k\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>h \<star> \<xi> \<star> k : h \<star> (f \<star> g) \<star> k \<Rightarrow> h \<star> trg f \<star> k\<guillemotright>"
	+ using composable fg.antipar(1-2) hk.antipar(1) by fastforce
	+ thus ?thesis
	+ using fg.antipar hk.antipar composable hk.unit_in_hom hcomp_obj_arr hcomp_assoc
	+ by simp
	+ qed
	+ show "\<guillemotleft>\<tau> : h \<star> k \<Rightarrow> src (g \<star> k)\<guillemotright>"
	+ using fg.antipar hk.antipar composable hk.unit_in_hom by auto
	+ qed
	+ qed
	+
	+ sublocale adjunction_in_strict_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
	+ proof
	+ show "(\<epsilon> \<star> h \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[h \<star> f, g \<star> k, h \<star> f] \<cdot> ((h \<star> f) \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[h \<star> f] \<cdot> \<r>[h \<star> f]"
	+ proof -
	+ have "(\<epsilon> \<star> h \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[h \<star> f, g \<star> k, h \<star> f] \<cdot> ((h \<star> f) \<star> \<eta>) =
	+ (\<tau> \<cdot> (h \<star> \<xi> \<star> k) \<star> h \<star> f) \<cdot> ((h \<star> f) \<star> (g \<star> \<sigma> \<star> f) \<cdot> \<zeta>)"
	+ using fg.antipar hk.antipar composable strict_assoc comp_ide_arr
	+ ide_left ide_right antipar(1) antipar(2)
	+ by (metis arrI seqE strict_assoc' triangle_in_hom(1))
	+ also have "... = (\<tau> \<star> h \<star> f) \<cdot> ((h \<star> \<xi> \<star> (k \<star> h) \<star> f) \<cdot> (h \<star> (f \<star> g) \<star> \<sigma> \<star> f)) \<cdot> (h \<star> f \<star> \<zeta>)"
	+ using fg.antipar hk.antipar composable whisker_left [of "h \<star> f"] whisker_right
	+ comp_assoc hcomp_assoc
	+ by simp
	+ also have "... = (\<tau> \<star> h \<star> f) \<cdot> (h \<star> (\<xi> \<star> (k \<star> h)) \<cdot> ((f \<star> g) \<star> \<sigma>) \<star> f) \<cdot> (h \<star> f \<star> \<zeta>)"
	+ using fg.antipar hk.antipar composable whisker_left whisker_right hcomp_assoc
	+ by (simp add: hseqI')
	+ also have "... = (\<tau> \<star> h \<star> f) \<cdot> (h \<star> (trg f \<star> \<sigma>) \<cdot> (\<xi> \<star> trg f) \<star> f) \<cdot> (h \<star> f \<star> \<zeta>)"
	+ using fg.antipar hk.antipar composable comp_arr_dom comp_cod_arr
	+ interchange [of \<xi> "f \<star> g" "k \<star> h" \<sigma>] interchange [of "trg f" \<xi> \<sigma> "trg f"]
	+ by auto
	+ also have "... = (\<tau> \<star> h \<star> f) \<cdot> (h \<star> \<sigma> \<cdot> \<xi> \<star> f) \<cdot> (h \<star> f \<star> \<zeta>)"
	+ using fg.antipar hk.antipar composable hcomp_obj_arr hcomp_arr_obj
	+ by (metis fg.counit_simps(1) fg.counit_simps(4) hk.unit_simps(1) hk.unit_simps(5)
	+ obj_src)
	+ also have "... = ((\<tau> \<star> h \<star> f) \<cdot> (h \<star> \<sigma> \<star> f)) \<cdot> ((h \<star> \<xi> \<star> f) \<cdot> (h \<star> f \<star> \<zeta>))"
	+ using fg.antipar hk.antipar composable whisker_left whisker_right comp_assoc
	+ by (simp add: hseqI')
	+ also have "... = ((\<tau> \<star> h) \<cdot> (h \<star> \<sigma>) \<star> f) \<cdot> (h \<star> (\<xi> \<star> f) \<cdot> (f \<star> \<zeta>))"
	+ using fg.antipar hk.antipar composable whisker_left whisker_right hcomp_assoc
	+ by (simp add: hseqI')
	+ also have "... = h \<star> f"
	+ using fg.antipar hk.antipar composable fg.triangle_left hk.triangle_left
	+ by simp
	+ also have "... = \<l>\<^sup>-\<^sup>1[h \<star> f] \<cdot> \<r>[h \<star> f]"
	+ using fg.antipar hk.antipar composable strict_lunit' strict_runit by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "((g \<star> k) \<star> \<epsilon>) \<cdot> \<a>[g \<star> k, h \<star> f, g \<star> k] \<cdot> (\<eta> \<star> g \<star> k) = \<r>\<^sup>-\<^sup>1[g \<star> k] \<cdot> \<l>[g \<star> k]"
	+ proof -
	+ have "((g \<star> k) \<star> \<epsilon>) \<cdot> \<a>[g \<star> k, h \<star> f, g \<star> k] \<cdot> (\<eta> \<star> g \<star> k) =
	+ ((g \<star> k) \<star> \<tau> \<cdot> (h \<star> \<xi> \<star> k)) \<cdot> ((g \<star> \<sigma> \<star> f) \<cdot> \<zeta> \<star> g \<star> k)"
	+ using fg.antipar hk.antipar composable strict_assoc comp_ide_arr
	+ ide_left ide_right
	+ by (metis antipar(1) antipar(2) arrI seqE triangle_in_hom(2))
	+ also have "... = (g \<star> k \<star> \<tau>) \<cdot> ((g \<star> (k \<star> h) \<star> \<xi> \<star> k) \<cdot> (g \<star> \<sigma> \<star> (f \<star> g) \<star> k)) \<cdot> (\<zeta> \<star> g \<star> k)"
	+ using fg.antipar hk.antipar composable whisker_left [of "g \<star> k"] whisker_right
	+ comp_assoc hcomp_assoc
	+ by simp
	+ also have "... = (g \<star> k \<star> \<tau>) \<cdot> (g \<star> ((k \<star> h) \<star> \<xi>) \<cdot> (\<sigma> \<star> f \<star> g) \<star> k) \<cdot> (\<zeta> \<star> g \<star> k)"
	+ using fg.antipar hk.antipar composable whisker_left whisker_right hcomp_assoc
	+ by (simp add: hseqI')
	+ also have "... = (g \<star> k \<star> \<tau>) \<cdot> (g \<star> (\<sigma> \<star> src g) \<cdot> (src g \<star> \<xi>) \<star> k) \<cdot> (\<zeta> \<star> g \<star> k)"
	+ using fg.antipar hk.antipar composable interchange [of "k \<star> h" \<sigma> \<xi> "f \<star> g"]
	+ interchange [of \<sigma> "src g" "src g" \<xi>] comp_arr_dom comp_cod_arr
	+ by simp
	+ also have "... = (g \<star> k \<star> \<tau>) \<cdot> (g \<star> \<sigma> \<cdot> \<xi> \<star> k) \<cdot> (\<zeta> \<star> g \<star> k)"
	+ using fg.antipar hk.antipar composable hcomp_obj_arr [of "src g" \<xi>]
	+ hcomp_arr_obj [of \<sigma> "src g"]
	+ by simp
	+ also have "... = ((g \<star> k \<star> \<tau>) \<cdot> (g \<star> \<sigma> \<star> k)) \<cdot> (g \<star> \<xi> \<star> k) \<cdot> (\<zeta> \<star> g \<star> k)"
	+ using fg.antipar hk.antipar composable whisker_left whisker_right comp_assoc
	+ by (simp add: hseqI')
	+ also have "... = (g \<star> (k \<star> \<tau>) \<cdot> (\<sigma> \<star> k)) \<cdot> ((g \<star> \<xi>) \<cdot> (\<zeta> \<star> g) \<star> k)"
	+ using fg.antipar hk.antipar composable whisker_left whisker_right hcomp_assoc
	+ by (simp add: hseqI')
	+ also have "... = g \<star> k"
	+ using fg.antipar hk.antipar composable fg.triangle_right hk.triangle_right
	+ by simp
	+ also have "... = \<r>\<^sup>-\<^sup>1[g \<star> k] \<cdot> \<l>[g \<star> k]"
	+ using fg.antipar hk.antipar composable strict_lunit strict_runit' by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma is_adjunction_in_strict_bicategory:
	+ shows "adjunction_in_strict_bicategory V H \<a> \<i> src trg (h \<star> f) (g \<star> k) \<eta> \<epsilon>"
	+ ..
	+
	+ end
	+
	+ context strict_bicategory
	+ begin
	+
	+ lemma left_adjoints_compose:
	+ assumes "is_left_adjoint f" and "is_left_adjoint f'" and "src f' = trg f"
	+ shows "is_left_adjoint (f' \<star> f)"
	+ proof -
	+ obtain g \<eta> \<epsilon> where fg: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms adjoint_pair_def by auto
	+ interpret fg: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using fg by auto
	+ obtain g' \<eta>' \<epsilon>' where f'g': "adjunction_in_bicategory V H \<a> \<i> src trg f' g' \<eta>' \<epsilon>'"
	+ using assms adjoint_pair_def by auto
	+ interpret f'g': adjunction_in_bicategory V H \<a> \<i> src trg f' g' \<eta>' \<epsilon>'
	+ using f'g' by auto
	+ interpret f'fgg': composite_adjunction_in_strict_bicategory V H \<a> \<i> src trg
	+ f g \<eta> \<epsilon> f' g' \<eta>' \<epsilon>'
	+ using assms apply unfold_locales by simp
	+ have "adjoint_pair (f' \<star> f) (g \<star> g')"
	+ using adjoint_pair_def f'fgg'.adjunction_in_bicategory_axioms by auto
	+ thus ?thesis by auto
	+ qed
	+
	+ lemma right_adjoints_compose:
	+ assumes "is_right_adjoint g" and "is_right_adjoint g'" and "src g = trg g'"
	+ shows "is_right_adjoint (g \<star> g')"
	+ proof -
	+ obtain f \<eta> \<epsilon> where fg: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms adjoint_pair_def by auto
	+ interpret fg: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using fg by auto
	+ obtain f' \<eta>' \<epsilon>' where f'g': "adjunction_in_bicategory V H \<a> \<i> src trg f' g' \<eta>' \<epsilon>'"
	+ using assms adjoint_pair_def by auto
	+ interpret f'g': adjunction_in_bicategory V H \<a> \<i> src trg f' g' \<eta>' \<epsilon>'
	+ using f'g' by auto
	+ interpret f'fgg': composite_adjunction_in_strict_bicategory V H \<a> \<i> src trg
	+ f g \<eta> \<epsilon> f' g' \<eta>' \<epsilon>'
	+ using assms fg.antipar f'g'.antipar apply unfold_locales by simp
	+ have "adjoint_pair (f' \<star> f) (g \<star> g')"
	+ using adjoint_pair_def f'fgg'.adjunction_in_bicategory_axioms by auto
	+ thus ?thesis by auto
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ We now use strictification to extend the preceding results to an arbitrary bicategory.
	+ We only prove that ``left adjoints compose'' and ``right adjoints compose'';
	+ I did not work out formulas for the unit and counit of the composite adjunction in the
	+ non-strict case.
	+ \<close>
	+
	+ context bicategory
	+ begin
	+
	+ interpretation S: strictified_bicategory V H \<a> \<i> src trg ..
	+
	+ notation S.vcomp (infixr "\<cdot>\<^sub>S" 55)
	+ notation S.hcomp (infixr "\<star>\<^sub>S" 53)
	+ notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
	+ notation S.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
	+
	+ interpretation UP: fully_faithful_functor V S.vcomp S.UP
	+ using S.UP_is_fully_faithful_functor by auto
	+ interpretation UP: equivalence_pseudofunctor V H \<a> \<i> src trg
	+ S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
	+ using S.UP_is_equivalence_pseudofunctor by auto
	+
	+ lemma left_adjoints_compose:
	+ assumes "is_left_adjoint f" and "is_left_adjoint f'" and "src f = trg f'"
	+ shows "is_left_adjoint (f \<star> f')"
	+ proof -
	+ have "S.is_left_adjoint (S.UP f) \<and> S.is_left_adjoint (S.UP f')"
	+ using assms UP.preserves_left_adjoint by simp
	+ moreover have "S.src (S.UP f) = S.trg (S.UP f')"
	+ using assms left_adjoint_is_ide by simp
	+ ultimately have "S.is_left_adjoint (S.hcomp (S.UP f) (S.UP f'))"
	+ using S.left_adjoints_compose by simp
	+ moreover have "S.isomorphic (S.hcomp (S.UP f) (S.UP f')) (S.UP (f \<star> f'))"
	+ proof -
	+ have "\<guillemotleft>S.\<Phi> (f, f') : S.hcomp (S.UP f) (S.UP f') \<Rightarrow>\<^sub>S S.UP (f \<star> f')\<guillemotright>"
	+ using assms left_adjoint_is_ide UP.\<Phi>_in_hom by simp
	+ moreover have "S.iso (S.\<Phi> (f, f'))"
	+ using assms left_adjoint_is_ide by simp
	+ ultimately show ?thesis
	+ using S.isomorphic_def by blast
	+ qed
	+ ultimately have "S.is_left_adjoint (S.UP (f \<star> f'))"
	+ using S.left_adjoint_preserved_by_iso S.isomorphic_def by blast
	+ thus "is_left_adjoint (f \<star> f')"
	+ using assms left_adjoint_is_ide UP.reflects_left_adjoint by simp
	+ qed
	+
	+ lemma right_adjoints_compose:
	+ assumes "is_right_adjoint g" and "is_right_adjoint g'" and "src g' = trg g"
	+ shows "is_right_adjoint (g' \<star> g)"
	+ proof -
	+ have "S.is_right_adjoint (S.UP g) \<and> S.is_right_adjoint (S.UP g')"
	+ using assms UP.preserves_right_adjoint by simp
	+ moreover have "S.src (S.UP g') = S.trg (S.UP g)"
	+ using assms right_adjoint_is_ide by simp
	+ ultimately have "S.is_right_adjoint (S.hcomp (S.UP g') (S.UP g))"
	+ using S.right_adjoints_compose by simp
	+ moreover have "S.isomorphic (S.hcomp (S.UP g') (S.UP g)) (S.UP (g' \<star> g))"
	+ proof -
	+ have "\<guillemotleft>S.\<Phi> (g', g) : S.hcomp (S.UP g') (S.UP g) \<Rightarrow>\<^sub>S S.UP (g' \<star> g)\<guillemotright>"
	+ using assms right_adjoint_is_ide UP.\<Phi>_in_hom by simp
	+ moreover have "S.iso (S.\<Phi> (g', g))"
	+ using assms right_adjoint_is_ide by simp
	+ ultimately show ?thesis
	+ using S.isomorphic_def by blast
	+ qed
	+ ultimately have "S.is_right_adjoint (S.UP (g' \<star> g))"
	+ using S.right_adjoint_preserved_by_iso S.isomorphic_def by blast
	+ thus "is_right_adjoint (g' \<star> g)"
	+ using assms right_adjoint_is_ide UP.reflects_right_adjoint by simp
	+ qed
	+
	+ end
	+
	+ subsection "Choosing Right Adjoints"
	+
	+ text \<open>
	+ It will be useful in various situations to suppose that we have made a choice of
	+ right adjoint for each left adjoint ({\it i.e.} each ``map'') in a bicategory.
	+ \<close>
	+
	+ locale chosen_right_adjoints =
	+ bicategory
	+ begin
	+
	+ (* Global notation is evil! *)
	+ no_notation Transitive_Closure.rtrancl ("(_\<^sup>*)" [1000] 999)
	+
	+ definition some_right_adjoint ("_\<^sup>*" [1000] 1000)
	+ where "f\<^sup>* \<equiv> SOME g. adjoint_pair f g"
	+
	+ definition some_unit
	+ where "some_unit f \<equiv> SOME \<eta>. \<exists>\<epsilon>. adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sup>* \<eta> \<epsilon>"
	+
	+ definition some_counit
	+ where "some_counit f \<equiv>
	+ SOME \<epsilon>. adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sup>* (some_unit f) \<epsilon>"
	+
	+ lemma left_adjoint_extends_to_adjunction:
	+ assumes "is_left_adjoint f"
	+ shows "adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sup>* (some_unit f) (some_counit f)"
	+ using assms some_right_adjoint_def adjoint_pair_def some_unit_def some_counit_def
	+ someI_ex [of "\<lambda>g. adjoint_pair f g"]
	+ someI_ex [of "\<lambda>\<eta>. \<exists>\<epsilon>. adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sup>* \<eta> \<epsilon>"]
	+ someI_ex [of "\<lambda>\<epsilon>. adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sup>* (some_unit f) \<epsilon>"]
	+ by auto
	+
	+ lemma left_adjoint_extends_to_adjoint_pair:
	+ assumes "is_left_adjoint f"
	+ shows "adjoint_pair f f\<^sup>*"
	+ using assms adjoint_pair_def left_adjoint_extends_to_adjunction by blast
	+
	+ lemma right_adjoint_in_hom [intro]:
	+ assumes "is_left_adjoint f"
	+ shows "\<guillemotleft>f\<^sup>* : trg f \<rightarrow> src f\<guillemotright>"
	+ and "\<guillemotleft>f\<^sup>* : f\<^sup>* \<Rightarrow> f\<^sup>*\<guillemotright>"
	+ using assms left_adjoint_extends_to_adjoint_pair adjoint_pair_antipar [of f "f\<^sup>*"]
	+ by auto
	+
	+ lemma right_adjoint_simps [simp]:
	+ assumes "is_left_adjoint f"
	+ shows "ide f\<^sup>*"
	+ and "src f\<^sup>* = trg f" and "trg f\<^sup>* = src f"
	+ and "dom f\<^sup>* = f\<^sup>" and "cod f\<^sup> = f\<^sup>*"
	+ using assms right_adjoint_in_hom left_adjoint_extends_to_adjoint_pair apply auto
	+ using assms right_adjoint_is_ide [of "f\<^sup>*"] by blast
	+
	+ end
	+
	+ locale map_in_bicategory =
	+ bicategory + chosen_right_adjoints +
	+ fixes f :: 'a
	+ assumes is_map: "is_left_adjoint f"
	+ begin
	+
	+ abbreviation \<eta>
	+ where "\<eta> \<equiv> some_unit f"
	+
	+ abbreviation \<epsilon>
	+ where "\<epsilon> \<equiv> some_counit f"
	+
	+ sublocale adjunction_in_bicategory V H \<a> \<i> src trg f \<open>f\<^sup>*\<close> \<eta> \<epsilon>
	+ using is_map left_adjoint_extends_to_adjunction by simp
	+
	+ end
	+
	+ subsection "Equivalences Refine to Adjoint Equivalences"
	+
	+ text \<open>
	+ In this section, we show that, just as an equivalence between categories can always
	+ be refined to an adjoint equivalence, an internal equivalence in a bicategory can also
	+ always be so refined.
	+ The proof, which follows that of Theorem 3.3 from \cite{nlab-adjoint-equivalence},
	+ makes use of the fact that if an internal equivalence satisfies one of the triangle
	+ identities, then it also satisfies the other.
	+ \<close>
	+
	+ locale adjoint_equivalence_in_bicategory =
	+ equivalence_in_bicategory +
	+ adjunction_in_bicategory
	+ begin
	+
	+ lemma dual_adjoint_equivalence:
	+ shows "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg g f (inv \<epsilon>) (inv \<eta>)"
	+ proof -
	+ interpret gf: equivalence_in_bicategory V H \<a> \<i> src trg g f \<open>inv \<epsilon>\<close> \<open>inv \<eta>\<close>
	+ using dual_equivalence by simp
	+ show ?thesis
	+ proof
	+ show "(inv \<eta> \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[g, f, g] \<cdot> (g \<star> inv \<epsilon>) = \<l>\<^sup>-\<^sup>1[g] \<cdot> \<r>[g]"
	+ proof -
	+ have "(inv \<eta> \<star> g) \<cdot> \<a>\<^sup>-\<^sup>1[g, f, g] \<cdot> (g \<star> inv \<epsilon>) =
	+ inv ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g))"
	+ using antipar inv_comp counit_is_iso iso_inv_iso isos_compose unit_is_iso
	+ comp_assoc hseqI'
	+ by simp
	+ also have "... = inv (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g])"
	+ using triangle_right by simp
	+ also have "... = \<l>\<^sup>-\<^sup>1[g] \<cdot> \<r>[g]"
	+ using iso_lunit iso_runit iso_inv_iso inv_comp by simp
	+ finally show ?thesis
	+ by blast
	+ qed
	+ show "(f \<star> inv \<eta>) \<cdot> \<a>[f, g, f] \<cdot> (inv \<epsilon> \<star> f) = \<r>\<^sup>-\<^sup>1[f] \<cdot> \<l>[f]"
	+ proof -
	+ have "(f \<star> inv \<eta>) \<cdot> \<a>[f, g, f] \<cdot> (inv \<epsilon> \<star> f) =
	+ inv ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>))"
	+ using antipar inv_comp counit_is_iso iso_inv_iso isos_compose unit_is_iso
	+ comp_assoc hseqI'
	+ by simp
	+ also have "... = inv (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
	+ using triangle_left by simp
	+ also have "... = \<r>\<^sup>-\<^sup>1[f] \<cdot> \<l>[f]"
	+ using iso_lunit iso_runit iso_inv_iso inv_comp by simp
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ context strict_bicategory
	+ begin
	+
	+ lemma equivalence_refines_to_adjoint_equivalence:
	+ assumes "equivalence_map f" and "\<guillemotleft>g : trg f \<rightarrow> src f\<guillemotright>" and "ide g"
	+ and "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>" and "iso \<eta>"
	+ shows "\<exists>!\<epsilon>. adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ proof -
	+ obtain g' \<eta>' \<epsilon>' where E': "equivalence_in_bicategory V H \<a> \<i> src trg f g' \<eta>' \<epsilon>'"
	+ using assms equivalence_map_def by auto
	+ interpret E': equivalence_in_bicategory V H \<a> \<i> src trg f g' \<eta>' \<epsilon>'
	+ using E' by auto
	+ let ?a = "src f" and ?b = "trg f"
	+ (* TODO: in_homE cannot be applied automatically to a conjunction. Must break down! *)
	+ have f_in_hhom: "\<guillemotleft>f : ?a \<rightarrow> ?b\<guillemotright>" and ide_f: "ide f"
	+ using assms equivalence_map_def by auto
	+ have g_in_hhom: "\<guillemotleft>g : ?b \<rightarrow> ?a\<guillemotright>" and ide_g: "ide g"
	+ using assms by auto
	+ have g'_in_hhom: "\<guillemotleft>g' : ?b \<rightarrow> ?a\<guillemotright>" and ide_g': "ide g'"
	+ using assms f_in_hhom E'.antipar by auto
	+ have \<eta>_in_hom: "\<guillemotleft>\<eta> : ?a \<Rightarrow> g \<star> f\<guillemotright>" and iso_\<eta>: "iso \<eta>"
	+ using assms by auto
	+ have a: "obj ?a" and b: "obj ?b"
	+ using f_in_hhom by auto
	+ have \<eta>_in_hhom: "\<guillemotleft>\<eta> : ?a \<rightarrow> ?a\<guillemotright>"
	+ using a src_dom trg_dom \<eta>_in_hom by fastforce
	+ text \<open>
	+ The following is quoted from \cite{nlab-adjoint-equivalence}:
	+ \begin{quotation}
	+ ``Since \<open>g \<cong> gfg' \<cong> g'\<close>, the isomorphism \<open>fg' \<cong> 1\<close> also induces an isomorphism \<open>fg \<cong> 1\<close>,
	+ which we denote \<open>\<xi>\<close>. Now \<open>\<eta>\<close> and \<open>\<xi>\<close> may not satisfy the zigzag identities, but if we
	+ define \<open>\<epsilon>\<close> by \<open>\<xi> \<cdot> (f \<star> \<eta>\<^sup>-\<^sup>1) \<cdot> (f \<star> g \<star> \<xi>\<^sup>-\<^sup>1) : f \<star> g \<Rightarrow> 1\<close>, then we can verify,
	+ using string diagram notation as above,
	+ that \<open>\<epsilon>\<close> satisfies one zigzag identity, and hence (by the previous lemma) also the other.
	+
	+ Finally, if \<open>\<epsilon>': fg \<Rightarrow> 1\<close> is any other isomorphism satisfying the zigzag identities
	+ with \<open>\<eta>\<close>, then we have:
	+ \[
	+ \<open>\<epsilon>' = \<epsilon>' \<cdot> (\<epsilon> f g) \<cdot> (f \<eta> g) = \<epsilon> \<cdot> (f g \<epsilon>') \<cdot> (f \<eta> g) = \<epsilon>\<close>
	+ \]
	+ using the interchange law and two zigzag identities. This shows uniqueness.''
	+ \end{quotation}
	+ \<close>
	+ have 1: "isomorphic g g'"
	+ proof -
	+ have "isomorphic g (g \<star> ?b)"
	+ using assms hcomp_arr_obj isomorphic_reflexive by auto
	+ also have "isomorphic ... (g \<star> f \<star> g')"
	+ using assms f_in_hhom g_in_hhom g'_in_hhom E'.counit_in_vhom E'.counit_is_iso
	+ isomorphic_def hcomp_ide_isomorphic isomorphic_symmetric
	+ by (metis E'.counit_simps(5) in_hhomE trg_trg)
	+ also have "isomorphic ... (?a \<star> g')"
	+ using assms f_in_hhom g_in_hhom g'_in_hhom ide_g' E'.unit_in_vhom E'.unit_is_iso
	+ isomorphic_def hcomp_isomorphic_ide isomorphic_symmetric
	+ by (metis hcomp_assoc hcomp_isomorphic_ide in_hhomE src_src)
	+ also have "isomorphic ... g'"
	+ using assms
	+ by (simp add: E'.antipar(1) hcomp_obj_arr isomorphic_reflexive)
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "isomorphic (f \<star> g') ?b"
	+ using E'.counit_is_iso isomorphicI [of \<epsilon>'] by auto
	+ hence 2: "isomorphic (f \<star> g) ?b"
	+ using assms 1 ide_f hcomp_ide_isomorphic [of f g g'] isomorphic_transitive
	+ isomorphic_symmetric
	+ by (metis in_hhomE)
	+ obtain \<xi> where \<xi>: "\<guillemotleft>\<xi> : f \<star> g \<Rightarrow> ?b\<guillemotright> \<and> iso \<xi>"
	+ using 2 by auto
	+ have \<xi>_in_hom: "\<guillemotleft>\<xi> : f \<star> g \<Rightarrow> ?b\<guillemotright>" and iso_\<xi>: "iso \<xi>"
	+ using \<xi> by auto
	+ have \<xi>_in_hhom: "\<guillemotleft>\<xi> : ?b \<rightarrow> ?b\<guillemotright>"
	+ using b src_cod trg_cod \<xi>_in_hom by fastforce
	+ text \<open>
	+ At the time of this writing, the definition of \<open>\<epsilon>\<close> given on nLab
	+ \cite{nlab-adjoint-equivalence} had an apparent typo:
	+ the expression \<open>f \<star> g \<star> \<xi>\<^sup>-\<^sup>1\<close> should read \<open>\<xi>\<^sup>-\<^sup>1 \<star> f \<star> g\<close>, as we have used here.
	+ \<close>
	+ let ?\<epsilon> = "\<xi> \<cdot> (f \<star> inv \<eta> \<star> g) \<cdot> (inv \<xi> \<star> f \<star> g)"
	+ have \<epsilon>_in_hom: "\<guillemotleft>?\<epsilon> : f \<star> g \<Rightarrow> ?b\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>f \<star> inv \<eta> \<star> g : f \<star> g \<star> f \<star> g \<Rightarrow> f \<star> g\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>inv \<eta> : g \<star> f \<Rightarrow> ?a\<guillemotright>"
	+ using \<eta>_in_hom iso_\<eta> by auto
	+ hence "\<guillemotleft>f \<star> inv \<eta> \<star> g : f \<star> (g \<star> f) \<star> g \<Rightarrow> f \<star> ?a \<star> g\<guillemotright>"
	+ using assms by (intro hcomp_in_vhom, auto)
	+ hence "\<guillemotleft>f \<star> inv \<eta> \<star> g : f \<star> (g \<star> f) \<star> g \<Rightarrow> f \<star> g\<guillemotright>"
	+ using assms f_in_hhom hcomp_obj_arr by (metis in_hhomE)
	+ moreover have "f \<star> (g \<star> f) \<star> g = f \<star> g \<star> f \<star> g"
	+ using hcomp_assoc by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ moreover have "\<guillemotleft>inv \<xi> \<star> f \<star> g : f \<star> g \<Rightarrow> f \<star> g \<star> f \<star> g\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>inv \<xi> \<star> f \<star> g : ?b \<star> f \<star> g \<Rightarrow> (f \<star> g) \<star> f \<star> g\<guillemotright>"
	+ using assms \<xi>_in_hom iso_\<xi> by (intro hcomp_in_vhom, auto)
	+ moreover have "(f \<star> g) \<star> f \<star> g = f \<star> g \<star> f \<star> g"
	+ using hcomp_assoc by simp
	+ moreover have "?b \<star> f \<star> g = f \<star> g"
	+ using f_in_hhom g_in_hhom b hcomp_obj_arr [of ?b "f \<star> g"] hseqI' by fastforce
	+ ultimately show ?thesis by simp
	+ qed
	+ ultimately show "\<guillemotleft>?\<epsilon> : f \<star> g \<Rightarrow> ?b\<guillemotright>"
	+ using \<xi>_in_hom by blast
	+ qed
	+ have "iso ?\<epsilon>"
	+ using f_in_hhom g_in_hhom \<eta>_in_hhom ide_f ide_g \<eta>_in_hom iso_\<eta> \<xi>_in_hhom \<xi>_in_hom iso_\<xi>
	+ iso_inv_iso hseqI'
	+ apply (intro isos_compose)
	+ apply auto
	+ apply fastforce
	+ apply fastforce
	+ proof -
	+ have 1: "\<guillemotleft>(f \<star> inv \<eta> \<star> g) \<cdot> (inv \<xi> \<star> f \<star> g) : ?b \<star> f \<star> g \<Rightarrow> f \<star> ?a \<star> g\<guillemotright>"
	+ proof
	+ have "\<guillemotleft>inv \<xi> \<star> f \<star> g : ?b \<star> f \<star> g \<Rightarrow> (f \<star> g) \<star> f \<star> g\<guillemotright>"
	+ using f_in_hhom g_in_hhom ide_f ide_g \<xi>_in_hhom \<xi>_in_hom iso_\<xi>
	+ by (intro hcomp_in_vhom, auto)
	+ thus "\<guillemotleft>inv \<xi> \<star> f \<star> g : ?b \<star> f \<star> g \<Rightarrow> f \<star> g \<star> f \<star> g\<guillemotright>"
	+ using hcomp_assoc by simp
	+ have "\<guillemotleft>f \<star> inv \<eta> \<star> g : f \<star> (g \<star> f) \<star> g \<Rightarrow> f \<star> ?a \<star> g\<guillemotright>"
	+ using f_in_hhom g_in_hhom ide_f ide_g \<eta>_in_hhom \<eta>_in_hom iso_\<eta>
	+ by (intro hcomp_in_vhom, auto)
	+ thus "\<guillemotleft>f \<star> inv \<eta> \<star> g : f \<star> g \<star> f \<star> g \<Rightarrow> f \<star> ?a \<star> g\<guillemotright>"
	+ using hcomp_assoc by simp
	+ qed
	+ show "seq (f \<star> inv \<eta> \<star> g) (inv \<xi> \<star> f \<star> g)"
	+ using 1 by auto
	+ show "seq \<xi> ((f \<star> inv \<eta> \<star> g) \<cdot> (inv \<xi> \<star> f \<star> g))"
	+ proof -
	+ have "f \<star> ?a \<star> g = f \<star> g"
	+ using a f_in_hhom g_in_hhom hcomp_obj_arr by fastforce
	+ thus ?thesis
	+ using 1 \<xi>_in_hom by auto
	+ qed
	+ qed
	+ have 4: "\<guillemotleft>inv \<xi> \<star> f : ?b \<star> f \<Rightarrow> f \<star> g \<star> f\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>inv \<xi> \<star> f : ?b \<star> f \<Rightarrow> (f \<star> g) \<star> f\<guillemotright>"
	+ using \<xi>_in_hom iso_\<xi> f_in_hhom
	+ by (intro hcomp_in_vhom, auto)
	+ thus ?thesis
	+ using hcomp_assoc by simp
	+ qed
	+ text \<open>
	+ First show \<open>?\<epsilon>\<close> and \<open>\<eta>\<close> satisfy the ``left'' triangle identity.
	+ \<close>
	+ have triangle_left: "(?\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f"
	+ proof -
	+ have "(?\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = (\<xi> \<star> f) \<cdot> (f \<star> inv \<eta> \<star> g \<star> f) \<cdot> (inv \<xi> \<star> f \<star> g \<star> f) \<cdot> (?b \<star> f \<star> \<eta>)"
	+ proof -
	+ have "f \<star> \<eta> = ?b \<star> f \<star> \<eta>"
	+ using b \<eta>_in_hhom hcomp_obj_arr [of ?b "f \<star> \<eta>"] hseqI' by fastforce
	+ moreover have "\<xi> \<cdot> (f \<star> inv \<eta> \<star> g) \<cdot> (inv \<xi> \<star> f \<star> g) \<star> f =
	+ (\<xi> \<star> f) \<cdot> ((f \<star> inv \<eta> \<star> g) \<star> f) \<cdot> ((inv \<xi> \<star> f \<star> g) \<star> f)"
	+ using ide_f ide_g \<xi>_in_hhom \<xi>_in_hom iso_\<xi> \<eta>_in_hhom \<eta>_in_hom iso_\<eta> whisker_right
	+ by (metis \<epsilon>_in_hom arrI in_hhomE seqE)
	+ moreover have "... = (\<xi> \<star> f) \<cdot> (f \<star> inv \<eta> \<star> g \<star> f) \<cdot> (inv \<xi> \<star> f \<star> g \<star> f)"
	+ using hcomp_assoc by simp
	+ ultimately show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (\<xi> \<star> f) \<cdot> ((f \<star> inv \<eta> \<star> g \<star> f) \<cdot> (f \<star> g \<star> f \<star> \<eta>)) \<cdot> (inv \<xi> \<star> f)"
	+ proof -
	+ have "((inv \<xi> \<star> f) \<star> (g \<star> f)) \<cdot> ((?b \<star> f) \<star> \<eta>) = (inv \<xi> \<star> f) \<cdot> (?b \<star> f) \<star> (g \<star> f) \<cdot> \<eta>"
	+ proof -
	+ have "seq (inv \<xi> \<star> f) (?b \<star> f)"
	+ using a b 4 ide_f ide_g \<xi>_in_hhom \<xi>_in_hom iso_\<xi> \<eta>_in_hhom \<eta>_in_hom iso_\<eta>
	+ by blast
	+ moreover have "seq (g \<star> f) \<eta>"
	+ using f_in_hhom g_in_hhom ide_g ide_f \<eta>_in_hom by fast
	+ ultimately show ?thesis
	+ using interchange [of "inv \<xi> \<star> f" "?b \<star> f" "g \<star> f" \<eta>] by simp
	+ qed
	+ also have "... = inv \<xi> \<star> f \<star> \<eta>"
	+ proof -
	+ have "(inv \<xi> \<star> f) \<cdot> (?b \<star> f) = inv \<xi> \<star> f"
	+ using 4 comp_arr_dom by auto
	+ moreover have "(g \<star> f) \<cdot> \<eta> = \<eta>"
	+ using \<eta>_in_hom comp_cod_arr by auto
	+ ultimately show ?thesis
	+ using hcomp_assoc by simp
	+ qed
	+ also have "... = (f \<star> g) \<cdot> inv \<xi> \<star> (f \<star> \<eta>) \<cdot> (f \<star> ?a)"
	+ proof -
	+ have "(f \<star> g) \<cdot> inv \<xi> = inv \<xi>"
	+ using \<xi>_in_hom iso_\<xi> comp_cod_arr by auto
	+ moreover have "(f \<star> \<eta>) \<cdot> (f \<star> ?a) = f \<star> \<eta>"
	+ proof -
	+ have "\<guillemotleft>f \<star> \<eta> : f \<star> ?a \<Rightarrow> f \<star> g \<star> f\<guillemotright>"
	+ using \<eta>_in_hom by fastforce
	+ thus ?thesis
	+ using comp_arr_dom by blast
	+ qed
	+ ultimately show ?thesis by argo
	+ qed
	+ also have "... = ((f \<star> g) \<star> (f \<star> \<eta>)) \<cdot> (inv \<xi> \<star> (f \<star> ?a))"
	+ proof -
	+ have "seq (f \<star> g) (inv \<xi>)"
	+ using \<xi>_in_hom iso_\<xi> comp_cod_arr by auto
	+ moreover have "seq (f \<star> \<eta>) (f \<star> ?a)"
	+ using f_in_hhom \<eta>_in_hom by force
	+ ultimately show ?thesis
	+ using interchange by simp
	+ qed
	+ also have "... = (f \<star> g \<star> f \<star> \<eta>) \<cdot> (inv \<xi> \<star> f)"
	+ using hcomp_arr_obj hcomp_assoc by auto
	+ finally have "((inv \<xi> \<star> f) \<star> (g \<star> f)) \<cdot> ((?b \<star> f) \<star> \<eta>) = (f \<star> g \<star> f \<star> \<eta>) \<cdot> (inv \<xi> \<star> f)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc hcomp_assoc by simp
	+ qed
	+ also have "... = (\<xi> \<star> f) \<cdot> ((f \<star> ?a \<star> \<eta>) \<cdot> (f \<star> inv \<eta> \<star> ?a)) \<cdot> (inv \<xi> \<star> f)"
	+ proof -
	+ have "(f \<star> inv \<eta> \<star> g \<star> f) \<cdot> (f \<star> (g \<star> f) \<star> \<eta>) = f \<star> (inv \<eta> \<star> g \<star> f) \<cdot> ((g \<star> f) \<star> \<eta>)"
	+ proof -
	+ have "seq ((inv \<eta> \<star> g) \<star> f) ((g \<star> f) \<star> \<eta>)"
	+ proof -
	+ have "seq (inv \<eta> \<star> g \<star> f) ((g \<star> f) \<star> \<eta>)"
	+ using f_in_hhom ide_f g_in_hhom ide_g \<eta>_in_hhom \<eta>_in_hom iso_\<eta> hseqI'
	+ apply (intro seqI)
	+ apply blast
	+ apply blast
	+ by fastforce
	+ thus ?thesis
	+ using hcomp_assoc by simp
	+ qed
	+ hence "(f \<star> (inv \<eta> \<star> g) \<star> f) \<cdot> (f \<star> (g \<star> f) \<star> \<eta>) =
	+ f \<star> ((inv \<eta> \<star> g) \<star> f) \<cdot> ((g \<star> f) \<star> \<eta>)"
	+ using whisker_left by simp
	+ thus ?thesis
	+ using hcomp_assoc by simp
	+ qed
	+ also have "... = f \<star> (?a \<star> \<eta>) \<cdot> (inv \<eta> \<star> ?a)"
	+ proof -
	+ have "(inv \<eta> \<star> g \<star> f) \<cdot> ((g \<star> f) \<star> \<eta>) = (?a \<star> \<eta>) \<cdot> (inv \<eta> \<star> ?a)"
	+ proof -
	+ have "(inv \<eta> \<star> g \<star> f) \<cdot> ((g \<star> f) \<star> \<eta>) = inv \<eta> \<cdot> (g \<star> f) \<star> (g \<star> f) \<cdot> \<eta>"
	+ proof -
	+ have "seq (inv \<eta>) (g \<star> f)"
	+ using g_in_hhom ide_g \<eta>_in_hom iso_\<eta> by force
	+ moreover have "seq (g \<star> f) \<eta>"
	+ using g_in_hhom ide_g \<eta>_in_hom by fastforce
	+ ultimately show ?thesis
	+ using interchange by fastforce
	+ qed
	+ also have "... = inv \<eta> \<star> \<eta>"
	+ using \<eta>_in_hom iso_\<eta> comp_arr_dom comp_cod_arr by auto
	+ also have "... = ?a \<cdot> inv \<eta> \<star> \<eta> \<cdot> ?a"
	+ using \<eta>_in_hom iso_\<eta> comp_arr_dom comp_cod_arr by auto
	+ also have "... = (?a \<star> \<eta>) \<cdot> (inv \<eta> \<star> ?a)"
	+ proof -
	+ have "seq ?a (inv \<eta>)"
	+ using a \<eta>_in_hom iso_\<eta> ideD [of ?a] by (elim objE, auto)
	+ moreover have "seq \<eta> ?a"
	+ using a \<eta>_in_hom by fastforce
	+ ultimately show ?thesis
	+ using interchange by blast
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis by argo
	+ qed
	+ also have "... = (f \<star> ?a \<star> \<eta>) \<cdot> (f \<star> inv \<eta> \<star> ?a)"
	+ proof -
	+ have "seq (?a \<star> \<eta>) (inv \<eta> \<star> ?a)"
	+ proof (intro seqI')
	+ show "\<guillemotleft>inv \<eta> \<star> ?a : (g \<star> f) \<star> ?a \<Rightarrow> ?a \<star> ?a\<guillemotright>"
	+ using a g_in_hhom \<eta>_in_hom iso_\<eta> hseqI ide_f ide_g
	+ apply (elim in_homE in_hhomE, intro hcomp_in_vhom)
	+ by auto
	+ show "\<guillemotleft>?a \<star> \<eta> : ?a \<star> ?a \<Rightarrow> ?a \<star> g \<star> f\<guillemotright>"
	+ using a \<eta>_in_hom hseqI by (intro hcomp_in_vhom, auto)
	+ qed
	+ thus ?thesis
	+ using whisker_left by simp
	+ qed
	+ finally show ?thesis
	+ using hcomp_assoc by simp
	+ qed
	+ also have "... = (\<xi> \<star> f) \<cdot> ((f \<star> \<eta>) \<cdot> (f \<star> inv \<eta>)) \<cdot> (inv \<xi> \<star> f)"
	+ using a \<eta>_in_hhom iso_\<eta> hcomp_obj_arr [of ?a \<eta>] hcomp_arr_obj [of "inv \<eta>" ?a] by auto
	+ also have "... = (\<xi> \<star> f) \<cdot> (inv \<xi> \<star> f)"
	+ proof -
	+ have "(f \<star> \<eta>) \<cdot> (f \<star> inv \<eta>) = f \<star> \<eta> \<cdot> inv \<eta>"
	+ using \<eta>_in_hhom iso_\<eta> whisker_left inv_in_hom by auto
	+ moreover have "f \<star> \<eta> \<cdot> inv \<eta> = f \<star> g \<star> f"
	+ using \<eta>_in_hom iso_\<eta> comp_arr_inv inv_is_inverse by auto
	+ moreover have "(f \<star> g \<star> f) \<cdot> (inv \<xi> \<star> f) = inv \<xi> \<star> f"
	+ proof -
	+ have "\<guillemotleft>inv \<xi> \<star> f : ?b \<star> f \<Rightarrow> f \<star> g \<star> f\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>inv \<xi> \<star> f : ?b \<star> f \<Rightarrow> (f \<star> g) \<star> f\<guillemotright>"
	+ using \<xi>_in_hom iso_\<xi> by (intro hcomp_in_vhom, auto)
	+ thus ?thesis
	+ using hcomp_assoc by simp
	+ qed
	+ moreover have "f \<star> g \<star> f = cod (inv \<xi> \<star> f)"
	+ using \<xi>_in_hhom iso_\<xi> hcomp_assoc hseqI' calculation by auto
	+ ultimately show ?thesis
	+ using comp_cod_arr by auto
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = ?b \<star> f"
	+ proof -
	+ have "(\<xi> \<star> f) \<cdot> (inv \<xi> \<star> f) = \<xi> \<cdot> inv \<xi> \<star> f"
	+ using \<xi>_in_hhom iso_\<xi> whisker_right by auto
	+ moreover have "\<xi> \<cdot> inv \<xi> = ?b"
	+ using \<xi>_in_hom iso_\<xi> comp_arr_inv inv_is_inverse by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = f"
	+ using hcomp_obj_arr by auto
	+ finally show ?thesis by blast
	+ qed
	+
	+ (* TODO: Putting this earlier breaks some steps in the proof. *)
	+ interpret E: equivalence_in_strict_bicategory V H \<a> \<i> src trg f g \<eta> ?\<epsilon>
	+ using ide_g \<eta>_in_hom \<epsilon>_in_hom g_in_hhom `iso \<eta>` `iso ?\<epsilon>`
	+ by (unfold_locales, auto)
	+
	+ text \<open>
	+ Apply ``triangle left if and only iff right'' to show the ``right'' triangle identity.
	+ \<close>
	+ have triangle_right: "((g \<star> \<xi> \<cdot> (f \<star> inv \<eta> \<star> g) \<cdot> (inv \<xi> \<star> f \<star> g)) \<cdot> (\<eta> \<star> g) = g)"
	+ using triangle_left E.triangle_left_iff_right by simp
	+
	+ text \<open>
	+ Use the two triangle identities to establish an adjoint equivalence and show that
	+ there is only one choice for the counit.
	+ \<close>
	+ show "\<exists>!\<epsilon>. adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ proof -
	+ have "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> ?\<epsilon>"
	+ proof
	+ show "(?\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ proof -
	+ have "(?\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = (?\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)"
	+ proof -
	+ have "seq \<a>\<^sup>-\<^sup>1[f, g, f] (f \<star> \<eta>)"
	+ using E.antipar hseqI'
	+ by (intro seqI hseqI, auto)
	+ hence "\<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = f \<star> \<eta>"
	+ using ide_f ide_g E.antipar triangle_right strict_assoc' comp_ide_arr hseqI'
	+ by presburger
	+ thus ?thesis by simp
	+ qed
	+ also have "... = f"
	+ using triangle_left by simp
	+ also have "... = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ using strict_lunit strict_runit by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "(g \<star> ?\<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ proof -
	+ have "(g \<star> ?\<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = (g \<star> ?\<epsilon>) \<cdot> (\<eta> \<star> g)"
	+ proof -
	+ have "seq \<a>[g, f, g] (\<eta> \<star> g)"
	+ using E.antipar hseqI'
	+ by (intro seqI hseqI, auto)
	+ hence "\<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<eta> \<star> g"
	+ using ide_f ide_g E.antipar triangle_right strict_assoc comp_ide_arr hseqI'
	+ by presburger
	+ thus ?thesis by simp
	+ qed
	+ also have "... = g"
	+ using triangle_right by simp
	+ also have "... = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ using strict_lunit strict_runit by simp
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ moreover have "\<And>\<epsilon> \<epsilon>'. \<lbrakk> adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g \<eta> \<epsilon>;
	+ adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g \<eta> \<epsilon>' \<rbrakk>
	+ \<Longrightarrow> \<epsilon> = \<epsilon>'"
	+ using adjunction_unit_determines_counit
	+ by (meson adjoint_equivalence_in_bicategory.axioms(2))
	+ ultimately show ?thesis by auto
	+ qed
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ We now apply strictification to generalize the preceding result to an arbitrary bicategory.
	+ \<close>
	+
	+ context bicategory
	+ begin
	+
	+ interpretation S: strictified_bicategory V H \<a> \<i> src trg ..
	+
	+ notation S.vcomp (infixr "\<cdot>\<^sub>S" 55)
	+ notation S.hcomp (infixr "\<star>\<^sub>S" 53)
	+ notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
	+ notation S.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
	+
	+ interpretation UP: fully_faithful_functor V S.vcomp S.UP
	+ using S.UP_is_fully_faithful_functor by auto
	+ interpretation UP: equivalence_pseudofunctor V H \<a> \<i> src trg
	+ S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
	+ using S.UP_is_equivalence_pseudofunctor by auto
	+ interpretation UP: pseudofunctor_into_strict_bicategory V H \<a> \<i> src trg
	+ S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
	+ ..
	+
	+ lemma equivalence_refines_to_adjoint_equivalence:
	+ assumes "equivalence_map f" and "\<guillemotleft>g : trg f \<rightarrow> src f\<guillemotright>" and "ide g"
	+ and "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>" and "iso \<eta>"
	+ shows "\<exists>!\<epsilon>. adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ proof -
	+ text \<open>
	+ To unpack the consequences of the assumptions, we need to obtain an
	+ interpretation of @{locale equivalence_in_bicategory}, even though we don't
	+ need the associated data other than \<open>f\<close>, \<open>a\<close>, and \<open>b\<close>.
	+ \<close>
	+ obtain g' \<phi> \<psi> where E: "equivalence_in_bicategory V H \<a> \<i> src trg f g' \<phi> \<psi>"
	+ using assms equivalence_map_def by auto
	+ interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g' \<phi> \<psi>
	+ using E by auto
	+ let ?a = "src f" and ?b = "trg f"
	+ have ide_f: "ide f" by simp
	+ have f_in_hhom: "\<guillemotleft>f : ?a \<rightarrow> ?b\<guillemotright>" by simp
	+ have a: "obj ?a" and b: "obj ?b" by auto
	+ have 1: "S.equivalence_map (S.UP f)"
	+ using assms UP.preserves_equivalence_maps by simp
	+ let ?\<eta>' = "S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> ?a"
	+ have 2: "\<guillemotleft>S.UP \<eta> : S.UP ?a \<Rightarrow>\<^sub>S S.UP (g \<star> f)\<guillemotright>"
	+ using assms UP.preserves_hom [of \<eta> "src f" "g \<star> f"] by auto
	+ have 4: "\<guillemotleft>?\<eta>' : UP.map\<^sub>0 ?a \<Rightarrow>\<^sub>S S.UP g \<star>\<^sub>S S.UP f\<guillemotright> \<and> S.iso ?\<eta>'"
	+ proof (intro S.comp_in_homI conjI)
	+ have 3: "S.iso (S.\<Phi> (g, f))"
	+ using assms UP.\<Phi>_components_are_iso by auto
	+ show "\<guillemotleft>S.inv (S.\<Phi> (g, f)) : S.UP (g \<star> f) \<Rightarrow>\<^sub>S S.UP g \<star>\<^sub>S S.UP f\<guillemotright>"
	+ using assms 3 UP.\<Phi>_in_hom(2) [of g f] UP.FF_def by auto
	+ moreover show "\<guillemotleft>UP.\<Psi> ?a : UP.map\<^sub>0 ?a \<Rightarrow>\<^sub>S S.UP ?a\<guillemotright>" by auto
	+ moreover show "\<guillemotleft>S.UP \<eta> : S.UP ?a \<Rightarrow>\<^sub>S S.UP (g \<star> f)\<guillemotright>"
	+ using 2 by simp
	+ ultimately show "S.iso (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> ?a)"
	+ using assms 3 a UP.\<Psi>_char(2) S.iso_inv_iso
	+ apply (intro S.isos_compose) by auto
	+ qed
	+ have ex_un_\<xi>': "\<exists>!\<xi>'. adjoint_equivalence_in_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
	+ (S.UP f) (S.UP g) ?\<eta>' \<xi>'"
	+ proof -
	+ have "\<guillemotleft>S.UP g : S.trg (S.UP f) \<rightarrow>\<^sub>S S.src (S.UP f)\<guillemotright>"
	+ using assms(2) by auto
	+ moreover have "S.ide (S.UP g)"
	+ by (simp add: assms(3))
	+ ultimately show ?thesis
	+ using 1 4 S.equivalence_refines_to_adjoint_equivalence S.UP_map\<^sub>0_obj by simp
	+ qed
	+ obtain \<xi>' where \<xi>': "adjoint_equivalence_in_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
	+ (S.UP f) (S.UP g) ?\<eta>' \<xi>'"
	+ using ex_un_\<xi>' by auto
	+ interpret E': adjoint_equivalence_in_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
	+ \<open>S.UP f\<close> \<open>S.UP g\<close> ?\<eta>' \<xi>'
	+ using \<xi>' by auto
	+ let ?\<epsilon>' = "UP.\<Psi> ?b \<cdot>\<^sub>S \<xi>' \<cdot>\<^sub>S S.inv (S.\<Phi> (f, g))"
	+ have \<epsilon>': "\<guillemotleft>?\<epsilon>' : S.UP (f \<star> g) \<Rightarrow>\<^sub>S S.UP ?b\<guillemotright>"
	+ using assms S.UP_map\<^sub>0_obj apply (intro S.in_homI) by auto
	+ have ex_un_\<epsilon>: "\<exists>!\<epsilon>. \<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> ?b\<guillemotright> \<and> S.UP \<epsilon> = ?\<epsilon>'"
	+ proof -
	+ have "\<exists>\<epsilon>. \<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> ?b\<guillemotright> \<and> S.UP \<epsilon> = ?\<epsilon>'"
	+ proof -
	+ have "src (f \<star> g) = src ?b \<and> trg (f \<star> g) = trg ?b"
	+ proof -
	+ have "arr (f \<star> g)"
	+ using assms(2) f_in_hhom by blast
	+ thus ?thesis
	+ using assms(2) f_in_hhom by (elim hseqE, auto)
	+ qed
	+ thus ?thesis
	+ using assms(2-3) b \<epsilon>' UP.locally_full by auto
	+ qed
	+ moreover have
	+ "\<And>\<mu> \<nu>. \<lbrakk> \<guillemotleft>\<mu> : f \<star> g \<Rightarrow> ?b\<guillemotright>; S.UP \<mu> = ?\<epsilon>'; \<guillemotleft>\<nu> : f \<star> g \<Rightarrow> ?b\<guillemotright>; S.UP \<nu> = ?\<epsilon>' \<rbrakk>
	+ \<Longrightarrow> \<mu> = \<nu>"
	+ proof -
	+ fix \<mu> \<nu>
	+ assume \<mu>: "\<guillemotleft>\<mu> : f \<star> g \<Rightarrow> ?b\<guillemotright>" and \<nu>: "\<guillemotleft>\<nu> : f \<star> g \<Rightarrow> ?b\<guillemotright>"
	+ and 1: "S.UP \<mu> = ?\<epsilon>'" and 2: "S.UP \<nu> = ?\<epsilon>'"
	+ have "par \<mu> \<nu>"
	+ using \<mu> \<nu> by fastforce
	+ thus "\<mu> = \<nu>"
	+ using 1 2 UP.is_faithful [of \<mu> \<nu>] by simp
	+ qed
	+ ultimately show ?thesis by auto
	+ qed
	+ have iso_\<epsilon>': "S.iso ?\<epsilon>'"
	+ proof (intro S.isos_compose)
	+ show "S.iso (S.inv (S.\<Phi> (f, g)))"
	+ using assms UP.\<Phi>_components_are_iso S.iso_inv_iso by auto
	+ show "S.iso \<xi>'"
	+ using E'.counit_is_iso by blast
	+ show "S.iso (UP.\<Psi> ?b)"
	+ using b UP.\<Psi>_char(2) by simp
	+ show "S.seq (UP.\<Psi> ?b) (\<xi>' \<cdot>\<^sub>S S.inv (S.\<Phi> (f, g)))"
	+ proof (intro S.seqI')
	+ show "\<guillemotleft>UP.\<Psi> ?b : UP.map\<^sub>0 ?b \<Rightarrow>\<^sub>S S.UP ?b\<guillemotright>"
	+ using b UP.\<Psi>_char by simp
	+ show "\<guillemotleft>\<xi>' \<cdot>\<^sub>S S.inv (S.\<Phi> (f, g)) : S.UP (f \<star> g) \<Rightarrow>\<^sub>S UP.map\<^sub>0 ?b\<guillemotright>"
	+ using assms UP.\<Phi>_components_are_iso VV.arr_char S.\<Phi>_in_hom [of "(f, g)"]
	+ E'.counit_in_hom S.UP_map\<^sub>0_obj
	+ apply (intro S.comp_in_homI) by auto
	+ qed
	+ thus "S.seq \<xi>' (S.inv (S.\<Phi> (f, g)))" by auto
	+ qed
	+ obtain \<epsilon> where \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> ?b\<guillemotright> \<and> S.UP \<epsilon> = ?\<epsilon>'"
	+ using ex_un_\<epsilon> by auto
	+ interpret E'': equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using assms \<epsilon> iso_\<epsilon>' UP.reflects_iso apply unfold_locales by auto
	+ interpret E'': adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ proof
	+ show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ proof -
	+ have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
	+ S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ using E''.UP_triangle(3) by simp
	+ also have
	+ "... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> ?b \<cdot>\<^sub>S \<xi>' \<cdot>\<^sub>S S.inv (S.\<Phi> (f, g)) \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ using \<epsilon> S.comp_assoc by simp
	+ also have "... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> ?b \<cdot>\<^sub>S \<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ have "\<xi>' \<cdot>\<^sub>S S.inv (S.\<Phi> (f, g)) \<cdot>\<^sub>S S.\<Phi> (f, g) = \<xi>'"
	+ proof -
	+ have "S.iso (S.\<Phi> (f, g))"
	+ using assms by auto
	+ moreover have "S.dom (S.\<Phi> (f, g)) = S.UP f \<star>\<^sub>S S.UP g"
	+ using assms by auto
	+ ultimately have "S.inv (S.\<Phi> (f, g)) \<cdot>\<^sub>S S.\<Phi> (f, g) = S.UP f \<star>\<^sub>S S.UP g"
	+ using S.comp_inv_arr' by simp
	+ thus ?thesis
	+ using S.comp_arr_dom E'.counit_in_hom(2) by simp
	+ qed
	+ thus ?thesis by argo
	+ qed
	+ also have
	+ "... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> ?b \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ ((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
	+ S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ have "UP.\<Psi> ?b \<cdot>\<^sub>S \<xi>' \<star>\<^sub>S S.UP f = (UP.\<Psi> ?b \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (\<xi>' \<star>\<^sub>S S.UP f)"
	+ using assms b UP.\<Psi>_char S.whisker_right S.UP_map\<^sub>0_obj by auto
	+ moreover have "S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> =
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)"
	+ using assms S.whisker_left S.comp_assoc by auto
	+ ultimately show ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ also have "... = (S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> ?b \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>) =
	+ (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))"
	+ proof -
	+ have "(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>) =
	+ S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>"
	+ using assms S.whisker_left by auto
	+ hence "((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) =
	+ ((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>))"
	+ by simp
	+ also have "... = ((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)"
	+ proof -
	+ have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) = \<xi>' \<star>\<^sub>S S.UP f"
	+ proof -
	+ have "\<guillemotleft>\<xi>' \<star>\<^sub>S S.UP f :
	+ (S.UP f \<star>\<^sub>S S.UP g) \<star>\<^sub>S S.UP f \<Rightarrow>\<^sub>S S.trg (S.UP f) \<star>\<^sub>S S.UP f\<guillemotright>"
	+ using assms by (intro S.hcomp_in_vhom, auto)
	+ moreover have "\<guillemotleft>S.\<a>' (S.UP f) (S.UP g) (S.UP f) :
	+ S.UP f \<star>\<^sub>S S.UP g \<star>\<^sub>S S.UP f \<Rightarrow>\<^sub>S (S.UP f \<star>\<^sub>S S.UP g) \<star>\<^sub>S S.UP f\<guillemotright>"
	+ using assms S.assoc'_in_hom by auto
	+ ultimately show ?thesis
	+ using assms S.strict_assoc' S.iso_assoc S.hcomp_assoc E'.antipar
	+ S.comp_arr_ide S.seqI'
	+ by simp
	+ qed
	+ thus ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ also have "... = ((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>))"
	+ using S.comp_assoc by simp
	+ also have "... = (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))"
	+ proof -
	+ have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) =
	+ (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))"
	+ proof -
	+ have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S UP.\<Psi> ?a) =
	+ S.lunit' (S.UP f) \<cdot>\<^sub>S S.runit (S.UP f)"
	+ proof -
	+ have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S UP.\<Psi> ?a) =
	+ (\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> ?a)"
	+ proof -
	+ have "S.seq (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) (UP.\<Psi> ?a)"
	+ using assms UP.\<Psi>_char UP.\<Phi>_components_are_iso by auto
	+ hence "(S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> ?a) =
	+ S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> ?a"
	+ using assms UP.\<Psi>_char UP.\<Phi>_components_are_iso S.comp_assoc
	+ S.whisker_left [of "S.UP f" "S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>" "UP.\<Psi> ?a"]
	+ by simp
	+ thus ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using assms E'.triangle_left UP.\<Phi>_components_are_iso UP.\<Psi>_char
	+ by simp
	+ qed
	+ also have "... = S.UP f"
	+ using S.strict_lunit' S.strict_runit by simp
	+ finally have 1: "((\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S UP.\<Psi> ?a) = S.UP f"
	+ using S.comp_assoc by simp
	+ have "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) =
	+ S.UP f \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> ?a))"
	+ proof -
	+ have "S.iso (S.UP f \<star>\<^sub>S UP.\<Psi> ?a)"
	+ using assms UP.\<Psi>_char S.UP_map\<^sub>0_obj by auto
	+ moreover have "S.inv (S.UP f \<star>\<^sub>S UP.\<Psi> ?a) = S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> ?a)"
	+ using assms a UP.\<Psi>_char S.UP_map\<^sub>0_obj by auto
	+ ultimately show ?thesis
	+ using assms 1 UP.\<Psi>_char UP.\<Phi>_components_are_iso
	+ S.invert_side_of_triangle(2)
	+ [of "S.UP f" "(\<xi>' \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.\<a>' (S.UP f) (S.UP g) (S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)"
	+ "S.UP f \<star>\<^sub>S UP.\<Psi> ?a"]
	+ by simp (* 45 sec *)
	+ qed
	+ also have "... = S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> ?a)"
	+ proof -
	+ have "\<guillemotleft>S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> ?a) :
	+ S.UP f \<star>\<^sub>S S.UP ?a \<Rightarrow>\<^sub>S S.UP f \<star>\<^sub>S UP.map\<^sub>0 ?a\<guillemotright>"
	+ using assms ide_f f_in_hhom UP.\<Psi>_char [of ?a] S.inv_in_hom
	+ apply (intro S.hcomp_in_vhom)
	+ apply auto[1]
	+ apply blast
	+ by auto
	+ moreover have "S.UP f \<star>\<^sub>S UP.map\<^sub>0 ?a = S.UP f"
	+ using a S.hcomp_arr_obj S.UP_map\<^sub>0_obj by auto
	+ finally show ?thesis
	+ using S.comp_cod_arr by blast
	+ qed
	+ finally show ?thesis by auto
	+ qed
	+ thus ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ also have "... = S.UP \<l>\<^sup>-\<^sup>1[f] \<cdot>\<^sub>S S.UP \<r>[f]"
	+ proof -
	+ have "S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> ?b \<star>\<^sub>S S.UP f) = S.UP \<l>\<^sup>-\<^sup>1[f]"
	+ proof -
	+ have "S.UP f = S.UP \<l>[f] \<cdot>\<^sub>S S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)"
	+ using UP.lunit_coherence iso_lunit S.strict_lunit by simp
	+ thus ?thesis
	+ using UP.\<Psi>_char S.comp_arr_dom UP.preserves_iso UP.preserves_inv
	+ S.invert_side_of_triangle(1)
	+ [of "S.UP f" "S.UP \<l>[f]" "S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)"]
	+ by auto
	+ qed
	+ moreover have "(S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f)) =
	+ S.UP \<r>[f]"
	+ proof -
	+ have "S.UP \<r>[f] \<cdot>\<^sub>S S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) = S.UP f"
	+ using UP.runit_coherence [of f] S.strict_runit by simp
	+ moreover have 1: "S.iso (S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)))"
	+ using UP.\<Psi>_char UP.\<Phi>_components_are_iso VV.arr_char S.hseqI' S.UP_map\<^sub>0_obj
	+ by (intro S.isos_compose S.seqI, auto)
	+ ultimately have
	+ "S.UP \<r>[f] = S.UP f \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)))"
	+ using S.invert_side_of_triangle(2)
	+ [of "S.UP f" "S.UP \<r>[f]" "S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"]
	+ by simp
	+ also have
	+ "... = (S.UP f \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ have "S.iso (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"
	+ using 1 UP.\<Psi>_char UP.\<Phi>_components_are_iso S.UP_map\<^sub>0_obj by simp
	+ moreover have
	+ "S.inv (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) = S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))"
	+ using 1 UP.\<Psi>_char UP.\<Phi>_components_are_iso S.UP_map\<^sub>0_obj by simp
	+ moreover have "S.seq (S.\<Phi> (f, src f)) (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"
	+ using 1 S.hseqI' S.UP_map\<^sub>0_obj
	+ by (intro S.seqI S.hseqI, auto)
	+ ultimately have "S.inv (S.\<Phi> (f, src f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))) =
	+ (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ using 1 UP.\<Psi>_char UP.\<Phi>_components_are_iso S.inv_comp by auto
	+ thus ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ also have
	+ "... = (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ using UP.\<Psi>_char S.comp_cod_arr S.hcomp_arr_obj S.hseqI' S.UP_map\<^sub>0_obj by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ also have "... = S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
	+ by simp
	+ finally have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) = S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
	+ by simp
	+ moreover have "par ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
	+ proof -
	+ have "\<guillemotleft>(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) : f \<star> src f \<Rightarrow> trg f \<star> f\<guillemotright>"
	+ using E''.triangle_in_hom(1) by simp
	+ moreover have "\<guillemotleft>\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] : f \<star> src f \<Rightarrow> trg f \<star> f\<guillemotright>" by auto
	+ ultimately show ?thesis
	+ by (metis in_homE)
	+ qed
	+ ultimately show ?thesis
	+ using UP.is_faithful by blast
	+ qed
	+ thus "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ using E''.triangle_left_implies_right by simp
	+ qed
	+ show ?thesis
	+ using E''.adjoint_equivalence_in_bicategory_axioms E''.adjunction_in_bicategory_axioms
	+ adjunction_unit_determines_counit adjoint_equivalence_in_bicategory_def
	+ by metis
	+ qed
	+
	+ lemma equivalence_map_extends_to_adjoint_equivalence:
	+ assumes "equivalence_map f"
	+ shows "\<exists>g \<eta> \<epsilon>. adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ proof -
	+ obtain g \<eta> \<epsilon>' where E: "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'"
	+ using assms equivalence_map_def by auto
	+ interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'
	+ using E by auto
	+ obtain \<epsilon> where A: "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms equivalence_refines_to_adjoint_equivalence [of f g \<eta>]
	+ E.antipar E.unit_is_iso E.unit_in_hom by auto
	+ show ?thesis
	+ using E A by blast
	+ qed
	+
	+ end
	+
	+ subsection "Uniqueness of Adjoints"
	+
	+ text \<open>
	+ Left and right adjoints determine each other up to isomorphism.
	+ \<close>
	+
	+ context strict_bicategory
	+ begin
	+
	+ lemma left_adjoint_determines_right_up_to_iso:
	+ assumes "adjoint_pair f g" and "adjoint_pair f g'"
	+ shows "g \<cong> g'"
	+ proof -
	+ obtain \<eta> \<epsilon> where A: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms adjoint_pair_def by auto
	+ interpret A: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using A by auto
	+ interpret A: adjunction_in_strict_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon> ..
	+ obtain \<eta>' \<epsilon>' where A': "adjunction_in_bicategory V H \<a> \<i> src trg f g' \<eta>' \<epsilon>'"
	+ using assms adjoint_pair_def by auto
	+ interpret A': adjunction_in_bicategory V H \<a> \<i> src trg f g' \<eta>' \<epsilon>'
	+ using A' by auto
	+ interpret A': adjunction_in_strict_bicategory V H \<a> \<i> src trg f g' \<eta>' \<epsilon>' ..
	+ let ?\<phi> = "A'.trnl\<^sub>\<eta> g \<epsilon>"
	+ have "\<guillemotleft>?\<phi>: g \<Rightarrow> g'\<guillemotright>"
	+ using A'.trnl\<^sub>\<eta>_eq A'.adjoint_transpose_left(1) [of "trg f" g] A.antipar A'.antipar
	+ hcomp_arr_obj hseqI'
	+ by auto
	+ moreover have "iso ?\<phi>"
	+ proof (intro isoI)
	+ let ?\<psi> = "A.trnl\<^sub>\<eta> g' \<epsilon>'"
	+ show "inverse_arrows ?\<phi> ?\<psi>"
	+ proof
	+ show "ide (?\<phi> \<cdot> ?\<psi>)"
	+ proof -
	+ have 1: "ide (trg f) \<and> trg (trg f) = trg f"
	+ by simp
	+ have "?\<phi> \<cdot> ?\<psi> = (g' \<star> \<epsilon>) \<cdot> ((\<eta>' \<star> g) \<cdot> (g \<star> \<epsilon>')) \<cdot> (\<eta> \<star> g')"
	+ using 1 A.antipar A'.antipar A.trnl\<^sub>\<eta>_eq [of "trg f" g' \<epsilon>']
	+ A'.trnl\<^sub>\<eta>_eq [of "trg f" g \<epsilon>] comp_assoc A.counit_in_hom A'.counit_in_hom
	+ by simp
	+ also have "... = ((g' \<star> \<epsilon>) \<cdot> (g' \<star> f \<star> g \<star> \<epsilon>')) \<cdot> ((\<eta>' \<star> g \<star> f \<star> g') \<cdot> (\<eta> \<star> g'))"
	+ proof -
	+ have "(\<eta>' \<star> g) \<cdot> (g \<star> \<epsilon>') = (\<eta>' \<star> g \<star> trg f) \<cdot> (src f \<star> g \<star> \<epsilon>')"
	+ using A.antipar A'.antipar hcomp_arr_obj hcomp_obj_arr [of "src f" "g \<star> \<epsilon>'"]
	+ hseqI'
	+ by (metis A'.counit_simps(1) A'.counit_simps(5) A.ide_right ideD(1)
	+ obj_trg trg_hcomp')
	+ also have "... = \<eta>' \<star> g \<star> \<epsilon>'"
	+ using A.antipar A'.antipar interchange [of \<eta>' "src f" "g \<star> trg f" "g \<star> \<epsilon>'"]
	+ whisker_left comp_arr_dom comp_cod_arr hseqI'
	+ by simp
	+ also have "... = ((g' \<star> f) \<star> g \<star> \<epsilon>') \<cdot> (\<eta>' \<star> g \<star> (f \<star> g'))"
	+ using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar
	+ A'.unit_in_hom A'.counit_in_hom interchange whisker_left
	+ comp_arr_dom comp_cod_arr
	+ by (metis A'.counit_simps(1-2,5) A'.unit_simps(1,3) hseqI' ide_char)
	+ also have "... = (g' \<star> f \<star> g \<star> \<epsilon>') \<cdot> (\<eta>' \<star> g \<star> f \<star> g')"
	+ using hcomp_assoc by simp
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (g' \<star> \<epsilon>') \<cdot> ((g' \<star> (\<epsilon> \<star> f) \<star> g') \<cdot> (g' \<star> (f \<star> \<eta>) \<star> g')) \<cdot> (\<eta>' \<star> g')"
	+ proof -
	+ have "(g' \<star> \<epsilon>) \<cdot> (g' \<star> f \<star> g \<star> \<epsilon>') = (g' \<star> \<epsilon>') \<cdot> (g' \<star> \<epsilon> \<star> f \<star> g')"
	+ proof -
	+ have "(g' \<star> \<epsilon>) \<cdot> (g' \<star> f \<star> g \<star> \<epsilon>') = g' \<star> \<epsilon> \<star> \<epsilon>'"
	+ proof -
	+ have "\<epsilon> \<cdot> (f \<star> g \<star> \<epsilon>') = \<epsilon> \<star> \<epsilon>'"
	+ using A.ide_left A.ide_right A.antipar A'.antipar hcomp_arr_obj comp_arr_dom
	+ comp_cod_arr interchange obj_src trg_src
	+ by (metis A'.counit_simps(1,3) A.counit_simps(1-2,4) hcomp_assoc)
	+ thus ?thesis
	+ using A.antipar A'.antipar whisker_left [of g' \<epsilon> "f \<star> g \<star> \<epsilon>'"]
	+ by (simp add: hcomp_assoc hseqI')
	+ qed
	+ also have "... = (g' \<star> \<epsilon>') \<cdot> (g' \<star> \<epsilon> \<star> f \<star> g')"
	+ proof -
	+ have "\<epsilon> \<star> \<epsilon>' = \<epsilon>' \<cdot> (\<epsilon> \<star> f \<star> g')"
	+ using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar
	+ hcomp_obj_arr hcomp_arr_obj comp_arr_dom comp_cod_arr interchange
	+ obj_src trg_src
	+ by (metis A'.counit_simps(1-2,5) A.counit_simps(1,3-4) arr_cod
	+ not_arr_null seq_if_composable)
	+ thus ?thesis
	+ using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar
	+ whisker_left
	+ by (metis A'.counit_simps(1,5) A.counit_simps(1,4) hseqI')
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "(\<eta>' \<star> g \<star> f \<star> g') \<cdot> (\<eta> \<star> g') = (g' \<star> f \<star> \<eta> \<star> g') \<cdot> (\<eta>' \<star> g')"
	+ proof -
	+ have "(\<eta>' \<star> g \<star> f \<star> g') \<cdot> (\<eta> \<star> g') = \<eta>' \<star> \<eta> \<star> g'"
	+ proof -
	+ have "(\<eta>' \<star> g \<star> f) \<cdot> \<eta> = \<eta>' \<star> \<eta>"
	+ using A.ide_left A.ide_right A.antipar A'.antipar A'.unit_in_hom hcomp_arr_obj
	+ interchange comp_arr_dom comp_cod_arr
	+ by (metis A'.unit_simps(1-2,4) A.unit_simps(1,3,5) hcomp_obj_arr obj_trg)
	+ thus ?thesis
	+ using A.antipar A'.antipar whisker_right [of g' "\<eta>' \<star> g \<star> f" \<eta>]
	+ by (simp add: hcomp_assoc hseqI')
	+ qed
	+ also have "... = (g' \<star> f \<star> \<eta> \<star> g') \<cdot> (\<eta>' \<star> g')"
	+ proof -
	+ have "\<eta>' \<star> \<eta> = (g' \<star> f \<star> \<eta>) \<cdot> \<eta>'"
	+ using A.ide_left A.ide_right A.antipar A'.antipar A'.unit_in_hom hcomp_arr_obj
	+ comp_arr_dom comp_cod_arr hcomp_assoc interchange
	+ by (metis A'.unit_simps(1,3-4) A.unit_simps(1-2) obj_src)
	+ thus ?thesis
	+ using A.ide_left A.ide_right A.antipar A'.antipar A'.unit_in_hom hcomp_arr_obj
	+ whisker_right [of g' "g' \<star> f \<star> \<eta>" \<eta>']
	+ by (metis A'.ide_right A'.unit_simps(1,4) A.unit_simps(1,5)
	+ hseqI' hcomp_assoc)
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using comp_assoc hcomp_assoc by simp
	+ qed
	+ also have "... = (g' \<star> \<epsilon>') \<cdot> ((g' \<star> f) \<star> g') \<cdot> (\<eta>' \<star> g')"
	+ proof -
	+ have "(g' \<star> (\<epsilon> \<star> f) \<star> g') \<cdot> (g' \<star> (f \<star> \<eta>) \<star> g') = g' \<star> f \<star> g'"
	+ proof -
	+ have "(g' \<star> (\<epsilon> \<star> f) \<star> g') \<cdot> (g' \<star> (f \<star> \<eta>) \<star> g') =
	+ g' \<star> ((\<epsilon> \<star> f) \<star> g') \<cdot> ((f \<star> \<eta>) \<star> g')"
	+ using A.ide_left A.ide_right A.antipar A'.antipar A'.unit_in_hom
	+ A'.counit_in_hom whisker_left [of g' "(\<epsilon> \<star> f) \<star> g'" "(f \<star> \<eta>) \<star> g'"]
	+ by (metis A'.ide_right A.triangle_left hseqI' ideD(1) whisker_right)
	+ also have "... = g' \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) \<star> g'"
	+ using A.antipar A'.antipar whisker_right [of g' "\<epsilon> \<star> f" "f \<star> \<eta>"]
	+ by (simp add: A.triangle_left hseqI')
	+ also have "... = g' \<star> f \<star> g'"
	+ using A.triangle_left by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using hcomp_assoc by simp
	+ qed
	+ also have "... = (g' \<star> \<epsilon>') \<cdot> (\<eta>' \<star> g')"
	+ using A.antipar A'.antipar A'.unit_in_hom A'.counit_in_hom comp_cod_arr
	+ by (metis A'.triangle_in_hom(4) A'.triangle_right' hcomp_simps(4) comp_null(2)
	+ hseq_char' in_homE)
	+ also have "... = g'"
	+ using A'.triangle_right by simp
	+ finally have "?\<phi> \<cdot> ?\<psi> = g'" by simp
	+ thus ?thesis by simp
	+ qed
	+ show "ide (?\<psi> \<cdot> ?\<phi>)"
	+ proof -
	+ have 1: "ide (trg f) \<and> trg (trg f) = trg f"
	+ by simp
	+ have "?\<psi> \<cdot> ?\<phi> = (g \<star> \<epsilon>') \<cdot> ((\<eta> \<star> g') \<cdot> (g' \<star> \<epsilon>)) \<cdot> (\<eta>' \<star> g)"
	+ using A.antipar A'.antipar A'.trnl\<^sub>\<eta>_eq [of "trg f" g \<epsilon>]
	+ A.trnl\<^sub>\<eta>_eq [of "trg f" g' \<epsilon>'] comp_assoc A.counit_in_hom A'.counit_in_hom
	+ by simp
	+ also have "... = ((g \<star> \<epsilon>') \<cdot> (g \<star> f \<star> g' \<star> \<epsilon>)) \<cdot> ((\<eta> \<star> g' \<star> f \<star> g) \<cdot> (\<eta>' \<star> g))"
	+ proof -
	+ have "(\<eta> \<star> g') \<cdot> (g' \<star> \<epsilon>) = (\<eta> \<star> g' \<star> trg f) \<cdot> (src f \<star> g' \<star> \<epsilon>)"
	+ using A.antipar A'.antipar hcomp_arr_obj hcomp_obj_arr hseqI'
	+ by (metis A'.ide_right A.unit_simps(1,4) hcomp_assoc hcomp_obj_arr
	+ ideD(1) obj_src)
	+ also have "... = \<eta> \<star> g' \<star> \<epsilon>"
	+ using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar A.unit_in_hom
	+ A.counit_in_hom interchange
	+ by (metis "1" A.counit_simps(5) A.unit_simps(4) hseqI' ide_def ide_in_hom(2)
	+ not_arr_null seqI' src.preserves_ide)
	+ also have "... = ((g \<star> f) \<star> g' \<star> \<epsilon>) \<cdot> (\<eta> \<star> g' \<star> (f \<star> g))"
	+ using A'.ide_right A'.antipar interchange ide_char comp_arr_dom comp_cod_arr hseqI'
	+ by (metis A.counit_simps(1-2,5) A.unit_simps(1,3))
	+ also have "... = (g \<star> f \<star> g' \<star> \<epsilon>) \<cdot> (\<eta> \<star> g' \<star> f \<star> g)"
	+ using hcomp_assoc by simp
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (g \<star> \<epsilon>) \<cdot> ((g \<star> (\<epsilon>' \<star> f) \<star> g) \<cdot> (g \<star> (f \<star> \<eta>') \<star> g)) \<cdot> (\<eta> \<star> g)"
	+ proof -
	+ have "(g \<star> \<epsilon>') \<cdot> (g \<star> f \<star> g' \<star> \<epsilon>) = (g \<star> \<epsilon>) \<cdot> (g \<star> \<epsilon>' \<star> f \<star> g)"
	+ proof -
	+ have "(g \<star> \<epsilon>') \<cdot> (g \<star> f \<star> g' \<star> \<epsilon>) = g \<star> \<epsilon>' \<star> \<epsilon>"
	+ proof -
	+ have "\<epsilon>' \<cdot> (f \<star> g' \<star> \<epsilon>) = \<epsilon>' \<star> \<epsilon>"
	+ using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar hcomp_arr_obj
	+ comp_arr_dom comp_cod_arr interchange obj_src trg_src hcomp_assoc
	+ by (metis A.counit_simps(1,3) A'.counit_simps(1-2,4))
	+ thus ?thesis
	+ using A.antipar A'.antipar whisker_left [of g \<epsilon>' "f \<star> g' \<star> \<epsilon>"]
	+ by (simp add: hcomp_assoc hseqI')
	+ qed
	+ also have "... = (g \<star> \<epsilon>) \<cdot> (g \<star> \<epsilon>' \<star> f \<star> g)"
	+ proof -
	+ have "\<epsilon>' \<star> \<epsilon> = \<epsilon> \<cdot> (\<epsilon>' \<star> f \<star> g)"
	+ using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar hcomp_obj_arr
	+ hcomp_arr_obj comp_arr_dom comp_cod_arr interchange obj_src trg_src
	+ by (metis A.counit_simps(1-2,5) A'.counit_simps(1,3-4)
	+ arr_cod not_arr_null seq_if_composable)
	+ thus ?thesis
	+ using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar
	+ whisker_left
	+ by (metis A.counit_simps(1,5) A'.counit_simps(1,4) hseqI')
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "(\<eta> \<star> g' \<star> f \<star> g) \<cdot> (\<eta>' \<star> g) = (g \<star> f \<star> \<eta>' \<star> g) \<cdot> (\<eta> \<star> g)"
	+ proof -
	+ have "(\<eta> \<star> g' \<star> f \<star> g) \<cdot> (\<eta>' \<star> g) = \<eta> \<star> \<eta>' \<star> g"
	+ proof -
	+ have "(\<eta> \<star> g' \<star> f) \<cdot> \<eta>' = \<eta> \<star> \<eta>'"
	+ using A.antipar A'.antipar A.unit_in_hom hcomp_arr_obj
	+ comp_arr_dom comp_cod_arr hcomp_obj_arr interchange
	+ by (metis A'.unit_simps(1,3,5) A.unit_simps(1-2,4) obj_trg)
	+ thus ?thesis
	+ using A.antipar A'.antipar whisker_right [of g "\<eta> \<star> g' \<star> f" \<eta>']
	+ by (simp add: hcomp_assoc hseqI')
	+ qed
	+ also have "... = ((g \<star> f) \<star> \<eta>' \<star> g) \<cdot> (\<eta> \<star> src f \<star> g)"
	+ using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar A.unit_in_hom
	+ A'.unit_in_hom comp_arr_dom comp_cod_arr interchange
	+ by (metis A'.unit_simps(1-2,4) A.unit_simps(1,3) hseqI' ide_char)
	+ also have "... = (g \<star> f \<star> \<eta>' \<star> g) \<cdot> (\<eta> \<star> g)"
	+ using A.antipar A'.antipar hcomp_assoc
	+ by (simp add: hcomp_obj_arr)
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using comp_assoc hcomp_assoc by simp
	+ qed
	+ also have "... = (g \<star> \<epsilon>) \<cdot> ((g \<star> f) \<star> g) \<cdot> (\<eta> \<star> g)"
	+ proof -
	+ have "(g \<star> (\<epsilon>' \<star> f) \<star> g) \<cdot> (g \<star> (f \<star> \<eta>') \<star> g) = g \<star> f \<star> g"
	+ proof -
	+ have "(g \<star> (\<epsilon>' \<star> f) \<star> g) \<cdot> (g \<star> (f \<star> \<eta>') \<star> g) =
	+ g \<star> ((\<epsilon>' \<star> f) \<star> g) \<cdot> ((f \<star> \<eta>') \<star> g)"
	+ using A.ide_left A.ide_right A'.ide_right A.antipar A'.antipar A.unit_in_hom
	+ A.counit_in_hom whisker_left
	+ by (metis A'.triangle_left hseqI' ideD(1) whisker_right)
	+ also have "... = g \<star> (\<epsilon>' \<star> f) \<cdot> (f \<star> \<eta>') \<star> g"
	+ using A.antipar A'.antipar whisker_right [of g "\<epsilon>' \<star> f" "f \<star> \<eta>'"]
	+ by (simp add: A'.triangle_left hseqI')
	+ also have "... = g \<star> f \<star> g"
	+ using A'.triangle_left by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using hcomp_assoc by simp
	+ qed
	+ also have "... = (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g)"
	+ using A.antipar A'.antipar A.unit_in_hom A.counit_in_hom comp_cod_arr
	+ by (metis A.triangle_in_hom(4) A.triangle_right' hcomp_simps(4) comp_null(2)
	+ hseq_char' in_homE)
	+ also have "... = g"
	+ using A.triangle_right by simp
	+ finally have "?\<psi> \<cdot> ?\<phi> = g" by simp
	+ moreover have "ide g"
	+ by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+ ultimately show ?thesis
	+ using isomorphic_def by auto
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ We now use strictification to extend to arbitrary bicategories.
	+ \<close>
	+
	+ context bicategory
	+ begin
	+
	+ interpretation S: strictified_bicategory V H \<a> \<i> src trg ..
	+
	+ notation S.vcomp (infixr "\<cdot>\<^sub>S" 55)
	+ notation S.hcomp (infixr "\<star>\<^sub>S" 53)
	+ notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
	+ notation S.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
	+
	+ interpretation UP: equivalence_pseudofunctor V H \<a> \<i> src trg
	+ S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
	+ using S.UP_is_equivalence_pseudofunctor by auto
	+ interpretation UP: pseudofunctor_into_strict_bicategory V H \<a> \<i> src trg
	+ S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
	+ ..
	+ interpretation UP: fully_faithful_functor V S.vcomp S.UP
	+ using S.UP_is_fully_faithful_functor by auto
	+
	+ lemma left_adjoint_determines_right_up_to_iso:
	+ assumes "adjoint_pair f g" and "adjoint_pair f g'"
	+ shows "g \<cong> g'"
	+ proof -
	+ have 0: "ide g \<and> ide g'"
	+ using assms adjoint_pair_def adjunction_in_bicategory_def
	+ adjunction_data_in_bicategory_def adjunction_data_in_bicategory_axioms_def
	+ by metis
	+ have 1: "S.adjoint_pair (S.UP f) (S.UP g) \<and> S.adjoint_pair (S.UP f) (S.UP g')"
	+ using assms UP.preserves_adjoint_pair by simp
	+ obtain \<nu> where \<nu>: "\<guillemotleft>\<nu> : S.UP g \<Rightarrow>\<^sub>S S.UP g'\<guillemotright> \<and> S.iso \<nu>"
	+ using 1 S.left_adjoint_determines_right_up_to_iso S.isomorphic_def by blast
	+ obtain \<mu> where \<mu>: "\<guillemotleft>\<mu> : g \<Rightarrow> g'\<guillemotright> \<and> S.UP \<mu> = \<nu>"
	+ using 0 \<nu> UP.is_full [of g' g \<nu>] by auto
	+ have "\<guillemotleft>\<mu> : g \<Rightarrow> g'\<guillemotright> \<and> iso \<mu>"
	+ using \<mu> \<nu> UP.reflects_iso by auto
	+ thus ?thesis
	+ using isomorphic_def by auto
	+ qed
	+
	+ lemma right_adjoint_determines_left_up_to_iso:
	+ assumes "adjoint_pair f g" and "adjoint_pair f' g"
	+ shows "f \<cong> f'"
	+ proof -
	+ obtain \<eta> \<epsilon> where A: "adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms adjoint_pair_def by auto
	+ interpret A: adjunction_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using A by auto
	+ obtain \<eta>' \<epsilon>' where A': "adjunction_in_bicategory V H \<a> \<i> src trg f' g \<eta>' \<epsilon>'"
	+ using assms adjoint_pair_def by auto
	+ interpret A': adjunction_in_bicategory V H \<a> \<i> src trg f' g \<eta>' \<epsilon>'
	+ using A' by auto
	+ interpret Cop: op_bicategory V H \<a> \<i> src trg ..
	+ interpret Aop: adjunction_in_bicategory V Cop.H Cop.\<a> \<i> Cop.src Cop.trg g f \<eta> \<epsilon>
	+ using A.antipar A.triangle_left A.triangle_right Cop.assoc_ide_simp
	+ Cop.lunit_ide_simp Cop.runit_ide_simp
	+ by (unfold_locales, auto)
	+ interpret Aop': adjunction_in_bicategory V Cop.H Cop.\<a> \<i> Cop.src Cop.trg g f' \<eta>' \<epsilon>'
	+ using A'.antipar A'.triangle_left A'.triangle_right Cop.assoc_ide_simp
	+ Cop.lunit_ide_simp Cop.runit_ide_simp
	+ by (unfold_locales, auto)
	+ show ?thesis
	+ using Aop.adjunction_in_bicategory_axioms Aop'.adjunction_in_bicategory_axioms
	+ Cop.left_adjoint_determines_right_up_to_iso Cop.adjoint_pair_def
	+ by blast
	+ qed
	+
	+ end
	+
	+ context chosen_right_adjoints
	+ begin
	+
	+ lemma isomorphic_to_left_adjoint_implies_isomorphic_right_adjoint:
	+ assumes "is_left_adjoint f" and "f \<cong> h"
	+ shows "f\<^sup>* \<cong> h\<^sup>*"
	+ proof -
	+ have 1: "adjoint_pair f f\<^sup>*"
	+ using assms left_adjoint_extends_to_adjoint_pair by blast
	+ moreover have "adjoint_pair h f\<^sup>*"
	+ using assms 1 adjoint_pair_preserved_by_iso isomorphic_symmetric isomorphic_reflexive
	+ by (meson isomorphic_def right_adjoint_simps(1))
	+ thus ?thesis
	+ using left_adjoint_determines_right_up_to_iso left_adjoint_extends_to_adjoint_pair
	+ by blast
	+ qed
	+
	+ end
	+
	+ context bicategory
	+ begin
	+
	+ lemma equivalence_is_adjoint:
	+ assumes "equivalence_map f"
	+ shows equivalence_is_left_adjoint: "is_left_adjoint f"
	+ and equivalence_is_right_adjoint: "is_right_adjoint f"
	+ proof -
	+ obtain g \<eta> \<epsilon> where fg: "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms equivalence_map_extends_to_adjoint_equivalence by blast
	+ interpret fg: adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using fg by simp
	+ interpret gf: adjoint_equivalence_in_bicategory V H \<a> \<i> src trg g f "inv \<epsilon>" "inv \<eta>"
	+ using fg.dual_adjoint_equivalence by simp
	+ show "is_left_adjoint f"
	+ using fg.adjunction_in_bicategory_axioms adjoint_pair_def by auto
	+ show "is_right_adjoint f"
	+ using gf.adjunction_in_bicategory_axioms adjoint_pair_def by auto
	+ qed
	+
	+ lemma right_adjoint_to_equivalence_is_equivalence:
	+ assumes "equivalence_map f" and "adjoint_pair f g"
	+ shows "equivalence_map g"
	+ proof -
	+ obtain \<eta> \<epsilon> where fg: "adjunction_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms adjoint_pair_def by auto
	+ interpret fg: adjunction_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using fg by simp
	+ obtain g' \<phi> \<psi> where fg': "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g' \<phi> \<psi>"
	+ using assms equivalence_map_def by auto
	+ interpret fg': equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg f g' \<phi> \<psi>
	+ using fg' by auto
	+ obtain \<psi>' where \<psi>': "adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g' \<phi> \<psi>'"
	+ using assms equivalence_refines_to_adjoint_equivalence [of f g' \<phi>]
	+ fg'.antipar fg'.unit_in_hom fg'.unit_is_iso
	+ by auto
	+ interpret \<psi>': adjoint_equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg f g' \<phi> \<psi>'
	+ using \<psi>' by simp
	+ have 1: "g \<cong> g'"
	+ using fg.adjunction_in_bicategory_axioms \<psi>'.adjunction_in_bicategory_axioms
	+ left_adjoint_determines_right_up_to_iso adjoint_pair_def
	+ by blast
	+ obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : g' \<Rightarrow> g\<guillemotright> \<and> iso \<gamma>"
	+ using 1 isomorphic_def isomorphic_symmetric by metis
	+ have "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg f g ((\<gamma> \<star> f) \<cdot> \<phi>) (\<psi>' \<cdot> (f \<star> inv \<gamma>))"
	+ using \<gamma> equivalence_preserved_by_iso_right \<psi>'.equivalence_in_bicategory_axioms by simp
	+ hence "equivalence_pair f g"
	+ using equivalence_pair_def by auto
	+ thus ?thesis
	+ using equivalence_pair_symmetric equivalence_pair_def equivalence_map_def by blast
	+ qed
	+
	+ lemma left_adjoint_to_equivalence_is_equivalence:
	+ assumes "equivalence_map f" and "adjoint_pair g f"
	+ shows "equivalence_map g"
	+ proof -
	+ obtain \<eta> \<epsilon> where gf: "adjunction_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg g f \<eta> \<epsilon>"
	+ using assms adjoint_pair_def by auto
	+ interpret gf: adjunction_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg g f \<eta> \<epsilon>
	+ using gf by simp
	+ obtain g' where 1: "equivalence_pair g' f"
	+ using assms equivalence_map_def equivalence_pair_def equivalence_pair_symmetric
	+ by blast
	+ obtain \<phi> \<psi> where g'f: "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg g' f \<phi> \<psi>"
	+ using assms 1 equivalence_pair_def by auto
	+ interpret g'f: equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg g' f \<phi> \<psi>
	+ using g'f by auto
	+ obtain \<psi>' where \<psi>': "adjoint_equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg g' f \<phi> \<psi>'"
	+ using assms 1 equivalence_refines_to_adjoint_equivalence [of g' f \<phi>]
	+ g'f.antipar g'f.unit_in_hom g'f.unit_is_iso equivalence_pair_def
	+ equivalence_map_def
	+ by auto
	+ interpret \<psi>': adjoint_equivalence_in_bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg g' f \<phi> \<psi>'
	+ using \<psi>' by simp
	+ have 1: "g \<cong> g'"
	+ using gf.adjunction_in_bicategory_axioms \<psi>'.adjunction_in_bicategory_axioms
	+ right_adjoint_determines_left_up_to_iso adjoint_pair_def
	+ by blast
	+ obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : g' \<Rightarrow> g\<guillemotright> \<and> iso \<gamma>"
	+ using 1 isomorphic_def isomorphic_symmetric by metis
	+ have "equivalence_in_bicategory (\<cdot>) (\<star>) \<a> \<i> src trg g f ((f \<star> \<gamma>) \<cdot> \<phi>) (\<psi>' \<cdot> (inv \<gamma> \<star> f))"
	+ using \<gamma> equivalence_preserved_by_iso_left \<psi>'.equivalence_in_bicategory_axioms by simp
	+ hence "equivalence_pair g f"
	+ using equivalence_pair_def by auto
	+ thus ?thesis
	+ using equivalence_pair_symmetric equivalence_pair_def equivalence_map_def by blast
	+ qed
	+
	+ lemma equivalence_pair_is_adjoint_pair:
	+ assumes "equivalence_pair f g"
	+ shows "adjoint_pair f g"
	+ proof -
	+ obtain \<eta> \<epsilon> where \<eta>\<epsilon>: "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms equivalence_pair_def by auto
	+ interpret \<eta>\<epsilon>: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using \<eta>\<epsilon> by auto
	+ obtain \<epsilon>' where \<eta>\<epsilon>': "adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'"
	+ using \<eta>\<epsilon> equivalence_map_def \<eta>\<epsilon>.antipar \<eta>\<epsilon>.unit_in_hom \<eta>\<epsilon>.unit_is_iso
	+ \<eta>\<epsilon>.ide_right equivalence_refines_to_adjoint_equivalence [of f g \<eta>]
	+ by force
	+ interpret \<eta>\<epsilon>': adjoint_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>'
	+ using \<eta>\<epsilon>' by auto
	+ show ?thesis
	+ using \<eta>\<epsilon>' adjoint_pair_def \<eta>\<epsilon>'.adjunction_in_bicategory_axioms by auto
	+ qed
	+
	+ lemma equivalence_pair_isomorphic_right:
	+ assumes "equivalence_pair f g"
	+ shows "equivalence_pair f g' \<longleftrightarrow> g \<cong> g'"
	+ proof
	+ show "g \<cong> g' \<Longrightarrow> equivalence_pair f g'"
	+ using assms equivalence_pair_def isomorphic_def equivalence_preserved_by_iso_right
	+ by metis
	+ assume g': "equivalence_pair f g'"
	+ show "g \<cong> g'"
	+ using assms g' equivalence_pair_is_adjoint_pair left_adjoint_determines_right_up_to_iso
	+ by blast
	+ qed
	+
	+ lemma equivalence_pair_isomorphic_left:
	+ assumes "equivalence_pair f g"
	+ shows "equivalence_pair f' g \<longleftrightarrow> f \<cong> f'"
	+ proof
	+ show "f \<cong> f' \<Longrightarrow> equivalence_pair f' g"
	+ using assms equivalence_pair_def isomorphic_def equivalence_preserved_by_iso_left
	+ by metis
	+ assume f': "equivalence_pair f' g"
	+ show "f \<cong> f'"
	+ using assms f' equivalence_pair_is_adjoint_pair right_adjoint_determines_left_up_to_iso
	+ by blast
	+ qed
	+
	+ end
	+
	+end
	diff --git a/thys/Bicategory/InternalEquivalence.thy b/thys/Bicategory/InternalEquivalence.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/InternalEquivalence.thy
	@@ -0,0 +1,1108 @@
	+(* Title: InternalEquivalence
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Internal Equivalences"
	+
	+theory InternalEquivalence
	+imports Bicategory
	+begin
	+
	+ text \<open>
	+ An \emph{internal equivalence} in a bicategory consists of antiparallel 1-cells \<open>f\<close> and \<open>g\<close>
	+ together with invertible 2-cells \<open>\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g\<guillemotright>\<close>.
	+ Objects in a bicategory are said to be \emph{equivalent} if they are connected by an
	+ internal equivalence.
	+ In this section we formalize the definition of internal equivalence and the related notions
	+ ``equivalence map'' and ``equivalent objects'', and we establish some basic facts about
	+ these notions.
	+ \<close>
	+
	+ subsection "Definition of Equivalence"
	+
	+ text \<open>
	+ The following locale is defined to prove some basic facts about an equivalence
	+ (or an adjunction) in a bicategory that are ``syntactic'' in the sense that they depend
	+ only on the configuration (source, target, domain, codomain) of the arrows
	+ involved and not on further properties such as the triangle identities (for adjunctions)
	+ or assumptions about invertibility (for equivalences). Proofs about adjunctions and
	+ equivalences become more automatic once we have introduction and simplification rules in
	+ place about this syntax.
	+ \<close>
	+
	+ locale adjunction_data_in_bicategory =
	+ bicategory +
	+ fixes f :: 'a
	+ and g :: 'a
	+ and \<eta> :: 'a
	+ and \<epsilon> :: 'a
	+ assumes ide_left [simp]: "ide f"
	+ and ide_right [simp]: "ide g"
	+ and unit_in_vhom: "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>"
	+ and counit_in_vhom: "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g\<guillemotright>"
	+ begin
	+
	+ (*
	+ * TODO: It is difficult to orient the following equations to make them useful as
	+ * default simplifications, so they have to be cited explicitly where they are used.
	+ *)
	+ lemma antipar ([simp]):
	+ shows "trg g = src f" and "src g = trg f"
	+ apply (metis counit_in_vhom ideD(1) ide_right iso_is_arr not_arr_null
	+ seq_if_composable src.components_are_iso trg.is_extensional trg_src
	+ vconn_implies_hpar(4))
	+ by (metis horizontal_homs.vconn_implies_hpar(4) horizontal_homs_axioms ideD(1)
	+ ide_left iso_is_arr not_arr_null seq_if_composable src.components_are_iso
	+ trg.is_extensional trg_src unit_in_vhom)
	+
	+ lemma counit_in_hom [intro]:
	+ shows "\<guillemotleft>\<epsilon> : trg f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> trg f\<guillemotright>"
	+ using counit_in_vhom vconn_implies_hpar antipar by auto
	+
	+ lemma unit_in_hom [intro]:
	+ shows "\<guillemotleft>\<eta> : src f \<rightarrow> src f\<guillemotright>" and "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>"
	+ using unit_in_vhom vconn_implies_hpar antipar by auto
	+
	+ lemma unit_simps [simp]:
	+ shows "arr \<eta>" and "dom \<eta> = src f" and "cod \<eta> = g \<star> f"
	+ and "src \<eta> = src f" and "trg \<eta> = src f"
	+ using unit_in_hom antipar by auto
	+
	+ lemma counit_simps [simp]:
	+ shows "arr \<epsilon>" and "dom \<epsilon> = f \<star> g" and "cod \<epsilon> = trg f"
	+ and "src \<epsilon> = trg f" and "trg \<epsilon> = trg f"
	+ using counit_in_hom antipar by auto
	+
	+ text \<open>
	+ The expressions found in the triangle identities for an adjunction come up
	+ relatively frequently, so it is useful to have established some basic facts
	+ about them, even if the triangle identities themselves have not actually been
	+ introduced as assumptions in the current context.
	+ \<close>
	+
	+ lemma triangle_in_hom:
	+ shows "\<guillemotleft>(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) : f \<star> src f \<Rightarrow> trg f \<star> f\<guillemotright>"
	+ and "\<guillemotleft>(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) : trg g \<star> g \<Rightarrow> g \<star> src g\<guillemotright>"
	+ and "\<guillemotleft>\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f\<guillemotright>"
	+ and "\<guillemotleft>\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] : g \<Rightarrow> g\<guillemotright>"
	+ using antipar hseqI' by auto
	+
	+ lemma triangle_equiv_form:
	+ shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<longleftrightarrow>
	+ \<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] = f"
	+ and "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<longleftrightarrow>
	+ \<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
	+ proof -
	+ show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<longleftrightarrow>
	+ \<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] = f"
	+ proof
	+ assume 1: "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ have "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] =
	+ \<l>[f] \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) \<cdot> \<r>\<^sup>-\<^sup>1[f]"
	+ using comp_assoc by simp
	+ also have "... = \<l>[f] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot> \<r>\<^sup>-\<^sup>1[f]"
	+ using 1 by simp
	+ also have "... = f"
	+ using comp_assoc comp_arr_inv' comp_inv_arr' iso_lunit iso_runit
	+ comp_arr_dom comp_cod_arr
	+ by simp
	+ finally show "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] = f"
	+ by simp
	+ next
	+ assume 2: "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] = f"
	+ have "\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] = \<l>\<^sup>-\<^sup>1[f] \<cdot> f \<cdot> \<r>[f]"
	+ using comp_cod_arr by simp
	+ also have "... = (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<l>[f]) \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) \<cdot> (\<r>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
	+ using 2 comp_assoc by (metis (no_types, lifting))
	+ also have "... = (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)"
	+ using comp_arr_inv' comp_inv_arr' iso_lunit iso_runit comp_arr_dom comp_cod_arr
	+ hseqI' antipar
	+ by (metis ide_left in_homE lunit_simps(4) runit_simps(4) triangle_in_hom(1))
	+ finally show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ by simp
	+ qed
	+ show "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<longleftrightarrow>
	+ \<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
	+ proof
	+ assume 1: "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ have "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] =
	+ \<r>[g] \<cdot> ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot> \<l>\<^sup>-\<^sup>1[g]"
	+ using comp_assoc by simp
	+ also have "... = \<r>[g] \<cdot> (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot> \<l>\<^sup>-\<^sup>1[g]"
	+ using 1 by simp
	+ also have "... = g"
	+ using comp_assoc comp_arr_inv' comp_inv_arr' iso_lunit iso_runit
	+ comp_arr_dom comp_cod_arr
	+ by simp
	+ finally show "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
	+ by simp
	+ next
	+ assume 2: "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
	+ have "\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] = \<r>\<^sup>-\<^sup>1[g] \<cdot> g \<cdot> \<l>[g]"
	+ using comp_cod_arr by simp
	+ also have "... = \<r>\<^sup>-\<^sup>1[g] \<cdot> (\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g]) \<cdot> \<l>[g]"
	+ using 2 by simp
	+ also have "... = (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<r>[g]) \<cdot> ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot> (\<l>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g])"
	+ using comp_assoc by simp
	+ also have "... = (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)"
	+ using comp_arr_inv' comp_inv_arr' iso_lunit iso_runit comp_arr_dom comp_cod_arr
	+ hseqI' antipar
	+ by (metis ide_right in_homE lunit_simps(4) runit_simps(4) triangle_in_hom(2))
	+ finally show "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ by simp
	+ qed
	+ qed
	+
	+ end
	+
	+ locale equivalence_in_bicategory =
	+ adjunction_data_in_bicategory +
	+ assumes unit_is_iso [simp]: "iso \<eta>"
	+ and counit_is_iso [simp]: "iso \<epsilon>"
	+ begin
	+
	+ lemma dual_equivalence:
	+ shows "equivalence_in_bicategory V H \<a> \<i> src trg g f (inv \<epsilon>) (inv \<eta>)"
	+ using iso_inv_iso antipar
	+ apply unfold_locales by auto
	+
	+ end
	+
	+ subsection "Equivalence Maps"
	+
	+ text \<open>
	+ We will use the term \emph{equivalence pair} to refer to 1-cells \<open>f\<close> and \<open>g\<close> that are
	+ part of an internal equivalence, and the term \emph{equivalence map} to refer to a 1-cell
	+ that is part of an equivalence pair.
	+ \<close>
	+
	+ context bicategory
	+ begin
	+
	+ definition equivalence_pair
	+ where "equivalence_pair f g \<equiv> \<exists>\<phi> \<psi>. equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>"
	+
	+ lemma equivalence_pair_symmetric:
	+ assumes "equivalence_pair f g"
	+ shows "equivalence_pair g f"
	+ using assms equivalence_in_bicategory.dual_equivalence equivalence_pair_def by fastforce
	+
	+ definition equivalence_map
	+ where "equivalence_map f \<equiv> \<exists>g \<eta> \<epsilon>. equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+
	+ lemma equivalence_mapI:
	+ assumes "ide f" and "ide g" and "src g = trg f" and "trg g = src f"
	+ and "isomorphic (src f) (g \<star> f)" and "isomorphic (f \<star> g) (trg f)"
	+ shows "equivalence_map f"
	+ proof -
	+ obtain \<eta> where \<eta>: "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright> \<and> iso \<eta>"
	+ using assms isomorphic_def by auto
	+ obtain \<epsilon> where \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> trg f\<guillemotright> \<and> iso \<epsilon>"
	+ using assms isomorphic_def by auto
	+ have "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms \<eta> \<epsilon> by (unfold_locales, auto)
	+ thus ?thesis
	+ using equivalence_map_def by auto
	+ qed
	+
	+ lemma equivalence_map_is_ide:
	+ assumes "equivalence_map f"
	+ shows "ide f"
	+ using assms adjunction_data_in_bicategory.ide_left equivalence_in_bicategory_def
	+ equivalence_map_def
	+ by fastforce
	+
	+ lemma obj_is_equivalence_map:
	+ assumes "obj a"
	+ shows "equivalence_map a"
	+ using assms
	+ by (metis equivalence_mapI isomorphic_symmetric objE obj_self_composable(2))
	+
	+ lemma equivalence_respects_iso:
	+ assumes "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>" and "\<guillemotleft>\<psi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<psi>"
	+ shows "equivalence_in_bicategory V H \<a> \<i> src trg f' g'
	+ ((g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv \<psi>))"
	+ proof -
	+ interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using assms by auto
	+ show ?thesis
	+ proof
	+ show f': "ide f'" using assms by auto
	+ show g': "ide g'" using assms by auto
	+ show 1: "\<guillemotleft>(g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta> : src f' \<Rightarrow> g' \<star> f'\<guillemotright>"
	+ using assms f' g' E.unit_in_hom E.antipar(2) vconn_implies_hpar(3) hseqI'
	+ apply (intro comp_in_homI, auto)
	+ by (intro hcomp_in_vhom, auto)
	+ show "iso ((g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta>)"
	+ using assms 1 g' vconn_implies_hpar(3) E.antipar(2) iso_hcomp
	+ by (intro isos_compose, auto)
	+ show 1: "\<guillemotleft>\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv \<psi>) : f' \<star> g' \<Rightarrow> src g'\<guillemotright>"
	+ using assms f' ide_in_hom(2) vconn_implies_hpar(3-4) E.antipar(1-2)
	+ by (intro comp_in_homI, auto)
	+ show "iso (\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv \<psi>))"
	+ using assms 1 isos_compose
	+ by (metis E.counit_is_iso E.ide_right arrI f' hseqE ide_is_iso iso_hcomp
	+ iso_inv_iso seqE)
	+ qed
	+ qed
	+
	+ lemma equivalence_map_preserved_by_iso:
	+ assumes "equivalence_map f" and "f \<cong> f'"
	+ shows "equivalence_map f'"
	+ proof -
	+ obtain g \<eta> \<epsilon> where E: "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using assms equivalence_map_def by auto
	+ interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using E by auto
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright> \<and> iso \<phi>"
	+ using assms isomorphic_def isomorphic_symmetric by blast
	+ have "equivalence_in_bicategory V H \<a> \<i> src trg f' g
	+ ((g \<star> \<phi>) \<cdot> (g \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv g))"
	+ using E \<phi> equivalence_respects_iso [of f g \<eta> \<epsilon> \<phi> f' g g] by fastforce
	+ thus ?thesis
	+ using equivalence_map_def by auto
	+ qed
	+
	+ lemma equivalence_preserved_by_iso_right:
	+ assumes "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ and "\<guillemotleft>\<phi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<phi>"
	+ shows "equivalence_in_bicategory V H \<a> \<i> src trg f g' ((\<phi> \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (f \<star> inv \<phi>))"
	+ proof
	+ interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using assms by auto
	+ show "ide f" by simp
	+ show "ide g'"
	+ using assms(2) isomorphic_def by auto
	+ show "\<guillemotleft>(\<phi> \<star> f) \<cdot> \<eta> : src f \<Rightarrow> g' \<star> f\<guillemotright>"
	+ using assms
	+ apply (intro comp_in_homI)
	+ apply auto[1]
	+ using E.antipar(2) E.ide_left by blast
	+ show "\<guillemotleft>\<epsilon> \<cdot> (f \<star> inv \<phi>) : f \<star> g' \<Rightarrow> src g'\<guillemotright>"
	+ using assms vconn_implies_hpar(3-4) E.counit_in_vhom E.antipar(1) ide_in_hom(2)
	+ by (intro comp_in_homI, auto)
	+ show "iso ((\<phi> \<star> f) \<cdot> \<eta>)"
	+ using assms E.antipar hseqI' isos_compose by auto
	+ show "iso (\<epsilon> \<cdot> (f \<star> inv \<phi>))"
	+ using assms E.antipar hseqI' isos_compose iso_inv_iso by auto
	+ qed
	+
	+ lemma equivalence_preserved_by_iso_left:
	+ assumes "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
	+ shows "equivalence_in_bicategory V H \<a> \<i> src trg f' g ((g \<star> \<phi>) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g))"
	+ proof
	+ interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using assms by auto
	+ show "ide f'"
	+ using assms by auto
	+ show "ide g"
	+ by simp
	+ show "\<guillemotleft>(g \<star> \<phi>) \<cdot> \<eta> : src f' \<Rightarrow> g \<star> f'\<guillemotright>"
	+ using assms E.unit_in_hom E.antipar hseqI'
	+ apply (intro comp_in_homI, auto)
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<epsilon> \<cdot> (inv \<phi> \<star> g) : f' \<star> g \<Rightarrow> src g\<guillemotright>"
	+ using assms E.counit_in_hom E.antipar ide_in_hom(2) vconn_implies_hpar(3)
	+ by (intro comp_in_homI, auto)
	+ show "iso ((g \<star> \<phi>) \<cdot> \<eta>)"
	+ using assms E.antipar hseqI' isos_compose by auto
	+ show "iso (\<epsilon> \<cdot> (inv \<phi> \<star> g))"
	+ using assms E.antipar hseqI' isos_compose iso_inv_iso by auto
	+ qed
	+
	+ end
	+
	+ subsection "Composing Equivalences"
	+
	+ locale composite_equivalence_in_bicategory =
	+ bicategory V H \<a> \<i> src trg +
	+ fg: equivalence_in_bicategory V H \<a> \<i> src trg f g \<zeta> \<xi> +
	+ hk: equivalence_in_bicategory V H \<a> \<i> src trg h k \<sigma> \<tau>
	+ for V :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and f :: "'a"
	+ and g :: "'a"
	+ and \<zeta> :: "'a"
	+ and \<xi> :: "'a"
	+ and h :: "'a"
	+ and k :: "'a"
	+ and \<sigma> :: "'a"
	+ and \<tau> :: "'a" +
	+ assumes composable: "src h = trg f"
	+ begin
	+
	+ abbreviation \<eta>
	+ where "\<eta> \<equiv> \<a>\<^sup>-\<^sup>1[g, k, h \<star> f] \<cdot> (g \<star> \<a>[k, h, f]) \<cdot> (g \<star> \<sigma> \<star> f) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[f]) \<cdot> \<zeta>"
	+
	+ abbreviation \<epsilon>
	+ where "\<epsilon> \<equiv> \<tau> \<cdot> (h \<star> \<l>[k]) \<cdot> (h \<star> \<xi> \<star> k) \<cdot> (h \<star> \<a>\<^sup>-\<^sup>1[f, g, k]) \<cdot> \<a>[h, f, g \<star> k]"
	+
	+ interpretation adjunction_data_in_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
	+ proof
	+ show "ide (h \<star> f)"
	+ using composable by simp
	+ show "ide (g \<star> k)"
	+ using fg.antipar hk.antipar composable by simp
	+ show "\<guillemotleft>\<eta> : src (h \<star> f) \<Rightarrow> (g \<star> k) \<star> h \<star> f\<guillemotright>"
	+ using fg.antipar hk.antipar composable by fastforce
	+ show "\<guillemotleft>\<epsilon> : (h \<star> f) \<star> g \<star> k \<Rightarrow> src (g \<star> k)\<guillemotright>"
	+ using fg.antipar hk.antipar composable by fastforce
	+ qed
	+
	+ interpretation equivalence_in_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
	+ proof
	+ show "iso \<eta>"
	+ using fg.antipar hk.antipar composable fg.unit_is_iso hk.unit_is_iso iso_hcomp
	+ iso_lunit' hseq_char iso_inv_iso
	+ by (intro isos_compose, auto)
	+ show "iso \<epsilon>"
	+ using fg.antipar hk.antipar composable fg.counit_is_iso hk.counit_is_iso iso_hcomp
	+ iso_lunit hseq_char iso_inv_iso
	+ by (intro isos_compose, auto)
	+ qed
	+
	+ lemma is_equivalence:
	+ shows "equivalence_in_bicategory V H \<a> \<i> src trg (h \<star> f) (g \<star> k) \<eta> \<epsilon>"
	+ ..
	+
	+ end
	+
	+ sublocale composite_equivalence_in_bicategory \<subseteq>
	+ equivalence_in_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
	+ using is_equivalence by simp
	+
	+ context bicategory
	+ begin
	+
	+ lemma equivalence_maps_compose:
	+ assumes "equivalence_map f" and "equivalence_map f'" and "src f' = trg f"
	+ shows "equivalence_map (f' \<star> f)"
	+ proof -
	+ obtain g \<phi> \<psi> where fg: "equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>"
	+ using assms(1) equivalence_map_def by auto
	+ interpret fg: equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>
	+ using fg by auto
	+ obtain g' \<phi>' \<psi>' where f'g': "equivalence_in_bicategory V H \<a> \<i> src trg f' g' \<phi>' \<psi>'"
	+ using assms(2) equivalence_map_def by auto
	+ interpret f'g': equivalence_in_bicategory V H \<a> \<i> src trg f' g' \<phi>' \<psi>'
	+ using f'g' by auto
	+ interpret composite_equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi> f' g' \<phi>' \<psi>'
	+ using assms(3) by (unfold_locales, auto)
	+ show ?thesis
	+ using equivalence_map_def equivalence_in_bicategory_axioms by auto
	+ qed
	+
	+ end
	+
	+ subsection "Equivalent Objects"
	+
	+ context bicategory
	+ begin
	+
	+ definition equivalent_objects
	+ where "equivalent_objects a b \<equiv> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_map f"
	+
	+ lemma equivalent_objects_reflexive:
	+ assumes "obj a"
	+ shows "equivalent_objects a a"
	+ using assms
	+ by (metis equivalent_objects_def ide_in_hom(1) objE obj_is_equivalence_map)
	+
	+ lemma equivalent_objects_symmetric:
	+ assumes "equivalent_objects a b"
	+ shows "equivalent_objects b a"
	+ proof -
	+ obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_map f"
	+ using assms equivalent_objects_def by auto
	+ obtain g \<eta> \<epsilon> where E: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using f equivalence_map_def by blast
	+ interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using E by auto
	+ have E': "equivalence_in_bicategory V H \<a> \<i> src trg g f (inv \<epsilon>) (inv \<eta>)"
	+ using E.unit_in_hom E.unit_is_iso E.counit_in_hom E.counit_is_iso iso_inv_iso E.antipar
	+ by (unfold_locales, auto)
	+ moreover have "\<guillemotleft>g : b \<rightarrow> a\<guillemotright>"
	+ using E E.antipar by auto
	+ ultimately show ?thesis
	+ using assms E' equivalent_objects_def equivalence_map_def by auto
	+ qed
	+
	+ lemma equivalent_objects_transitive [trans]:
	+ assumes "equivalent_objects a b" and "equivalent_objects b c"
	+ shows "equivalent_objects a c"
	+ proof -
	+ obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_map f"
	+ using assms equivalent_objects_def by auto
	+ obtain g \<eta> \<epsilon> where E: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
	+ using f equivalence_map_def by blast
	+ interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
	+ using E by auto
	+ obtain h where h: "\<guillemotleft>h : b \<rightarrow> c\<guillemotright> \<and> equivalence_map h"
	+ using assms equivalent_objects_def by auto
	+ obtain k \<mu> \<nu> where E': "\<guillemotleft>h : b \<rightarrow> c\<guillemotright> \<and> equivalence_in_bicategory V H \<a> \<i> src trg h k \<mu> \<nu>"
	+ using h equivalence_map_def by blast
	+ interpret E': equivalence_in_bicategory V H \<a> \<i> src trg h k \<mu> \<nu>
	+ using E' by auto
	+ interpret EE': composite_equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon> h k \<mu> \<nu>
	+ using E E' by (unfold_locales, blast)
	+ show ?thesis
	+ using E E' EE'.is_equivalence equivalent_objects_def equivalence_map_def by auto
	+ qed
	+
	+ end
	+
	+ subsection "Transporting Arrows along Equivalences"
	+
	+ text \<open>
	+ We show in this section that transporting the arrows of one hom-category to another
	+ along connecting equivalence maps yields an equivalence of categories.
	+ This is useful, because it seems otherwise hard to establish that the transporting
	+ functor is full.
	+ \<close>
	+
	+ locale two_equivalences_in_bicategory =
	+ bicategory V H \<a> \<i> src trg +
	+ e\<^sub>0: equivalence_in_bicategory V H \<a> \<i> src trg e\<^sub>0 d\<^sub>0 \<eta>\<^sub>0 \<epsilon>\<^sub>0 +
	+ e\<^sub>1: equivalence_in_bicategory V H \<a> \<i> src trg e\<^sub>1 d\<^sub>1 \<eta>\<^sub>1 \<epsilon>\<^sub>1
	+ for V :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and e\<^sub>0 :: "'a"
	+ and d\<^sub>0 :: "'a"
	+ and \<eta>\<^sub>0 :: "'a"
	+ and \<epsilon>\<^sub>0 :: "'a"
	+ and e\<^sub>1 :: "'a"
	+ and d\<^sub>1 :: "'a"
	+ and \<eta>\<^sub>1 :: "'a"
	+ and \<epsilon>\<^sub>1 :: "'a"
	+ begin
	+
	+ interpretation hom: subcategory V \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>\<close>
	+ using hhom_is_subcategory by simp
	+
	+ (* TODO: The preceding interpretation somehow brings in unwanted notation. *)
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+
	+ interpretation hom': subcategory V \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>\<close>
	+ using hhom_is_subcategory by simp
	+
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+
	+ abbreviation (input) F
	+ where "F \<equiv> \<lambda>\<mu>. e\<^sub>1 \<star> \<mu> \<star> d\<^sub>0"
	+
	+ interpretation F: "functor" hom.comp hom'.comp F
	+ proof
	+ show 1: "\<And>f. hom.arr f \<Longrightarrow> hom'.arr (e\<^sub>1 \<star> f \<star> d\<^sub>0)"
	+ using hom.arr_char hom'.arr_char hseqI' in_hhom_def e\<^sub>0.antipar(1) e\<^sub>0.antipar(2)
	+ by simp
	+ show "\<And>f. \<not> hom.arr f \<Longrightarrow> e\<^sub>1 \<star> f \<star> d\<^sub>0 = hom'.null"
	+ using 1 hom.arr_char hom'.null_char in_hhom_def
	+ by (metis e\<^sub>0.antipar(1) hseqE hseq_char' hcomp_simps(2))
	+ show "\<And>f. hom.arr f \<Longrightarrow> hom'.dom (e\<^sub>1 \<star> f \<star> d\<^sub>0) = e\<^sub>1 \<star> hom.dom f \<star> d\<^sub>0"
	+ using hom.arr_char hom.dom_char hom'.arr_char hom'.dom_char hseqI'
	+ by (metis 1 hcomp_simps(3) e\<^sub>0.ide_right e\<^sub>1.ide_left hom'.inclusion hseq_char ide_char)
	+ show "\<And>f. hom.arr f \<Longrightarrow> hom'.cod (e\<^sub>1 \<star> f \<star> d\<^sub>0) = e\<^sub>1 \<star> hom.cod f \<star> d\<^sub>0"
	+ using hom.arr_char hom.cod_char hom'.arr_char hom'.cod_char hseqI'
	+ by (metis 1 hcomp_simps(4) e\<^sub>0.ide_right e\<^sub>1.ide_left hom'.inclusion hseq_char ide_char)
	+ show "\<And>g f. hom.seq g f \<Longrightarrow>
	+ e\<^sub>1 \<star> hom.comp g f \<star> d\<^sub>0 = hom'.comp (e\<^sub>1 \<star> g \<star> d\<^sub>0) (e\<^sub>1 \<star> f \<star> d\<^sub>0)"
	+ using 1 hom.seq_char hom.arr_char hom.comp_char hom'.arr_char hom'.comp_char hseqI'
	+ whisker_left [of e\<^sub>1] whisker_right [of d\<^sub>0]
	+ apply auto
	+ apply (metis hseq_char seqE src_vcomp)
	+ by (metis hseq_char hseq_char')
	+ qed
	+
	+ abbreviation (input) G
	+ where "G \<equiv> \<lambda>\<mu>'. d\<^sub>1 \<star> \<mu>' \<star> e\<^sub>0"
	+
	+ interpretation G: "functor" hom'.comp hom.comp G
	+ proof
	+ show 1: "\<And>f. hom'.arr f \<Longrightarrow> hom.arr (d\<^sub>1 \<star> f \<star> e\<^sub>0)"
	+ using hom.arr_char hom'.arr_char hseqI' in_hhom_def e\<^sub>1.antipar(1) e\<^sub>1.antipar(2)
	+ by simp
	+ show "\<And>f. \<not> hom'.arr f \<Longrightarrow> d\<^sub>1 \<star> f \<star> e\<^sub>0 = hom.null"
	+ using 1 hom.arr_char hom'.null_char in_hhom_def
	+ by (metis e\<^sub>1.antipar(2) hom'.arrI hom.null_char hseqE hseq_char' hcomp_simps(2))
	+ show "\<And>f. hom'.arr f \<Longrightarrow> hom.dom (d\<^sub>1 \<star> f \<star> e\<^sub>0) = d\<^sub>1 \<star> hom'.dom f \<star> e\<^sub>0"
	+ using 1 hom.arr_char hom.dom_char hom'.arr_char hom'.dom_char hseqI'
	+ by (metis hcomp_simps(3) e\<^sub>0.ide_left e\<^sub>1.ide_right hom.inclusion hseq_char ide_char)
	+ show "\<And>f. hom'.arr f \<Longrightarrow> hom.cod (d\<^sub>1 \<star> f \<star> e\<^sub>0) = d\<^sub>1 \<star> hom'.cod f \<star> e\<^sub>0"
	+ using 1 hom.arr_char hom.cod_char hom'.arr_char hom'.cod_char hseqI'
	+ by (metis hcomp_simps(4) e\<^sub>0.ide_left e\<^sub>1.ide_right hom.inclusion hseq_char ide_char)
	+ show "\<And>g f. hom'.seq g f \<Longrightarrow>
	+ d\<^sub>1 \<star> hom'.comp g f \<star> e\<^sub>0 = hom.comp (d\<^sub>1 \<star> g \<star> e\<^sub>0) (d\<^sub>1 \<star> f \<star> e\<^sub>0)"
	+ using 1 hom'.seq_char hom'.arr_char hom'.comp_char hom.arr_char hom.comp_char hseqI'
	+ whisker_left [of d\<^sub>1] whisker_right [of e\<^sub>0]
	+ apply auto
	+ apply (metis hseq_char seqE src_vcomp)
	+ by (metis hseq_char hseq_char')
	+ qed
	+
	+ interpretation GF: composite_functor hom.comp hom'.comp hom.comp F G ..
	+ interpretation FG: composite_functor hom'.comp hom.comp hom'.comp G F ..
	+
	+ abbreviation (input) \<phi>\<^sub>0
	+ where "\<phi>\<^sub>0 f \<equiv> (d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, f \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (f \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
	+ ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> f \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[f]"
	+
	+ lemma \<phi>\<^sub>0_in_hom:
	+ assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
	+ shows "\<guillemotleft>\<phi>\<^sub>0 f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
	+ and "\<guillemotleft>\<phi>\<^sub>0 f : f \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> f \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<phi>\<^sub>0 f : f \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> f \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
	+ using assms e\<^sub>0.antipar e\<^sub>1.antipar
	+ by (intro comp_in_homI, fastforce+)
	+ thus "\<guillemotleft>\<phi>\<^sub>0 f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
	+ using assms src_dom [of "\<phi>\<^sub>0 f"] trg_dom [of "\<phi>\<^sub>0 f"]
	+ by (metis arrI dom_comp in_hhom_def runit'_simps(4) seqE)
	+ qed
	+
	+ lemma iso_\<phi>\<^sub>0:
	+ assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
	+ shows "iso (\<phi>\<^sub>0 f)"
	+ using assms iso_lunit' iso_runit' e\<^sub>0.antipar e\<^sub>1.antipar hseqI'
	+ apply (intro isos_compose)
	+ apply auto
	+ apply (metis assoc'_simps(3) e\<^sub>0.ide_left e\<^sub>0.ide_right e\<^sub>1.ide_left e\<^sub>1.ide_right
	+ iso_hcomp ideD(1) ide_is_iso in_hhomE iso_assoc' hcomp_simps(1))
	+ by (metis assoc'_simps(3) e\<^sub>0.ide_left e\<^sub>0.ide_right e\<^sub>1.ide_left e\<^sub>1.ide_right iso_hcomp
	+ ide_hcomp ideD(1) ide_is_iso in_hhomE iso_assoc' hcomp_simps(1-2))
	+
	+ interpretation \<phi>: transformation_by_components hom.comp hom.comp hom.map \<open>G o F\<close> \<phi>\<^sub>0
	+ proof
	+ fix f
	+ assume f: "hom.ide f"
	+ show "hom.in_hom (\<phi>\<^sub>0 f) (hom.map f) (GF.map f)"
	+ proof (unfold hom.in_hom_char, intro conjI)
	+ show "hom.arr (hom.map f)"
	+ using f by simp
	+ show "hom.arr (GF.map f)"
	+ using f by simp
	+ show "hom.arr (\<phi>\<^sub>0 f)"
	+ using f hom.ide_char hom.arr_char \<phi>\<^sub>0_in_hom by simp
	+ show "\<guillemotleft>\<phi>\<^sub>0 f : hom.map f \<Rightarrow> GF.map f\<guillemotright>"
	+ using f hom.ide_char hom.arr_char hom'.ide_char hom'.arr_char F.preserves_arr
	+ \<phi>\<^sub>0_in_hom
	+ by auto
	+ qed
	+ next
	+ fix \<mu>
	+ assume \<mu>: "hom.arr \<mu>"
	+ show "hom.comp (\<phi>\<^sub>0 (hom.cod \<mu>)) (hom.map \<mu>) =
	+ hom.comp (GF.map \<mu>) (\<phi>\<^sub>0 (hom.dom \<mu>))"
	+ proof -
	+ have "hom.comp (\<phi>\<^sub>0 (hom.cod \<mu>)) (hom.map \<mu>) = \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu>"
	+ proof -
	+ have "hom.map \<mu> = \<mu>"
	+ using \<mu> by simp
	+ moreover have "\<phi>\<^sub>0 (hom.cod \<mu>) = \<phi>\<^sub>0 (cod \<mu>)"
	+ using \<mu> hom.arr_char hom.cod_char by simp
	+ moreover have "hom.arr (\<phi>\<^sub>0 (cod \<mu>))"
	+ using \<mu> hom.arr_char \<phi>\<^sub>0_in_hom [of "cod \<mu>"]
	+ by (metis hom.arr_cod hom.cod_simp ide_cod in_hhom_def)
	+ moreover have "seq (\<phi>\<^sub>0 (cod \<mu>)) \<mu>"
	+ proof
	+ show 1: "\<guillemotleft>\<mu> : dom \<mu> \<Rightarrow> cod \<mu>\<guillemotright>"
	+ using \<mu> hom.arr_char by auto
	+ show "\<guillemotleft>\<phi>\<^sub>0 (cod \<mu>) : cod \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
	+ using \<mu> hom.arr_char \<phi>\<^sub>0_in_hom
	+ by (metis 1 arrI hom.arr_cod hom.cod_simp ide_cod)
	+ qed
	+ ultimately show ?thesis
	+ using \<mu> hom.comp_char by simp
	+ qed
	+ also have "... = (d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
	+ ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
	+ \<l>\<^sup>-\<^sup>1[cod \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu>"
	+ using \<mu> hom.arr_char comp_assoc by auto
	+ also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
	+ ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
	+ \<l>\<^sup>-\<^sup>1[cod \<mu> \<star> src e\<^sub>0] \<cdot> (\<mu> \<star> src e\<^sub>0)) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
	+ using \<mu> hom.arr_char runit'_naturality [of \<mu>] comp_assoc by auto
	+ also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
	+ ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
	+ (src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0]) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
	+ using \<mu> hom.arr_char lunit'_naturality [of "\<mu> \<star> src e\<^sub>0"] by force
	+ also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
	+ ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
	+ (src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0)) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
	+ using comp_assoc by simp
	+ also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
	+ ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0)) \<cdot>
	+ (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
	+ proof -
	+ have "(\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot> (src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0) = \<eta>\<^sub>1 \<star> \<mu> \<star> \<eta>\<^sub>0"
	+ using \<mu> hom.arr_char comp_arr_dom comp_cod_arr
	+ interchange [of \<eta>\<^sub>1 "src e\<^sub>1" "cod \<mu> \<star> \<eta>\<^sub>0" "\<mu> \<star> src e\<^sub>0"]
	+ interchange [of "cod \<mu>" \<mu> \<eta>\<^sub>0 "src e\<^sub>0"]
	+ by (metis e\<^sub>0.unit_in_hom(1) e\<^sub>0.unit_simps(2) e\<^sub>1.unit_simps(1) e\<^sub>1.unit_simps(2)
	+ hseqI' in_hhom_def)
	+ also have "... = ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0)"
	+ proof -
	+ have "\<eta>\<^sub>1 \<star> \<mu> \<star> \<eta>\<^sub>0 = (d\<^sub>1 \<star> e\<^sub>1) \<cdot> \<eta>\<^sub>1 \<star> \<mu> \<cdot> dom \<mu> \<star> (d\<^sub>0 \<star> e\<^sub>0) \<cdot> \<eta>\<^sub>0"
	+ using \<mu> hom.arr_char comp_arr_dom comp_cod_arr by auto
	+ also have "... = (d\<^sub>1 \<star> e\<^sub>1) \<cdot> \<eta>\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (dom \<mu> \<star> \<eta>\<^sub>0)"
	+ using \<mu> hom.arr_char comp_cod_arr
	+ interchange [of \<mu> "dom \<mu>" "d\<^sub>0 \<star> e\<^sub>0" \<eta>\<^sub>0]
	+ by auto
	+ also have "... = ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0)"
	+ using \<mu> hom.arr_char comp_arr_dom comp_cod_arr hseqI'
	+ interchange [of "d\<^sub>1 \<star> e\<^sub>1" \<eta>\<^sub>1 "\<mu> \<star> d\<^sub>0 \<star> e\<^sub>0" "dom \<mu> \<star> \<eta>\<^sub>0"]
	+ interchange [of \<mu> "dom \<mu>" "d\<^sub>0 \<star> e\<^sub>0" \<eta>\<^sub>0]
	+ by (metis e\<^sub>0.unit_in_hom(1) e\<^sub>0.unit_simps(1) e\<^sub>0.unit_simps(3) e\<^sub>1.unit_simps(1)
	+ e\<^sub>1.unit_simps(3) hom.inclusion hseqI)
	+ finally show ?thesis by simp
	+ qed
	+ finally have "(\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot> (src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0) =
	+ ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
	+ ((d\<^sub>1 \<star> e\<^sub>1) \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0])) \<cdot>
	+ (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
	+ using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar hseqI' assoc'_naturality [of \<mu> d\<^sub>0 e\<^sub>0]
	+ whisker_left [of "d\<^sub>1 \<star> e\<^sub>1" "\<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]" "\<mu> \<star> d\<^sub>0 \<star> e\<^sub>0"]
	+ whisker_left [of "d\<^sub>1 \<star> e\<^sub>1" "(\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0" "\<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]"]
	+ by auto
	+ also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
	+ ((d\<^sub>1 \<star> e\<^sub>1) \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0)) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
	+ (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
	+ using comp_assoc by simp
	+ also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> (d\<^sub>1 \<star> e\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0) \<cdot>
	+ \<a>[d\<^sub>1, e\<^sub>1, (dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0]) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
	+ (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
	+ using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar hseqI'
	+ assoc_naturality [of d\<^sub>1 e\<^sub>1 "(\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0"]
	+ by auto
	+ also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> (d\<^sub>1 \<star> e\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0)) \<cdot>
	+ \<a>[d\<^sub>1, e\<^sub>1, (dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
	+ (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
	+ using comp_assoc by simp
	+ also have "... = ((d\<^sub>1 \<star> (e\<^sub>1 \<star> \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0) \<cdot> (d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, dom \<mu> \<star> d\<^sub>0, e\<^sub>0])) \<cdot>
	+ \<a>[d\<^sub>1, e\<^sub>1, (dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
	+ (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
	+ using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar hseqI'
	+ assoc'_naturality [of e\<^sub>1 "\<mu> \<star> d\<^sub>0" e\<^sub>0]
	+ whisker_left [of d\<^sub>1 "\<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]" "e\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0"]
	+ whisker_left [of d\<^sub>1 "(e\<^sub>1 \<star> \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0" "\<a>\<^sup>-\<^sup>1[e\<^sub>1, dom \<mu> \<star> d\<^sub>0, e\<^sub>0]"]
	+ by auto
	+ also have "... = hom.comp (GF.map \<mu>) (\<phi>\<^sub>0 (hom.dom \<mu>))"
	+ proof -
	+ have "hom.arr (GF.map \<mu>)"
	+ using \<mu> by blast
	+ moreover have "hom.arr (\<phi>\<^sub>0 (hom.dom \<mu>))"
	+ using \<mu> hom.arr_char hom.in_hom_char \<phi>\<^sub>0_in_hom(1) hom.dom_closed hom.dom_simp
	+ hom.inclusion ide_dom
	+ by metis
	+ moreover have "seq (GF.map \<mu>) (\<phi>\<^sub>0 (hom.dom \<mu>))"
	+ proof
	+ show "\<guillemotleft>\<phi>\<^sub>0 (hom.dom \<mu>) : dom \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
	+ using \<mu> hom.arr_char hom.dom_char hom.in_hom_char \<phi>\<^sub>0_in_hom hom.dom_closed
	+ hom.dom_simp hom.inclusion ide_dom
	+ by metis
	+ show "\<guillemotleft>GF.map \<mu> : d\<^sub>1 \<star> (e\<^sub>1 \<star> dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0 \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
	+ using \<mu> hom.arr_char hom'.arr_char F.preserves_arr
	+ apply simp
	+ apply (intro hcomp_in_vhom)
	+ by (auto simp add: e\<^sub>0.antipar e\<^sub>1.antipar in_hhom_def)
	+ qed
	+ ultimately show ?thesis
	+ using \<mu> hom.comp_char comp_assoc by auto
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+
	+ lemma transformation_by_components_\<phi>\<^sub>0:
	+ shows "transformation_by_components hom.comp hom.comp hom.map (G o F) \<phi>\<^sub>0"
	+ ..
	+
	+ interpretation \<phi>: natural_isomorphism hom.comp hom.comp hom.map \<open>G o F\<close> \<phi>.map
	+ proof
	+ fix f
	+ assume "hom.ide f"
	+ hence f: "ide f \<and> \<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
	+ using hom.ide_char hom.arr_char by simp
	+ show "hom.iso (\<phi>.map f)"
	+ proof (unfold hom.iso_char hom.arr_char, intro conjI)
	+ show "iso (\<phi>.map f)"
	+ using f iso_\<phi>\<^sub>0 \<phi>.map_simp_ide hom.ide_char hom.arr_char by simp
	+ moreover show "\<guillemotleft>\<phi>.map f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
	+ using f hom.ide_char hom.arr_char by blast
	+ ultimately show "\<guillemotleft>inv (\<phi>.map f) : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
	+ by auto
	+ qed
	+ qed
	+
	+ lemma natural_isomorphism_\<phi>:
	+ shows "natural_isomorphism hom.comp hom.comp hom.map (G o F) \<phi>.map"
	+ ..
	+
	+ definition \<phi>
	+ where "\<phi> \<equiv> \<phi>.map"
	+
	+ lemma \<phi>_ide_simp:
	+ assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
	+ shows "\<phi> f = \<phi>\<^sub>0 f"
	+ unfolding \<phi>_def
	+ using assms hom.ide_char hom.arr_char by simp
	+
	+ lemma \<phi>_components_are_iso:
	+ assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
	+ shows "iso (\<phi> f)"
	+ using assms \<phi>_def \<phi>.components_are_iso hom.ide_char hom.arr_char hom.iso_char
	+ by simp
	+
	+ lemma \<phi>_eq:
	+ shows "\<phi> = (\<lambda>\<mu>. if \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> then \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu> else null)"
	+ proof
	+ fix \<mu>
	+ have "\<not> \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> \<Longrightarrow> \<phi>.map \<mu> = null"
	+ using hom.comp_char hom.null_char hom.arr_char
	+ by (simp add: \<phi>.is_extensional)
	+ moreover have "\<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> \<Longrightarrow> \<phi>.map \<mu> = \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu>"
	+ unfolding \<phi>.map_def
	+ apply auto
	+ using hom.comp_char hom.arr_char
	+ apply simp
	+ by (metis (no_types, lifting) \<phi>\<^sub>0_in_hom(1) hom.cod_closed hom.inclusion ide_cod local.ext)
	+ ultimately show "\<phi> \<mu> = (if \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> then \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu> else null)"
	+ unfolding \<phi>_def by auto
	+ qed
	+
	+ lemma \<phi>_in_hom [intro]:
	+ assumes "\<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
	+ shows "\<guillemotleft>\<phi> \<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
	+ and "\<guillemotleft>\<phi> \<mu> : dom \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<phi> \<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
	+ using assms \<phi>_eq \<phi>_def hom.arr_char \<phi>.preserves_reflects_arr by presburger
	+ show "\<guillemotleft>\<phi> \<mu> : dom \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
	+ unfolding \<phi>_eq
	+ using \<phi>\<^sub>0_in_hom(2) arr_iff_in_hom assms comp_in_hom_simp hom.cod_closed hom.inclusion
	+ ide_cod
	+ by presburger
	+ qed
	+
	+ lemma \<phi>_simps [simp]:
	+ assumes "\<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
	+ shows "arr (\<phi> \<mu>)"
	+ and "src (\<phi> \<mu>) = src e\<^sub>0" and "trg (\<phi> \<mu>) = src e\<^sub>1"
	+ and "dom (\<phi> \<mu>) = dom \<mu>" and "cod (\<phi> \<mu>) = d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0"
	+ using assms \<phi>_in_hom by auto
	+
	+ interpretation d\<^sub>0: equivalence_in_bicategory V H \<a> \<i> src trg d\<^sub>0 e\<^sub>0 \<open>inv \<epsilon>\<^sub>0\<close> \<open>inv \<eta>\<^sub>0\<close>
	+ using e\<^sub>0.dual_equivalence by simp
	+ interpretation d\<^sub>1: equivalence_in_bicategory V H \<a> \<i> src trg d\<^sub>1 e\<^sub>1 \<open>inv \<epsilon>\<^sub>1\<close> \<open>inv \<eta>\<^sub>1\<close>
	+ using e\<^sub>1.dual_equivalence by simp
	+ interpretation d\<^sub>0e\<^sub>0: two_equivalences_in_bicategory V H \<a> \<i> src trg
	+ d\<^sub>0 e\<^sub>0 \<open>inv \<epsilon>\<^sub>0\<close> \<open>inv \<eta>\<^sub>0\<close> d\<^sub>1 e\<^sub>1 \<open>inv \<epsilon>\<^sub>1\<close> \<open>inv \<eta>\<^sub>1\<close>
	+ ..
	+
	+ interpretation \<psi>: inverse_transformation hom'.comp hom'.comp hom'.map \<open>F o G\<close> d\<^sub>0e\<^sub>0.\<phi>
	+ proof -
	+ interpret \<psi>': natural_isomorphism hom'.comp hom'.comp hom'.map \<open>F o G\<close> d\<^sub>0e\<^sub>0.\<phi>
	+ using d\<^sub>0e\<^sub>0.natural_isomorphism_\<phi> e\<^sub>0.antipar e\<^sub>1.antipar d\<^sub>0e\<^sub>0.\<phi>_eq d\<^sub>0e\<^sub>0.\<phi>_def by metis
	+ show "inverse_transformation hom'.comp hom'.comp hom'.map (F o G) d\<^sub>0e\<^sub>0.\<phi>"
	+ ..
	+ qed
	+
	+ definition \<psi>
	+ where "\<psi> \<equiv> \<psi>.map"
	+
	+ lemma \<psi>_ide_simp:
	+ assumes "\<guillemotleft>f': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>" and "ide f'"
	+ shows "\<psi> f' = \<r>[f'] \<cdot> \<l>[f' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> f' \<star> \<epsilon>\<^sub>0) \<cdot> ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[f', e\<^sub>0, d\<^sub>0]) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot> (e\<^sub>1 \<star> \<a>[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
	+ proof -
	+ have "hom'.ide f'"
	+ using assms hom'.ide_char hom'.arr_char by simp
	+ hence "\<psi>.map f' = hom'.inv (d\<^sub>0e\<^sub>0.\<phi> f')"
	+ using assms by simp
	+ also have "... = inv (d\<^sub>0e\<^sub>0.\<phi> f')"
	+ using hom'.inv_char \<open>hom'.ide f'\<close> by simp
	+ also have "... = inv (d\<^sub>0e\<^sub>0.\<phi>\<^sub>0 f')"
	+ using assms e\<^sub>0.antipar e\<^sub>1.antipar d\<^sub>0e\<^sub>0.\<phi>_eq d\<^sub>0e\<^sub>0.\<phi>_ide_simp [of f'] by simp
	+ also have "... = ((((inv \<r>\<^sup>-\<^sup>1[f'] \<cdot> inv \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0]) \<cdot> inv (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0)) \<cdot>
	+ inv ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0])) \<cdot> inv \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]) \<cdot>
	+ inv (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
	+ proof -
	+ text \<open>There has to be a better way to do this.\<close>
	+ have 1: "\<And>A B C D E F.
	+ \<lbrakk> iso A; iso B; iso C; iso D; iso E; iso F;
	+ arr (((((A \<cdot> B) \<cdot> C) \<cdot> D) \<cdot> E) \<cdot> F) \<rbrakk> \<Longrightarrow>
	+ inv (((((A \<cdot> B) \<cdot> C) \<cdot> D) \<cdot> E) \<cdot> F) =
	+ inv F \<cdot> inv E \<cdot> inv D \<cdot> inv C \<cdot> inv B \<cdot> inv A"
	+ using inv_comp isos_compose seqE by metis
	+ have "arr (d\<^sub>0e\<^sub>0.\<phi>\<^sub>0 f')"
	+ using assms e\<^sub>0.antipar(2) e\<^sub>1.antipar(2) d\<^sub>0e\<^sub>0.iso_\<phi>\<^sub>0 [of f'] iso_is_arr by simp
	+ moreover have "iso \<r>\<^sup>-\<^sup>1[f']"
	+ using assms iso_runit' by simp
	+ moreover have "iso \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0]"
	+ using assms iso_lunit' by auto
	+ moreover have "iso (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0)"
	+ using assms e\<^sub>0.antipar(2) e\<^sub>1.antipar(2) hseqI' in_hhom_def by simp
	+ moreover have "iso ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0])"
	+ using assms e\<^sub>0.antipar e\<^sub>1.antipar(1) e\<^sub>1.antipar(2) in_hhom_def iso_hcomp
	+ by (metis calculation(1) e\<^sub>0.ide_left e\<^sub>0.ide_right e\<^sub>1.ide_left e\<^sub>1.ide_right hseqE
	+ ide_is_iso iso_assoc' seqE)
	+ moreover have "iso \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]"
	+ using assms e\<^sub>0.antipar e\<^sub>1.antipar by auto
	+ moreover have "iso (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
	+ using assms e\<^sub>0.antipar e\<^sub>1.antipar
	+ by (metis calculation(1) e\<^sub>0.ide_left e\<^sub>0.ide_right e\<^sub>1.ide_left e\<^sub>1.ide_right
	+ iso_hcomp ide_hcomp hseqE ideD(1) ide_is_iso in_hhomE iso_assoc'
	+ seqE hcomp_simps(1-2))
	+ ultimately show ?thesis
	+ using 1 [of "e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0]" "\<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]"
	+ "(e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0]" "inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0" "\<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0]" "\<r>\<^sup>-\<^sup>1[f']"]
	+ comp_assoc
	+ by (metis e\<^sub>0.antipar(2))
	+ qed
	+ also have "... = inv \<r>\<^sup>-\<^sup>1[f'] \<cdot> inv \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0] \<cdot> inv (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0) \<cdot>
	+ inv ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0]) \<cdot> inv \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
	+ inv (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
	+ using comp_assoc by simp
	+ also have "... = \<r>[f'] \<cdot> \<l>[f' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> f' \<star> \<epsilon>\<^sub>0) \<cdot> ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[f', e\<^sub>0, d\<^sub>0]) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot> (e\<^sub>1 \<star> \<a>[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
	+ proof -
	+ have "inv \<r>\<^sup>-\<^sup>1[f'] = \<r>[f']"
	+ using assms inv_inv iso_runit by blast
	+ moreover have "inv \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0] = \<l>[f' \<star> trg e\<^sub>0]"
	+ using assms inv_inv iso_lunit by auto
	+ moreover have "inv (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0) = \<epsilon>\<^sub>1 \<star> f' \<star> \<epsilon>\<^sub>0"
	+ proof -
	+ have "src (inv \<epsilon>\<^sub>1) = trg f'"
	+ using assms(1) e\<^sub>1.antipar(2) by auto
	+ moreover have "src f' = trg (inv \<epsilon>\<^sub>0)"
	+ using assms(1) e\<^sub>0.antipar(2) by auto
	+ ultimately show ?thesis
	+ using assms(2) e\<^sub>0.counit_is_iso e\<^sub>1.counit_is_iso hseqI' by simp
	+ qed
	+ moreover have "inv ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0]) = (e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[f', e\<^sub>0, d\<^sub>0]"
	+ using assms e\<^sub>0.antipar e\<^sub>1.antipar hseqI' iso_inv_iso by auto
	+ moreover have "inv \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] = \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]"
	+ using assms e\<^sub>0.antipar e\<^sub>1.antipar hseqI' by auto
	+ moreover have "inv (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0]) = e\<^sub>1 \<star> \<a>[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0]"
	+ using assms e\<^sub>0.antipar e\<^sub>1.antipar iso_assoc hseqI' iso_inv_iso
	+ by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ finally show ?thesis
	+ using \<psi>_def by simp
	+ qed
	+
	+ lemma \<psi>_components_are_iso:
	+ assumes "\<guillemotleft>f' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>" and "ide f'"
	+ shows "iso (\<psi> f')"
	+ using assms \<psi>_def \<psi>.components_are_iso hom'.ide_char hom'.arr_char hom'.iso_char
	+ by simp
	+
	+ lemma \<psi>_eq:
	+ shows "\<psi> = (\<lambda>\<mu>'. if \<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> then
	+ \<mu>' \<cdot> \<r>[dom \<mu>'] \<cdot> \<l>[dom \<mu>' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> dom \<mu>' \<star> \<epsilon>\<^sub>0) \<cdot>
	+ ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[dom \<mu>', e\<^sub>0, d\<^sub>0]) \<cdot> \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
	+ (e\<^sub>1 \<star> \<a>[d\<^sub>1, dom \<mu>' \<star> e\<^sub>0, d\<^sub>0])
	+ else null)"
	+ proof
	+ fix \<mu>'
	+ have "\<not> \<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> \<Longrightarrow> \<psi>.map \<mu>' = null"
	+ using \<psi>.is_extensional hom'.arr_char hom'.null_char by simp
	+ moreover have "\<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> \<Longrightarrow>
	+ \<psi>.map \<mu>' = \<mu>' \<cdot> \<r>[dom \<mu>'] \<cdot> \<l>[dom \<mu>' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> dom \<mu>' \<star> \<epsilon>\<^sub>0) \<cdot>
	+ ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[dom \<mu>', e\<^sub>0, d\<^sub>0]) \<cdot> \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
	+ (e\<^sub>1 \<star> \<a>[d\<^sub>1, dom \<mu>' \<star> e\<^sub>0, d\<^sub>0])"
	+ proof -
	+ assume \<mu>': "\<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
	+ have "\<guillemotleft>\<psi>.map (dom \<mu>') : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
	+ using \<mu>' hom'.arr_char hom'.dom_closed by auto
	+ moreover have "seq \<mu>' (\<psi>.map (dom \<mu>'))"
	+ proof -
	+ have "hom'.seq \<mu>' (\<psi>.map (dom \<mu>'))"
	+ using \<mu>' \<psi>.preserves_cod hom'.arrI
	+ apply (intro hom'.seqI) by auto
	+ thus ?thesis
	+ using hom'.seq_char by blast
	+ qed
	+ ultimately show ?thesis
	+ using \<mu>' \<psi>.is_natural_1 [of \<mu>'] hom'.comp_char hom'.arr_char hom'.dom_closed
	+ \<psi>_ide_simp [of "dom \<mu>'"]
	+ apply auto
	+ by (metis \<psi>_def hom'.inclusion ide_dom)
	+ qed
	+ ultimately show "\<psi> \<mu>' = (if \<guillemotleft>\<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> then
	+ \<mu>' \<cdot> \<r>[dom \<mu>'] \<cdot> \<l>[dom \<mu>' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> dom \<mu>' \<star> \<epsilon>\<^sub>0) \<cdot>
	+ ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[dom \<mu>', e\<^sub>0, d\<^sub>0]) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
	+ (e\<^sub>1 \<star> \<a>[d\<^sub>1, dom \<mu>' \<star> e\<^sub>0, d\<^sub>0])
	+ else null)"
	+ unfolding \<psi>_def by argo
	+ qed
	+
	+ lemma \<psi>_in_hom [intro]:
	+ assumes "\<guillemotleft>\<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
	+ shows "\<guillemotleft>\<psi> \<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
	+ and "\<guillemotleft>\<psi> \<mu>' : e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0 \<Rightarrow> cod \<mu>'\<guillemotright>"
	+ proof -
	+ have 0: "\<psi> \<mu>' = \<psi>.map \<mu>'"
	+ using \<psi>_def by auto
	+ hence 1: "hom'.arr (\<psi> \<mu>')"
	+ using assms hom'.arr_char \<psi>.preserves_reflects_arr by auto
	+ show "\<guillemotleft>\<psi> \<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
	+ using 1 hom'.arr_char by blast
	+ show "\<guillemotleft>\<psi> \<mu>' : e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0 \<Rightarrow> cod \<mu>'\<guillemotright>"
	+ using assms 0 1 \<psi>.preserves_hom hom'.in_hom_char hom'.arr_char hseqI'
	+ e\<^sub>0.antipar e\<^sub>1.antipar \<psi>.preserves_dom \<psi>.preserves_cod hom'.dom_char
	+ apply (intro in_homI)
	+ apply auto[1]
	+ proof -
	+ show "dom (\<psi> \<mu>') = e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0"
	+ proof -
	+ have "hom'.dom (\<psi> \<mu>') = FG.map (hom'.dom \<mu>')"
	+ using assms 0 \<psi>.preserves_dom hom'.arr_char
	+ by (metis (no_types, lifting))
	+ thus ?thesis
	+ using assms 0 1 hom.arr_char hom'.arr_char hom'.dom_char G.preserves_arr
	+ hom'.dom_closed
	+ by auto
	+ qed
	+ show "cod (\<psi> \<mu>') = cod \<mu>'"
	+ proof -
	+ have "hom'.cod (\<psi> \<mu>') = cod \<mu>'"
	+ using assms 0 \<psi>.preserves_cod hom'.arr_char by auto
	+ thus ?thesis
	+ using assms 0 1 hom'.arr_char hom'.cod_char G.preserves_arr hom'.cod_closed by auto
	+ qed
	+ qed
	+ qed
	+
	+ lemma \<psi>_simps [simp]:
	+ assumes "\<guillemotleft>\<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
	+ shows "arr (\<psi> \<mu>')"
	+ and "src (\<psi> \<mu>') = trg e\<^sub>0" and "trg (\<psi> \<mu>') = trg e\<^sub>1"
	+ and "dom (\<psi> \<mu>') = e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0" and "cod (\<psi> \<mu>') = cod \<mu>'"
	+ using assms \<psi>_in_hom by auto
	+
	+ interpretation equivalence_of_categories hom'.comp hom.comp F G \<phi> \<psi>
	+ proof -
	+ interpret \<phi>: natural_isomorphism hom.comp hom.comp hom.map \<open>G o F\<close> \<phi>
	+ using \<phi>.natural_isomorphism_axioms \<phi>_def by simp
	+ interpret \<psi>: natural_isomorphism hom'.comp hom'.comp \<open>F o G\<close> hom'.map \<psi>
	+ using \<psi>.natural_isomorphism_axioms \<psi>_def by simp
	+ show "equivalence_of_categories hom'.comp hom.comp F G \<phi> \<psi>"
	+ ..
	+ qed
	+
	+ lemma induces_equivalence_of_hom_categories:
	+ shows "equivalence_of_categories hom'.comp hom.comp F G \<phi> \<psi>"
	+ ..
	+
	+ lemma equivalence_functor_F:
	+ shows "equivalence_functor hom.comp hom'.comp F"
	+ proof -
	+ interpret \<phi>': inverse_transformation hom.comp hom.comp hom.map \<open>G o F\<close> \<phi> ..
	+ interpret \<psi>': inverse_transformation hom'.comp hom'.comp \<open>F o G\<close> hom'.map \<psi> ..
	+ interpret E: equivalence_of_categories hom.comp hom'.comp G F \<psi>'.map \<phi>'.map ..
	+ show ?thesis
	+ using E.equivalence_functor_axioms by simp
	+ qed
	+
	+ lemma equivalence_functor_G:
	+ shows "equivalence_functor hom'.comp hom.comp G"
	+ using equivalence_functor_axioms by simp
	+
	+ end
	+
	+ context bicategory
	+ begin
	+
	+ text \<open>
	+ We now use the just-established equivalence of hom-categories to prove some cancellation
	+ laws for equivalence maps. It is relatively straightforward to prove these results
	+ directly, without using the just-established equivalence, but the proofs are somewhat
	+ longer that way.
	+ \<close>
	+
	+ lemma equivalence_cancel_left:
	+ assumes "equivalence_map e"
	+ and "par \<mu> \<mu>'" and "src e = trg \<mu>" and "e \<star> \<mu> = e \<star> \<mu>'"
	+ shows "\<mu> = \<mu>'"
	+ proof -
	+ obtain d \<eta> \<epsilon> where d\<eta>\<epsilon>: "equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>"
	+ using assms equivalence_map_def by auto
	+ interpret e: equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>
	+ using d\<eta>\<epsilon> by simp
	+ interpret i: equivalence_in_bicategory V H \<a> \<i> src trg
	+ \<open>src \<mu>\<close> \<open>src \<mu>\<close> \<open>inv \<i>[src \<mu>]\<close> \<open>\<i>[src \<mu>]\<close>
	+ using assms iso_inv_iso iso_unit obj_src
	+ apply unfold_locales by simp_all
	+ interpret two_equivalences_in_bicategory V H \<a> \<i> src trg
	+ \<open>src \<mu>\<close> \<open>src \<mu>\<close> \<open>inv \<i>[src \<mu>]\<close> \<open>\<i>[src \<mu>]\<close> e d \<eta> \<epsilon>
	+ ..
	+ interpret hom: subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (src (src \<mu>)) (src e)\<close>
	+ using hhom_is_subcategory by blast
	+ interpret hom': subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (trg (src \<mu>)) (trg e)\<close>
	+ using hhom_is_subcategory by blast
	+ interpret F: equivalence_functor hom.comp hom'.comp \<open>\<lambda>\<mu>'. e \<star> \<mu>' \<star> src \<mu>\<close>
	+ using equivalence_functor_F by simp
	+ have "F \<mu> = F \<mu>'"
	+ using assms hom.arr_char
	+ apply simp
	+ by (metis e.ide_left hcomp_reassoc(2) i.ide_right ideD(1) src_dom trg_dom trg_src)
	+ moreover have "hom.par \<mu> \<mu>'"
	+ using assms hom.arr_char hom.dom_char hom.cod_char
	+ by (metis (no_types, lifting) in_hhomI src_dom src_src trg_dom)
	+ ultimately show "\<mu> = \<mu>'"
	+ using F.is_faithful by blast
	+ qed
	+
	+ lemma equivalence_cancel_right:
	+ assumes "equivalence_map e"
	+ and "par \<mu> \<mu>'" and "src \<mu> = trg e" and "\<mu> \<star> e = \<mu>' \<star> e"
	+ shows "\<mu> = \<mu>'"
	+ proof -
	+ obtain d \<eta> \<epsilon> where d\<eta>\<epsilon>: "equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>"
	+ using assms equivalence_map_def by auto
	+ interpret e: equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>
	+ using d\<eta>\<epsilon> by simp
	+ interpret i: equivalence_in_bicategory V H \<a> \<i> src trg
	+ \<open>trg \<mu>\<close> \<open>trg \<mu>\<close> \<open>inv \<i>[trg \<mu>]\<close> \<open>\<i>[trg \<mu>]\<close>
	+ using assms iso_inv_iso iso_unit obj_src
	+ apply unfold_locales by simp_all
	+ interpret two_equivalences_in_bicategory V H \<a> \<i> src trg
	+ e d \<eta> \<epsilon> \<open>trg \<mu>\<close> \<open>trg \<mu>\<close> \<open>inv \<i>[trg \<mu>]\<close> \<open>\<i>[trg \<mu>]\<close>
	+ ..
	+ interpret hom: subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (trg e) (trg (trg \<mu>))\<close>
	+ using hhom_is_subcategory by blast
	+ interpret hom': subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (src e) (src (trg \<mu>))\<close>
	+ using hhom_is_subcategory by blast
	+ interpret G: equivalence_functor hom.comp hom'.comp \<open>\<lambda>\<mu>'. trg \<mu> \<star> \<mu>' \<star> e\<close>
	+ using equivalence_functor_G by simp
	+ have "G \<mu> = G \<mu>'"
	+ using assms hom.arr_char by simp
	+ moreover have "hom.par \<mu> \<mu>'"
	+ using assms hom.arr_char hom.dom_char hom.cod_char
	+ by (metis (no_types, lifting) in_hhomI src_dom trg_dom trg_trg)
	+ ultimately show "\<mu> = \<mu>'"
	+ using G.is_faithful by blast
	+ qed
	+
	+ end
	+
	+end
	+
	diff --git a/thys/Bicategory/IsomorphismClass.thy b/thys/Bicategory/IsomorphismClass.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/IsomorphismClass.thy
	@@ -0,0 +1,124 @@
	+(* Title: IsomorphismClass
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Isomorphism Classes"
	+
	+text \<open>
	+ The following is a small theory that facilitates working with isomorphism classes of objects
	+ in a category.
	+\<close>
	+
	+theory IsomorphismClass
	+imports Category3.EpiMonoIso Category3.NaturalTransformation
	+begin
	+
	+ context category
	+ begin
	+
	+ notation isomorphic (infix "\<cong>" 50)
	+
	+ definition iso_class ("\<lbrakk>_\<rbrakk>")
	+ where "iso_class f \<equiv> {f'. f \<cong> f'}"
	+
	+ definition is_iso_class
	+ where "is_iso_class F \<equiv> \<exists>f. f \<in> F \<and> F = iso_class f"
	+
	+ definition iso_class_rep
	+ where "iso_class_rep F \<equiv> SOME f. f \<in> F"
	+
	+ lemmas isomorphic_transitive [trans]
	+ lemmas naturally_isomorphic_transitive [trans]
	+
	+ lemma inv_in_homI [intro]:
	+ assumes "iso f" and "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
	+ shows "\<guillemotleft>inv f : b \<rightarrow> a\<guillemotright>"
	+ using assms inv_is_inverse seqE inverse_arrowsE
	+ by (metis ide_compE in_homE in_homI)
	+
	+ lemma iso_class_is_nonempty:
	+ assumes "is_iso_class F"
	+ shows "F \<noteq> {}"
	+ using assms is_iso_class_def iso_class_def by auto
	+
	+ lemma iso_class_memb_is_ide:
	+ assumes "is_iso_class F" and "f \<in> F"
	+ shows "ide f"
	+ using assms is_iso_class_def iso_class_def isomorphic_def by auto
	+
	+ lemma ide_in_iso_class:
	+ assumes "ide f"
	+ shows "f \<in> \<lbrakk>f\<rbrakk>"
	+ using assms iso_class_def is_iso_class_def isomorphic_reflexive by simp
	+
	+ lemma rep_in_iso_class:
	+ assumes "is_iso_class F"
	+ shows "iso_class_rep F \<in> F"
	+ using assms is_iso_class_def iso_class_rep_def someI_ex [of "\<lambda>f. f \<in> F"]
	+ ide_in_iso_class
	+ by metis
	+
	+ lemma is_iso_classI:
	+ assumes "ide f"
	+ shows "is_iso_class \<lbrakk>f\<rbrakk>"
	+ using assms iso_class_def is_iso_class_def isomorphic_reflexive by blast
	+
	+ lemma rep_iso_class:
	+ assumes "ide f"
	+ shows "iso_class_rep \<lbrakk>f\<rbrakk> \<cong> f"
	+ using assms is_iso_classI rep_in_iso_class iso_class_def isomorphic_symmetric
	+ by blast
	+
	+ lemma iso_class_elems_isomorphic:
	+ assumes "is_iso_class F" and "f \<in> F" and "f' \<in> F"
	+ shows "f \<cong> f'"
	+ using assms iso_class_def
	+ by (metis is_iso_class_def isomorphic_symmetric isomorphic_transitive mem_Collect_eq)
	+
	+ lemma iso_class_eqI [intro]:
	+ assumes "f \<cong> g"
	+ shows "\<lbrakk>f\<rbrakk> = \<lbrakk>g\<rbrakk>"
	+ proof -
	+ have f: "ide f"
	+ using assms isomorphic_def by auto
	+ have g: "ide g"
	+ using assms isomorphic_def by auto
	+ have "f \<in> \<lbrakk>g\<rbrakk>"
	+ using assms iso_class_def isomorphic_symmetric by simp
	+ moreover have "g \<in> \<lbrakk>g\<rbrakk>"
	+ using assms g iso_class_def isomorphic_reflexive isomorphic_def by simp
	+ ultimately have "\<And>h. (h \<in> \<lbrakk>f\<rbrakk>) = (h \<in> \<lbrakk>g\<rbrakk>)"
	+ using assms g iso_class_def [of f] iso_class_def [of g]
	+ isomorphic_reflexive isomorphic_symmetric isomorphic_transitive
	+ by blast
	+ thus ?thesis by auto
	+ qed
	+
	+ lemma iso_class_eq:
	+ assumes "is_iso_class F" and "is_iso_class G" and "F \<inter> G \<noteq> {}"
	+ shows "F = G"
	+ proof -
	+ obtain h where h: "h \<in> F \<and> h \<in> G"
	+ using assms by auto
	+ show ?thesis
	+ using assms h
	+ by (metis is_iso_class_def iso_class_elems_isomorphic iso_class_eqI)
	+ qed
	+
	+ lemma iso_class_rep [simp]:
	+ assumes "is_iso_class F"
	+ shows "\<lbrakk>iso_class_rep F\<rbrakk> = F"
	+ proof (intro iso_class_eq)
	+ show "is_iso_class \<lbrakk>iso_class_rep F\<rbrakk>"
	+ using assms is_iso_classI iso_class_memb_is_ide rep_in_iso_class by blast
	+ show "is_iso_class F"
	+ using assms by simp
	+ show "\<lbrakk>iso_class_rep F\<rbrakk> \<inter> F \<noteq> {}"
	+ using assms rep_in_iso_class
	+ by (meson disjoint_iff_not_equal ide_in_iso_class iso_class_memb_is_ide)
	+ qed
	+
	+ end
	+
	+end
	diff --git a/thys/Bicategory/Prebicategory.thy b/thys/Bicategory/Prebicategory.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/Prebicategory.thy
	@@ -0,0 +1,3328 @@
	+(* Title: PreBicategory
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+ text \<open>
	+ The objective of this section is to construct a formalization of bicategories that is
	+ compatible with our previous formulation of categories \cite{Category3-AFP}
	+ and that permits us to carry over unchanged as much of the work done on categories as possible.
	+ For these reasons, we conceive of a bicategory in what might be regarded as a somewhat
	+ unusual fashion. Rather than a traditional development, which would typically define
	+ a bicategory to be essentially ``a `category' whose homs themselves have the structure
	+ of categories,'' here we regard a bicategory as ``a (vertical) category that has been
	+ equipped with a suitable (horizontal) weak composition.'' Stated another way, we think
	+ of a bicategory as a generalization of a monoidal category in which the tensor product is
	+ a partial operation, rather than a total one. Our definition of bicategory can thus
	+ be summarized as follows: a bicategory is a (vertical) category that has been equipped
	+ with idempotent endofunctors \<open>src\<close> and \<open>trg\<close> that assign to each arrow its ``source''
	+ and ``target'' subject to certain commutativity constraints,
	+ a partial binary operation \<open>\<star>\<close> of horizontal composition that is suitably functorial on
	+ the ``hom-categories'' determined by the assignment of sources and targets,
	+ ``associativity'' isomorphisms \<open>\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> (g \<star> h)\<guillemotright>\<close> for each horizontally
	+ composable triple of vertical identities \<open>f\<close>, \<open>g\<close>, \<open>h\<close>, subject to the usual naturality
	+ and coherence conditions, and for each ``object'' \<open>a\<close> (defined to be an arrow that is
	+ its own source and target) a ``unit isomorphism'' \<open>\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
	+ As is the case for monoidal categories, the unit isomorphisms and associator isomorphisms
	+ together enable a canonical definition of left and right ``unit'' isomorphisms
	+ \<open>\<guillemotleft>\<l>[f] : a \<star> f \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>\<close> when \<open>f\<close> is a vertical identity
	+ horizontally composable on the left or right by \<open>a\<close>, and it can be shown that these are
	+ the components of natural transformations.
	+
	+ The definition of bicategory just sketched shares with a more traditional version the
	+ requirement that assignments of source and target are given as basic data, and these
	+ assignments determine horizontal composability in the sense that arrows \<open>\<mu>\<close> and \<open>\<nu>\<close>
	+ are composable if the chosen source of \<open>\<mu>\<close> coincides with the chosen target of \<open>\<nu>\<close>.
	+ Thus it appears, at least on its face, that composability of arrows depends on an assignment
	+ of sources and targets. We are interested in establishing whether this is essential or
	+ whether bicategories can be formalized in a completely ``object-free'' fashion.
	+
	+ It turns out that we can obtain such an object-free formalization through a rather direct
	+ generalization of the approach we used in the formalization of categories.
	+ Specifically, we define a \emph{weak composition} to be a partial binary operation \<open>\<star>\<close>
	+ on the arrow type of a ``vertical'' category \<open>V\<close>, such that the domain of definition of this
	+ operation is itself a category (of ``horizontally composable pairs of arrows''),
	+ the operation is functorial, and it is subject to certain matching conditions which include
	+ those satisfied by a category.
	+ From the axioms for a weak composition we can prove the existence of ``hom-categories'',
	+ which are subcategories of \<open>V\<close> consisting of arrows horizontally composable on the
	+ left or right by a specified vertical identity.
	+ A \emph{weak unit} is defined to be a vertical identity \<open>a\<close> such that \<open>a \<star> a \<cong> a\<close>
	+ and is such that the mappings \<open>a \<star> \<hyphen>\<close> and \<open>\<hyphen> \<star> a\<close> are fully faithful endofunctors
	+ of the subcategories of \<open>V\<close> consisting of the arrows for which they are defined.
	+ We define the \emph{sources} of an arrow \<open>\<mu>\<close> to be the weak units that are horizontally
	+ composable with \<open>\<mu>\<close> on the right, and the \emph{targets} of \<open>\<mu>\<close> to be the weak units
	+ that are horizontally composable with \<open>\<mu>\<close> on the left.
	+ An \emph{associative weak composition} is defined to be a weak composition that is equipped
	+ with ``associator'' isomorphisms \<open>\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> (g \<star> h)\<guillemotright>\<close> for horizontally
	+ composable vertical identities \<open>f\<close>, \<open>g\<close>, \<open>h\<close>, subject to the usual naturality and coherence
	+ conditions.
	+ A \emph{prebicategory} is defined to be an associative weak composition for which every
	+ arrow has a source and a target. We show that the sets of sources and targets of each
	+ arrow in a prebicategory is an isomorphism class of weak units, and that horizontal
	+ composability of arrows \<open>\<mu>\<close> and \<open>\<nu>\<close> is characterized by the set of sources of \<open>\<mu>\<close> being
	+ equal to the set of targets of \<open>\<nu>\<close>.
	+
	+ We show that prebicategories are essentially ``bicategories without objects''.
	+ Given a prebicategory, we may choose an arbitrary representative of each
	+ isomorphism class of weak units and declare these to be ``objects''
	+ (this is analogous to choosing a particular unit object in a monoidal category).
	+ For each object we may choose a particular \emph{unit isomorphism} \<open>\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
	+ This choice, together with the associator isomorphisms, enables a canonical definition
	+ of left and right unit isomorphisms \<open>\<guillemotleft>\<l>[f] : a \<star> f \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>\<close>
	+ when \<open>f\<close> is a vertical identity horizontally composable on the left or right by \<open>a\<close>,
	+ and it can be shown that these are the components of natural isomorphisms.
	+ We may then define ``the source'' of an arrow to be the chosen representative of the
	+ set of its sources and ``the target'' to be the chosen representative of the set of its
	+ targets. We show that the resulting structure is a bicategory, in which horizontal
	+ composability as given by the weak composition coincides with the ``syntactic'' version
	+ determined by the chosen sources and targets.
	+ Conversely, a bicategory determines a prebicategory, essentially by forgetting
	+ the sources, targets and unit isomorphisms.
	+ These results make it clear that the assignment of sources and targets to arrows in
	+ a bicategory is basically a convenience and that horizontal composability of arrows
	+ is not dependent on a particular choice.
	+\<close>
	+
	+theory Prebicategory
	+imports Category3.EquivalenceOfCategories Category3.Subcategory IsomorphismClass
	+begin
	+
	+ section "Weak Composition"
	+
	+ text \<open>
	+ In this section we define a locale \<open>weak_composition\<close>, which formalizes a functorial
	+ operation of ``horizontal'' composition defined on an underlying ``vertical'' category.
	+ The definition is expressed without the presumption of the existence of any sort
	+ of ``objects'' that determine horizontal composability. Rather, just as we did
	+ in showing that the @{locale partial_magma} locale supported the definition of ``identity
	+ arrow'' as a kind of unit for vertical composition which ultimately served as a basis
	+ for the definition of ``domain'' and ``codomain'' of an arrow, here we show that the
	+ \<open>weak_composition\<close> locale supports a definition of \emph{weak unit} for horizontal
	+ composition which can ultimately be used to define the \emph{sources} and \emph{targets}
	+ of an arrow with respect to horizontal composition.
	+ In particular, the definition of weak composition involves axioms that relate horizontal
	+ and vertical composability. As a consequence of these axioms, for any fixed arrow \<open>\<mu>\<close>,
	+ the sets of arrows horizontally composable on the left and on the right with \<open>\<mu>\<close>
	+ form subcategories with respect to vertical composition. We define the
	+ sources of \<open>\<mu>\<close> to be the weak units that are composable with \<open>\<mu>\<close> on the right,
	+ and the targets of \<open>\<mu>\<close> to be the weak units that are composable with \<open>\<mu>\<close>
	+ on the left. Weak units are then characterized as arrows that are members
	+ of the set of their own sources (or, equivalently, of their own targets).
	+ \<close>
	+
	+ subsection "Definition"
	+
	+ locale weak_composition =
	+ category V +
	+ VxV: product_category V V +
	+ VoV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu> \<noteq> null\<close> +
	+ "functor" VoV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a comp" (infixr "\<star>" 53) +
	+ assumes left_connected: "seq \<nu> \<nu>' \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu>' \<star> \<mu> \<noteq> null"
	+ and right_connected: "seq \<mu> \<mu>' \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> \<mu>' \<noteq> null"
	+ and match_1: "\<lbrakk> \<nu> \<star> \<mu> \<noteq> null; (\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null \<rbrakk> \<Longrightarrow> \<mu> \<star> \<tau> \<noteq> null"
	+ and match_2: "\<lbrakk> \<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null; \<mu> \<star> \<tau> \<noteq> null \<rbrakk> \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null"
	+ and match_3: "\<lbrakk> \<mu> \<star> \<tau> \<noteq> null; \<nu> \<star> \<mu> \<noteq> null \<rbrakk> \<Longrightarrow> (\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null"
	+ and match_4: "\<lbrakk> \<mu> \<star> \<tau> \<noteq> null; \<nu> \<star> \<mu> \<noteq> null \<rbrakk> \<Longrightarrow> \<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null"
	+ begin
	+
	+ text \<open>
	+ We think of the arrows of the vertical category as ``2-cells'' and the vertical identities
	+ as ``1-cells''. In the formal development, the predicate @{term arr} (``arrow'')
	+ will have its normal meaning with respect to the vertical composition, hence @{term "arr \<mu>"}
	+ will mean, essentially, ``\<open>\<mu>\<close> is a 2-cell''. This is somewhat unfortunate, as it is
	+ traditional when discussing bicategories to use the term ``arrow'' to refer to the 1-cells.
	+ However, we are trying to carry over all the formalism that we have already developed for
	+ categories and apply it to bicategories with as little change and redundancy as possible.
	+ It becomes too confusing to try to repurpose the name @{term arr} to mean @{term ide} and
	+ to introduce a replacement for the name @{term arr}, so we will simply tolerate the
	+ situation. In informal text, we will prefer the terms ``2-cell'' and ``1-cell'' over
	+ (vertical) ``arrow'' and ``identity'' when there is a chance for confusion.
	+
	+ We do, however, make the following adjustments in notation for @{term in_hom} so that
	+ it is distinguished from the notion @{term in_hhom} (``in horizontal hom'') to be
	+ introduced subsequently.
	+ \<close>
	+
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+ notation in_hom ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
	+
	+ lemma is_partial_magma:
	+ shows "partial_magma H"
	+ proof
	+ show "\<exists>!n. \<forall>f. n \<star> f = n \<and> f \<star> n = n"
	+ proof
	+ show 1: "\<forall>f. null \<star> f = null \<and> f \<star> null = null"
	+ using is_extensional VoV.inclusion VoV.arr_char by force
	+ show "\<And>n. \<forall>f. n \<star> f = n \<and> f \<star> n = n \<Longrightarrow> n = null"
	+ using 1 VoV.arr_char is_extensional not_arr_null by metis
	+ qed
	+ qed
	+
	+ interpretation H: partial_magma H
	+ using is_partial_magma by auto
	+
	+ text \<open>
	+ Either \<open>match_1\<close> or \<open>match_2\<close> seems essential for the next result, which states
	+ that the nulls for the horizontal and vertical compositions coincide.
	+ \<close>
	+
	+ lemma null_agreement [simp]:
	+ shows "H.null = null"
	+ by (metis VoV.inclusion VxV.not_arr_null match_1 H.comp_null(1))
	+
	+ lemma composable_implies_arr:
	+ assumes "\<nu> \<star> \<mu> \<noteq> null"
	+ shows "arr \<mu>" and "arr \<nu>"
	+ using assms is_extensional VoV.arr_char VoV.inclusion by auto
	+
	+ lemma hcomp_null [simp]:
	+ shows "null \<star> \<mu> = null" and "\<mu> \<star> null = null"
	+ using H.comp_null by auto
	+
	+ lemma hcomp_simps\<^sub>W\<^sub>C [simp]:
	+ assumes "\<nu> \<star> \<mu> \<noteq> null"
	+ shows "arr (\<nu> \<star> \<mu>)" and "dom (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>" and "cod (\<nu> \<star> \<mu>) = cod \<nu> \<star> cod \<mu>"
	+ using assms preserves_arr preserves_dom preserves_cod VoV.arr_char VoV.inclusion
	+ by force+
	+
	+ lemma ide_hcomp\<^sub>W\<^sub>C [simp]:
	+ assumes "ide f" and "ide g" and "g \<star> f \<noteq> null"
	+ shows "ide (g \<star> f)"
	+ using assms preserves_ide VoV.ide_char by force
	+
	+ lemma hcomp_in_hom\<^sub>W\<^sub>C [intro]:
	+ assumes "\<nu> \<star> \<mu> \<noteq> null"
	+ shows "\<guillemotleft>\<nu> \<star> \<mu> : dom \<nu> \<star> dom \<mu> \<Rightarrow> cod \<nu> \<star> cod \<mu>\<guillemotright>"
	+ using assms by auto
	+
	+ text \<open>
	+ Horizontal composability of arrows is determined by horizontal composability of
	+ their domains and codomains (defined with respect to vertical composition).
	+ \<close>
	+
	+ lemma hom_connected:
	+ shows "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> dom \<nu> \<star> \<mu> \<noteq> null"
	+ and "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> dom \<mu> \<noteq> null"
	+ and "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> cod \<nu> \<star> \<mu> \<noteq> null"
	+ and "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> cod \<mu> \<noteq> null"
	+ proof -
	+ show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> dom \<nu> \<star> \<mu> \<noteq> null"
	+ using left_connected [of \<nu> "dom \<nu>" \<mu>] composable_implies_arr arr_dom_iff_arr by force
	+ show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> cod \<nu> \<star> \<mu> \<noteq> null"
	+ using left_connected [of "cod \<nu>" \<nu> \<mu>] composable_implies_arr arr_cod_iff_arr by force
	+ show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> dom \<mu> \<noteq> null"
	+ using right_connected [of \<mu> "dom \<mu>" \<nu>] composable_implies_arr arr_dom_iff_arr by force
	+ show "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu> \<star> cod \<mu> \<noteq> null"
	+ using right_connected [of "cod \<mu>" \<mu> \<nu>] composable_implies_arr arr_cod_iff_arr by force
	+ qed
	+
	+ lemma isomorphic_implies_equicomposable:
	+ assumes "f \<cong> g"
	+ shows "\<tau> \<star> f \<noteq> null \<longleftrightarrow> \<tau> \<star> g \<noteq> null"
	+ and "f \<star> \<sigma> \<noteq> null \<longleftrightarrow> g \<star> \<sigma> \<noteq> null"
	+ using assms isomorphic_def hom_connected by auto
	+
	+ lemma interchange:
	+ assumes "seq \<nu> \<mu>" and "seq \<tau> \<sigma>"
	+ shows "(\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
	+ proof -
	+ have "\<mu> \<star> \<sigma> = null \<Longrightarrow> ?thesis"
	+ by (metis assms comp_null(2) dom_comp hom_connected(1-2))
	+ moreover have "\<mu> \<star> \<sigma> \<noteq> null \<Longrightarrow> ?thesis"
	+ proof -
	+ assume \<mu>\<sigma>: "\<mu> \<star> \<sigma> \<noteq> null"
	+ have 1: "VoV.arr (\<mu>, \<sigma>)"
	+ using \<mu>\<sigma> VoV.arr_char by auto
	+ have \<nu>\<tau>: "(\<nu>, \<tau>) \<in> VoV.hom (VoV.cod (\<mu>, \<sigma>)) (VoV.cod (\<nu>, \<tau>))"
	+ proof -
	+ have "VoV.arr (\<nu>, \<tau>)"
	+ using assms 1 hom_connected VoV.arr_char
	+ by (elim seqE, auto, metis)
	+ thus ?thesis
	+ using assms \<mu>\<sigma> VoV.dom_char VoV.cod_char by fastforce
	+ qed
	+ show ?thesis
	+ proof -
	+ have "VoV.seq (\<nu>, \<tau>) (\<mu>, \<sigma>)"
	+ using assms 1 \<mu>\<sigma> \<nu>\<tau> VoV.seqI by blast
	+ thus ?thesis
	+ using assms 1 \<mu>\<sigma> \<nu>\<tau> VoV.comp_char preserves_comp [of "(\<nu>, \<tau>)" "(\<mu>, \<sigma>)"] VoV.seqI
	+ by fastforce
	+ qed
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+
	+ lemma paste_1:
	+ shows "\<nu> \<star> \<mu> = (cod \<nu> \<star> \<mu>) \<cdot> (\<nu> \<star> dom \<mu>)"
	+ using interchange composable_implies_arr comp_arr_dom comp_cod_arr
	+ hom_connected(2-3)
	+ by (metis comp_null(2))
	+
	+ lemma paste_2:
	+ shows "\<nu> \<star> \<mu> = (\<nu> \<star> cod \<mu>) \<cdot> (dom \<nu> \<star> \<mu>)"
	+ using interchange composable_implies_arr comp_arr_dom comp_cod_arr
	+ hom_connected(1,4)
	+ by (metis comp_null(2))
	+
	+ lemma whisker_left:
	+ assumes "seq \<nu> \<mu>" and "ide f"
	+ shows "f \<star> (\<nu> \<cdot> \<mu>) = (f \<star> \<nu>) \<cdot> (f \<star> \<mu>)"
	+ using assms interchange [of f f \<nu> \<mu>] hom_connected by auto
	+
	+ lemma whisker_right:
	+ assumes "seq \<nu> \<mu>" and "ide f"
	+ shows "(\<nu> \<cdot> \<mu>) \<star> f = (\<nu> \<star> f) \<cdot> (\<mu> \<star> f)"
	+ using assms interchange [of \<nu> \<mu> f f] hom_connected by auto
	+
	+ subsection "Hom-Subcategories"
	+
	+ definition left
	+ where "left \<tau> \<equiv> \<lambda>\<mu>. \<tau> \<star> \<mu> \<noteq> null"
	+
	+ definition right
	+ where "right \<sigma> \<equiv> \<lambda>\<mu>. \<mu> \<star> \<sigma> \<noteq> null"
	+
	+ lemma right_iff_left:
	+ shows "right \<sigma> \<tau> \<longleftrightarrow> left \<tau> \<sigma>"
	+ using right_def left_def by simp
	+
	+ lemma left_respects_isomorphic:
	+ assumes "f \<cong> g"
	+ shows "left f = left g"
	+ using assms isomorphic_implies_equicomposable left_def by auto
	+
	+ lemma right_respects_isomorphic:
	+ assumes "f \<cong> g"
	+ shows "right f = right g"
	+ using assms isomorphic_implies_equicomposable right_def by auto
	+
	+ lemma left_iff_left_inv:
	+ assumes "iso \<mu>"
	+ shows "left \<tau> \<mu> \<longleftrightarrow> left \<tau> (inv \<mu>)"
	+ using assms left_def inv_in_hom hom_connected(2) hom_connected(4) [of \<tau> "inv \<mu>"]
	+ by auto
	+
	+ lemma right_iff_right_inv:
	+ assumes "iso \<mu>"
	+ shows "right \<sigma> \<mu> \<longleftrightarrow> right \<sigma> (inv \<mu>)"
	+ using assms right_def inv_in_hom hom_connected(1) hom_connected(3) [of "inv \<mu>" \<sigma>]
	+ by auto
	+
	+ lemma left_hom_is_subcategory:
	+ assumes "arr \<mu>"
	+ shows "subcategory V (left \<mu>)"
	+ proof (unfold left_def, unfold_locales)
	+ show "\<And>f. \<mu> \<star> f \<noteq> null \<Longrightarrow> arr f" using composable_implies_arr by simp
	+ show "\<And>f. \<mu> \<star> f \<noteq> null \<Longrightarrow> \<mu> \<star> dom f \<noteq> null" using hom_connected(2) by simp
	+ show "\<And>f. \<mu> \<star> f \<noteq> null \<Longrightarrow> \<mu> \<star> cod f \<noteq> null" using hom_connected(4) by auto
	+ show "\<And>f g. \<lbrakk> \<mu> \<star> f \<noteq> null; \<mu> \<star> g \<noteq> null; cod f = dom g \<rbrakk> \<Longrightarrow> \<mu> \<star> (g \<cdot> f) \<noteq> null"
	+ proof -
	+ fix f g
	+ assume f: "\<mu> \<star> f \<noteq> null" and g: "\<mu> \<star> g \<noteq> null" and fg: "cod f = dom g"
	+ show "\<mu> \<star> (g \<cdot> f) \<noteq> null"
	+ using f g fg composable_implies_arr hom_connected(2) [of \<mu> "g \<cdot> f"] hom_connected(2)
	+ by simp
	+ qed
	+ qed
	+
	+ lemma right_hom_is_subcategory:
	+ assumes "arr \<mu>"
	+ shows "subcategory V (right \<mu>)"
	+ proof (unfold right_def, unfold_locales)
	+ show "\<And>f. f \<star> \<mu> \<noteq> null \<Longrightarrow> arr f" using composable_implies_arr by simp
	+ show "\<And>f. f \<star> \<mu> \<noteq> null \<Longrightarrow> dom f \<star> \<mu> \<noteq> null" using hom_connected(1) by auto
	+ show "\<And>f. f \<star> \<mu> \<noteq> null \<Longrightarrow> cod f \<star> \<mu> \<noteq> null" using hom_connected(3) by auto
	+ show "\<And>f g. \<lbrakk> f \<star> \<mu> \<noteq> null; g \<star> \<mu> \<noteq> null; cod f = dom g \<rbrakk> \<Longrightarrow> (g \<cdot> f) \<star> \<mu> \<noteq> null"
	+ proof -
	+ fix f g
	+ assume f: "f \<star> \<mu> \<noteq> null" and g: "g \<star> \<mu> \<noteq> null" and fg: "cod f = dom g"
	+ show "(g \<cdot> f) \<star> \<mu> \<noteq> null"
	+ using f g fg composable_implies_arr hom_connected(1) [of "g \<cdot> f" \<mu>] hom_connected(1)
	+ by simp
	+ qed
	+ qed
	+
	+ abbreviation Left
	+ where "Left a \<equiv> subcategory.comp V (left a)"
	+
	+ abbreviation Right
	+ where "Right a \<equiv> subcategory.comp V (right a)"
	+
	+ text \<open>
	+ We define operations of composition on the left or right with a fixed 1-cell,
	+ and show that such operations are functorial in case that 1-cell is
	+ horizontally self-composable.
	+ \<close>
	+
	+ definition H\<^sub>L
	+ where "H\<^sub>L g \<equiv> \<lambda>\<mu>. g \<star> \<mu>"
	+
	+ definition H\<^sub>R
	+ where "H\<^sub>R f \<equiv> \<lambda>\<mu>. \<mu> \<star> f"
	+
	+ (* TODO: Why do the following fail when I use @{thm ...} *)
	+ text \<open>
	+ Note that \<open>match_3\<close> and \<open>match_4\<close> are required for the next results.
	+ \<close>
	+
	+ lemma endofunctor_H\<^sub>L:
	+ assumes "ide g" and "g \<star> g \<noteq> null"
	+ shows "endofunctor (Left g) (H\<^sub>L g)"
	+ proof -
	+ interpret L: subcategory V \<open>left g\<close> using assms left_hom_is_subcategory by simp
	+ have *: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> H\<^sub>L g \<mu> = g \<star> \<mu>"
	+ using assms H\<^sub>L_def by simp
	+ have preserves_arr: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> L.arr (H\<^sub>L g \<mu>)"
	+ using assms * L.arr_char left_def match_4 by force
	+ show "endofunctor L.comp (H\<^sub>L g)"
	+ proof
	+ show "\<And>\<mu>. \<not> L.arr \<mu> \<Longrightarrow> H\<^sub>L g \<mu> = L.null"
	+ using assms L.arr_char L.null_char left_def H\<^sub>L_def by fastforce
	+ show "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> L.arr (H\<^sub>L g \<mu>)" by fact
	+ fix \<mu>
	+ assume "L.arr \<mu>"
	+ hence \<mu>: "L.arr \<mu> \<and> arr \<mu> \<and> g \<star> \<mu> \<noteq> null"
	+ using assms L.arr_char composable_implies_arr left_def by metis
	+ show "L.dom (H\<^sub>L g \<mu>) = H\<^sub>L g (L.dom \<mu>)"
	+ using assms \<mu> * L.arr_char L.dom_char preserves_arr hom_connected(2) left_def
	+ by simp
	+ show "L.cod (H\<^sub>L g \<mu>) = H\<^sub>L g (L.cod \<mu>)"
	+ using assms \<mu> * L.arr_char L.cod_char preserves_arr hom_connected(4) left_def
	+ by simp
	+ next
	+ fix \<mu> \<nu>
	+ assume \<mu>\<nu>: "L.seq \<nu> \<mu>"
	+ have \<mu>: "L.arr \<mu>"
	+ using \<mu>\<nu> by (elim L.seqE, auto)
	+ have \<nu>: "L.arr \<nu> \<and> arr \<nu> \<and> in_hom \<nu> (L.cod \<mu>) (L.cod \<nu>) \<and> left g \<nu> \<and> g \<star> \<nu> \<noteq> null"
	+ proof -
	+ have 1: "L.in_hom \<nu> (L.cod \<mu>) (L.cod \<nu>)"
	+ using \<mu>\<nu> by (elim L.seqE, auto)
	+ hence "arr \<nu> \<and> left g \<nu>"
	+ using L.hom_char by blast
	+ thus ?thesis
	+ using assms 1 left_def by fastforce
	+ qed
	+ show "H\<^sub>L g (L.comp \<nu> \<mu>) = L.comp (H\<^sub>L g \<nu>) (H\<^sub>L g \<mu>)"
	+ proof -
	+ have "H\<^sub>L g (L.comp \<nu> \<mu>) = g \<star> (\<nu> \<cdot> \<mu>)"
	+ using \<mu> \<nu> H\<^sub>L_def L.comp_def L.arr_char by fastforce
	+ also have "... = (g \<star> \<nu>) \<cdot> (g \<star> \<mu>)"
	+ using assms \<mu> \<nu> L.inclusion whisker_left L.arr_char by fastforce
	+ also have "... = L.comp (H\<^sub>L g \<nu>) (H\<^sub>L g \<mu>)"
	+ using assms \<mu>\<nu> \<mu> \<nu> * preserves_arr L.arr_char L.dom_char L.cod_char L.comp_char
	+ L.inclusion H\<^sub>L_def left_def
	+ by auto
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+
	+ lemma endofunctor_H\<^sub>R:
	+ assumes "ide f" and "f \<star> f \<noteq> null"
	+ shows "endofunctor (Right f) (H\<^sub>R f)"
	+ proof -
	+ interpret R: subcategory V \<open>right f\<close> using assms right_hom_is_subcategory by simp
	+ have *: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> H\<^sub>R f \<mu> = \<mu> \<star> f"
	+ using assms H\<^sub>R_def by simp
	+ have preserves_arr: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> R.arr (H\<^sub>R f \<mu>)"
	+ using assms * R.arr_char right_def match_3 by force
	+ show "endofunctor R.comp (H\<^sub>R f)"
	+ proof
	+ show "\<And>\<mu>. \<not> R.arr \<mu> \<Longrightarrow> H\<^sub>R f \<mu> = R.null"
	+ using assms R.arr_char R.null_char right_def H\<^sub>R_def by fastforce
	+ show "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> R.arr (H\<^sub>R f \<mu>)" by fact
	+ fix \<mu>
	+ assume "R.arr \<mu>"
	+ hence \<mu>: "R.arr \<mu> \<and> arr \<mu> \<and> \<mu> \<star> f \<noteq> null"
	+ using assms R.arr_char composable_implies_arr right_def by simp
	+ show "R.dom (H\<^sub>R f \<mu>) = H\<^sub>R f (R.dom \<mu>)"
	+ using assms \<mu> * R.arr_char R.dom_char preserves_arr hom_connected(1) right_def
	+ by simp
	+ show "R.cod (H\<^sub>R f \<mu>) = H\<^sub>R f (R.cod \<mu>)"
	+ using assms \<mu> * R.arr_char R.cod_char preserves_arr hom_connected(3) right_def
	+ by simp
	+ next
	+ fix \<mu> \<nu>
	+ assume \<mu>\<nu>: "R.seq \<nu> \<mu>"
	+ have \<mu>: "R.arr \<mu>"
	+ using \<mu>\<nu> by (elim R.seqE, auto)
	+ have \<nu>: "R.arr \<nu> \<and> arr \<nu> \<and> in_hom \<nu> (R.cod \<mu>) (R.cod \<nu>) \<and> right f \<nu> \<and> \<nu> \<star> f \<noteq> null"
	+ proof -
	+ have 1: "R.in_hom \<nu> (R.cod \<mu>) (R.cod \<nu>)"
	+ using \<mu>\<nu> by (elim R.seqE, auto)
	+ hence "arr \<nu> \<and> right f \<nu>"
	+ using R.hom_char by blast
	+ thus ?thesis
	+ using assms 1 right_def by fastforce
	+ qed
	+ show "H\<^sub>R f (R.comp \<nu> \<mu>) = R.comp (H\<^sub>R f \<nu>) (H\<^sub>R f \<mu>)"
	+ proof -
	+ have "H\<^sub>R f (R.comp \<nu> \<mu>) = (\<nu> \<cdot> \<mu>) \<star> f"
	+ using \<mu> \<nu> H\<^sub>R_def R.comp_def R.arr_char by fastforce
	+ also have "... = (\<nu> \<star> f) \<cdot> (\<mu> \<star> f)"
	+ using assms \<mu> \<nu> R.inclusion whisker_right R.arr_char by fastforce
	+ also have "... = R.comp (H\<^sub>R f \<nu>) (H\<^sub>R f \<mu>)"
	+ using assms \<mu>\<nu> \<mu> \<nu> * preserves_arr R.arr_char R.dom_char R.cod_char R.comp_char
	+ R.inclusion H\<^sub>R_def right_def
	+ by auto
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ locale left_hom =
	+ weak_composition V H +
	+ S: subcategory V \<open>left \<omega>\<close>
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a comp" (infixr "\<star>" 53)
	+ and \<omega> :: 'a +
	+ assumes arr_\<omega>: "arr \<omega>"
	+ begin
	+
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+ notation in_hom ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
	+ notation S.comp (infixr "\<cdot>\<^sub>S" 55)
	+ notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
	+
	+ lemma right_hcomp_closed [simp]:
	+ assumes "\<guillemotleft>\<mu> : x \<Rightarrow>\<^sub>S y\<guillemotright>" and "\<guillemotleft>\<nu> : c \<Rightarrow> d\<guillemotright>" and "\<mu> \<star> \<nu> \<noteq> null"
	+ shows "\<guillemotleft>\<mu> \<star> \<nu> : x \<star> c \<Rightarrow>\<^sub>S y \<star> d\<guillemotright>"
	+ proof
	+ show 1: "S.arr (\<mu> \<star> \<nu>)"
	+ using assms arr_\<omega> S.arr_char left_def match_4
	+ by (elim S.in_homE, meson)
	+ show "S.dom (\<mu> \<star> \<nu>) = x \<star> c"
	+ using assms 1 by force
	+ show "S.cod (\<mu> \<star> \<nu>) = y \<star> d"
	+ using assms 1 by force
	+ qed
	+
	+ lemma interchange:
	+ assumes "S.seq \<nu> \<mu>" and "S.seq \<tau> \<sigma>" and "\<mu> \<star> \<sigma> \<noteq> null"
	+ shows "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
	+ proof -
	+ have 1: "\<nu> \<star> \<tau> \<noteq> null"
	+ using assms hom_connected(1) [of \<nu> \<sigma>] hom_connected(2) [of \<nu> \<tau>] hom_connected(3-4)
	+ by force
	+ have "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>)"
	+ using assms S.comp_char S.seq_char by metis
	+ also have "... = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
	+ using assms interchange S.seq_char S.arr_char by simp
	+ also have "... = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
	+ proof -
	+ have "S.arr (\<nu> \<star> \<tau>)"
	+ proof -
	+ have "\<guillemotleft>\<tau> : dom \<tau> \<Rightarrow> cod \<tau>\<guillemotright>"
	+ using assms S.in_hom_char by blast
	+ thus ?thesis
	+ using assms 1 right_hcomp_closed by blast
	+ qed
	+ moreover have "S.arr (\<mu> \<star> \<sigma>)"
	+ proof -
	+ have "\<guillemotleft>\<sigma> : dom \<sigma> \<Rightarrow> cod \<sigma>\<guillemotright>"
	+ using assms S.in_hom_char by blast
	+ thus ?thesis
	+ using assms right_hcomp_closed [of \<mu> "dom \<mu>" "cod \<mu>" \<sigma> "dom \<sigma>" "cod \<sigma>"] by fastforce
	+ qed
	+ moreover have "seq (\<nu> \<star> \<tau>) (\<mu> \<star> \<sigma>)"
	+ using assms 1 S.in_hom_char
	+ by (metis (full_types) S.seq_char hcomp_simps\<^sub>W\<^sub>C(1-3) seqE seqI)
	+ ultimately show ?thesis
	+ using S.comp_char by auto
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+
	+ lemma inv_char:
	+ assumes "S.arr \<phi>" and "iso \<phi>"
	+ shows "S.inverse_arrows \<phi> (inv \<phi>)"
	+ and "S.inv \<phi> = inv \<phi>"
	+ proof -
	+ have 1: "S.arr (inv \<phi>)"
	+ proof -
	+ have "S.arr \<phi>" using assms by auto
	+ hence "\<omega> \<star> \<phi> \<noteq> null"
	+ using S.arr_char left_def by simp
	+ hence "\<omega> \<star> cod \<phi> \<noteq> null"
	+ using hom_connected(4) by blast
	+ hence "\<omega> \<star> dom (inv \<phi>) \<noteq> null"
	+ using assms S.iso_char by simp
	+ hence "\<omega> \<star> inv \<phi> \<noteq> null"
	+ using hom_connected by blast
	+ thus "S.arr (inv \<phi>)"
	+ using S.arr_char left_def by force
	+ qed
	+ show "S.inv \<phi> = inv \<phi>"
	+ using assms 1 S.inv_char S.iso_char by blast
	+ thus "S.inverse_arrows \<phi> (inv \<phi>)"
	+ using assms 1 S.iso_char S.inv_is_inverse by metis
	+ qed
	+
	+ lemma iso_char:
	+ assumes "S.arr \<phi>"
	+ shows "S.iso \<phi> \<longleftrightarrow> iso \<phi>"
	+ using assms S.iso_char inv_char by auto
	+
	+ end
	+
	+ locale right_hom =
	+ weak_composition V H +
	+ S: subcategory V \<open>right \<omega>\<close>
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a comp" (infixr "\<star>" 53)
	+ and \<omega> :: 'a +
	+ assumes arr_\<omega>: "arr \<omega>"
	+ begin
	+
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+ notation in_hom ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
	+ notation S.comp (infixr "\<cdot>\<^sub>S" 55)
	+ notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
	+
	+ lemma left_hcomp_closed [simp]:
	+ assumes "\<guillemotleft>\<mu> : x \<Rightarrow>\<^sub>S y\<guillemotright>" and "\<guillemotleft>\<nu> : c \<Rightarrow> d\<guillemotright>" and "\<nu> \<star> \<mu> \<noteq> null"
	+ shows "\<guillemotleft>\<nu> \<star> \<mu> : c \<star> x \<Rightarrow>\<^sub>S d \<star> y\<guillemotright>"
	+ proof
	+ show 1: "S.arr (\<nu> \<star> \<mu>)"
	+ using assms arr_\<omega> S.arr_char right_def match_3
	+ by (elim S.in_homE, meson)
	+ show "S.dom (\<nu> \<star> \<mu>) = c \<star> x"
	+ using assms 1 by force
	+ show "S.cod (\<nu> \<star> \<mu>) = d \<star> y"
	+ using assms 1 by force
	+ qed
	+
	+ lemma interchange:
	+ assumes "S.seq \<nu> \<mu>" and "S.seq \<tau> \<sigma>" and "\<mu> \<star> \<sigma> \<noteq> null"
	+ shows "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
	+ proof -
	+ have 1: "\<nu> \<star> \<tau> \<noteq> null"
	+ using assms hom_connected(1) [of \<nu> \<sigma>] hom_connected(2) [of \<nu> \<tau>] hom_connected(3-4)
	+ by fastforce
	+ have "(\<nu> \<cdot>\<^sub>S \<mu>) \<star> (\<tau> \<cdot>\<^sub>S \<sigma>) = (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>)"
	+ using assms S.comp_char S.seq_char by metis
	+ also have "... = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
	+ using assms interchange S.seq_char S.arr_char by simp
	+ also have "... = (\<nu> \<star> \<tau>) \<cdot>\<^sub>S (\<mu> \<star> \<sigma>)"
	+ proof -
	+ have "S.arr (\<nu> \<star> \<tau>)"
	+ proof -
	+ have "\<guillemotleft>\<nu> : dom \<nu> \<Rightarrow> cod \<nu>\<guillemotright>"
	+ using assms S.in_hom_char by blast
	+ thus ?thesis
	+ using assms 1 left_hcomp_closed by blast
	+ qed
	+ moreover have "S.arr (\<mu> \<star> \<sigma>)"
	+ proof -
	+ have "\<guillemotleft>\<mu> : dom \<mu> \<Rightarrow> cod \<mu>\<guillemotright>"
	+ using assms S.in_hom_char by blast
	+ thus ?thesis
	+ using assms left_hcomp_closed [of \<sigma> "dom \<sigma>" "cod \<sigma>" \<mu> "dom \<mu>" "cod \<mu>"]
	+ by fastforce
	+ qed
	+ moreover have "seq (\<nu> \<star> \<tau>) (\<mu> \<star> \<sigma>)"
	+ using assms 1 S.in_hom_char
	+ by (metis (full_types) S.seq_char hcomp_simps\<^sub>W\<^sub>C(1-3) seqE seqI)
	+ ultimately show ?thesis
	+ using S.comp_char by auto
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+
	+ lemma inv_char:
	+ assumes "S.arr \<phi>" and "iso \<phi>"
	+ shows "S.inverse_arrows \<phi> (inv \<phi>)"
	+ and "S.inv \<phi> = inv \<phi>"
	+ proof -
	+ have 1: "S.arr (inv \<phi>)"
	+ proof -
	+ have "S.arr \<phi>" using assms by auto
	+ hence "\<phi> \<star> \<omega> \<noteq> null"
	+ using S.arr_char right_def by simp
	+ hence "cod \<phi> \<star> \<omega> \<noteq> null"
	+ using hom_connected(3) by blast
	+ hence "dom (inv \<phi>) \<star> \<omega> \<noteq> null"
	+ using assms S.iso_char by simp
	+ hence "inv \<phi> \<star> \<omega> \<noteq> null"
	+ using hom_connected(1) by blast
	+ thus ?thesis
	+ using S.arr_char right_def by force
	+ qed
	+ show "S.inv \<phi> = inv \<phi>"
	+ using assms 1 S.inv_char S.iso_char by blast
	+ thus "S.inverse_arrows \<phi> (inv \<phi>)"
	+ using assms 1 S.iso_char S.inv_is_inverse by metis
	+ qed
	+
	+ lemma iso_char:
	+ assumes "S.arr \<phi>"
	+ shows "S.iso \<phi> \<longleftrightarrow> iso \<phi>"
	+ using assms S.iso_char inv_char by auto
	+
	+ end
	+
	+ subsection "Weak Units"
	+
	+ text \<open>
	+ We now define a \emph{weak unit} to be an arrow \<open>a\<close> such that:
	+ \begin{enumerate}
	+ \item \<open>a \<star> a\<close> is isomorphic to \<open>a\<close>
	+ (and hence \<open>a\<close> is a horizontally self-composable 1-cell).
	+ \item Horizontal composition on the left with \<open>a\<close> is a fully faithful endofunctor of the
	+ subcategory of arrows that are composable on the left with \<open>a\<close>.
	+ \item Horizontal composition on the right with \<open>a\<close> is fully faithful endofunctor of the
	+ subcategory of arrows that are composable on the right with \<open>a\<close>.
	+ \end{enumerate}
	+ \<close>
	+
	+ context weak_composition
	+ begin
	+
	+ definition weak_unit :: "'a \<Rightarrow> bool"
	+ where "weak_unit a \<equiv> a \<star> a \<cong> a \<and>
	+ fully_faithful_functor (Left a) (Left a) (H\<^sub>L a) \<and>
	+ fully_faithful_functor (Right a) (Right a) (H\<^sub>R a)"
	+
	+ lemma weak_unit_self_composable [simp]:
	+ assumes "weak_unit a"
	+ shows "ide a" and "ide (a \<star> a)" and "a \<star> a \<noteq> null"
	+ proof -
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : a \<star> a \<Rightarrow> a\<guillemotright> \<and> iso \<phi>"
	+ using assms weak_unit_def isomorphic_def by blast
	+ have 1: "arr \<phi>" using \<phi> by blast
	+ show "ide a" using \<phi> ide_cod by blast
	+ thus "ide (a \<star> a)" using \<phi> ide_dom by force
	+ thus "a \<star> a \<noteq> null" using not_arr_null ideD(1) by metis
	+ qed
	+
	+ lemma weak_unit_self_right:
	+ assumes "weak_unit a"
	+ shows "right a a"
	+ using assms weak_unit_self_composable right_def by simp
	+
	+ lemma weak_unit_self_left:
	+ assumes "weak_unit a"
	+ shows "left a a"
	+ using assms weak_unit_self_composable left_def by simp
	+
	+ lemma weak_unit_in_vhom:
	+ assumes "weak_unit a"
	+ shows "\<guillemotleft>a : a \<Rightarrow> a\<guillemotright>"
	+ using assms weak_unit_self_composable left_def by auto
	+
	+ text \<open>
	+ If \<open>a\<close> is a weak unit, then there exists a ``unit isomorphism'' \<open>\<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
	+ It need not be unique, but we may choose one arbitrarily.
	+ \<close>
	+
	+ definition some_unit
	+ where "some_unit a \<equiv> SOME \<iota>. iso \<iota> \<and> \<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>"
	+
	+ lemma iso_some_unit:
	+ assumes "weak_unit a"
	+ shows "iso (some_unit a)"
	+ and "\<guillemotleft>some_unit a : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ proof -
	+ let ?P = "\<lambda>\<iota>. iso \<iota> \<and> \<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ have "\<exists>\<iota>. ?P \<iota>"
	+ using assms weak_unit_def by auto
	+ hence 1: "?P (some_unit a)"
	+ using someI_ex [of ?P] some_unit_def by simp
	+ show "iso (some_unit a)" using 1 by blast
	+ show "\<guillemotleft>some_unit a : a \<star> a \<Rightarrow> a\<guillemotright>" using 1 by blast
	+ qed
	+
	+ text \<open>
	+ The \emph{sources} of an arbitrary arrow \<open>\<mu>\<close> are the weak units that are composable with \<open>\<mu>\<close>
	+ on the right. Similarly, the \emph{targets} of \<open>\<mu>\<close> are the weak units that are composable
	+ with \<open>\<mu>\<close> on the left.
	+ \<close>
	+
	+ definition sources
	+ where "sources \<mu> \<equiv> {a. weak_unit a \<and> \<mu> \<star> a \<noteq> null}"
	+
	+ lemma sourcesI [intro]:
	+ assumes "weak_unit a" and "\<mu> \<star> a \<noteq> null"
	+ shows "a \<in> sources \<mu>"
	+ using assms sources_def by blast
	+
	+ lemma sourcesD [dest]:
	+ assumes "a \<in> sources \<mu>"
	+ shows "ide a" and "weak_unit a" and "\<mu> \<star> a \<noteq> null"
	+ using assms sources_def by auto
	+
	+ definition targets
	+ where "targets \<mu> \<equiv> {b. weak_unit b \<and> b \<star> \<mu> \<noteq> null}"
	+
	+ lemma targetsI [intro]:
	+ assumes "weak_unit b" and "b \<star> \<mu> \<noteq> null"
	+ shows "b \<in> targets \<mu>"
	+ using assms targets_def by blast
	+
	+ lemma targetsD [dest]:
	+ assumes "b \<in> targets \<mu>"
	+ shows "ide b" and "weak_unit b" and "b \<star> \<mu> \<noteq> null"
	+ using assms targets_def by auto
	+
	+ lemma sources_dom [simp]:
	+ assumes "arr \<mu>"
	+ shows "sources (dom \<mu>) = sources \<mu>"
	+ using assms hom_connected(1) by blast
	+
	+ lemma sources_cod [simp]:
	+ assumes "arr \<mu>"
	+ shows "sources (cod \<mu>) = sources \<mu>"
	+ using assms hom_connected(3) by blast
	+
	+ lemma targets_dom [simp]:
	+ assumes "arr \<mu>"
	+ shows "targets (dom \<mu>) = targets \<mu>"
	+ using assms hom_connected(2) by blast
	+
	+ lemma targets_cod [simp]:
	+ assumes "arr \<mu>"
	+ shows "targets (cod \<mu>) = targets \<mu>"
	+ using assms hom_connected(4) by blast
	+
	+ lemma weak_unit_iff_self_source:
	+ shows "weak_unit a \<longleftrightarrow> a \<in> sources a"
	+ using weak_unit_self_composable by auto
	+
	+ lemma weak_unit_iff_self_target:
	+ shows "weak_unit b \<longleftrightarrow> b \<in> targets b"
	+ using weak_unit_self_composable by auto
	+
	+ abbreviation (input) in_hhom\<^sub>W\<^sub>C ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>W\<^sub>C _\<guillemotright>")
	+ where "in_hhom\<^sub>W\<^sub>C \<mu> f g \<equiv> arr \<mu> \<and> f \<in> sources \<mu> \<and> g \<in> targets \<mu>"
	+
	+ lemma sources_hcomp:
	+ assumes "\<nu> \<star> \<mu> \<noteq> null"
	+ shows "sources (\<nu> \<star> \<mu>) = sources \<mu>"
	+ using assms match_1 match_3 null_agreement by blast
	+
	+ lemma targets_hcomp:
	+ assumes "\<nu> \<star> \<mu> \<noteq> null"
	+ shows "targets (\<nu> \<star> \<mu>) = targets \<nu>"
	+ using assms match_2 match_4 null_agreement by blast
	+
	+ lemma H\<^sub>R_preserved_along_iso:
	+ assumes "weak_unit a" and "a \<cong> a'"
	+ shows "endofunctor (Right a) (H\<^sub>R a')"
	+ proof -
	+ have a: "ide a \<and> weak_unit a" using assms isomorphic_def by auto
	+ have a': "ide a'" using assms isomorphic_def by auto
	+ (* TODO: The following interpretation re-introduces unwanted notation for "in_hom" *)
	+ interpret R: subcategory V \<open>right a\<close> using a right_hom_is_subcategory by simp
	+ have *: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> H\<^sub>R a' \<mu> = \<mu> \<star> a'"
	+ using assms H\<^sub>R_def by simp
	+ have preserves_arr: "\<And>\<mu>. R.arr \<mu> \<Longrightarrow> R.arr (H\<^sub>R a' \<mu>)"
	+ using assms a' * R.arr_char right_def weak_unit_def weak_unit_self_composable
	+ isomorphic_implies_equicomposable R.ide_char match_3 hcomp_simps\<^sub>W\<^sub>C(1)
	+ null_agreement
	+ by metis
	+ show "endofunctor R.comp (H\<^sub>R a')"
	+ proof
	+ show "\<And>\<mu>. \<not> R.arr \<mu> \<Longrightarrow> H\<^sub>R a' \<mu> = R.null"
	+ using assms R.arr_char R.null_char right_def H\<^sub>R_def null_agreement
	+ right_respects_isomorphic
	+ by metis
	+ fix \<mu>
	+ assume "R.arr \<mu>"
	+ hence \<mu>: "R.arr \<mu> \<and> arr \<mu> \<and> right a \<mu> \<and> right a' \<mu> \<and> \<mu> \<star> a \<noteq> null \<and> \<mu> \<star> a' \<noteq> null"
	+ using assms R.arr_char right_respects_isomorphic composable_implies_arr null_agreement
	+ right_def
	+ by metis
	+ show "R.arr (H\<^sub>R a' \<mu>)" using \<mu> preserves_arr by blast
	+ show "R.dom (H\<^sub>R a' \<mu>) = H\<^sub>R a' (R.dom \<mu>)"
	+ using a' \<mu> * R.arr_char R.dom_char preserves_arr hom_connected(1) right_def
	+ by simp
	+ show "R.cod (H\<^sub>R a' \<mu>) = H\<^sub>R a' (R.cod \<mu>)"
	+ using a' \<mu> * R.arr_char R.cod_char preserves_arr hom_connected(3) right_def
	+ by simp
	+ next
	+ fix \<mu> \<nu>
	+ assume \<mu>\<nu>: "R.seq \<nu> \<mu>"
	+ have "R.arr \<mu>"
	+ using \<mu>\<nu> by (elim R.seqE, auto)
	+ hence \<mu>: "R.arr \<mu> \<and> arr \<mu> \<and> right a \<mu> \<and> right a' \<mu> \<and> \<mu> \<star> a \<noteq> null \<and> \<mu> \<star> a' \<noteq> null"
	+ using assms R.arr_char right_respects_isomorphic composable_implies_arr null_agreement
	+ right_def
	+ by metis
	+ have "\<nu> \<in> R.hom (R.cod \<mu>) (R.cod \<nu>)"
	+ using \<mu>\<nu> by (elim R.seqE, auto)
	+ hence "\<guillemotleft>\<nu> : R.cod \<mu> \<Rightarrow> R.cod \<nu>\<guillemotright> \<and> arr \<nu> \<and> \<nu> \<in> Collect (right a)"
	+ using R.hom_char by blast
	+ hence \<nu>: "\<guillemotleft>\<nu> : R.cod \<mu> \<rightarrow> R.cod \<nu>\<guillemotright> \<and> arr \<nu> \<and>
	+ right a \<nu> \<and> H \<nu> a \<noteq> null \<and> right a' \<nu> \<and> H \<nu> a' \<noteq> null"
	+ using assms right_def right_respects_isomorphic isomorphic_implies_equicomposable
	+ by simp
	+ show "H\<^sub>R a' (R.comp \<nu> \<mu>) = R.comp (H\<^sub>R a' \<nu>) (H\<^sub>R a' \<mu>)"
	+ proof -
	+ have 1: "R.arr (H\<^sub>R a' \<nu>)"
	+ using \<nu> preserves_arr by blast
	+ have 2: "seq (\<nu> \<star> a') (\<mu> \<star> a')"
	+ using a' \<mu> \<nu> R.arr_char R.inclusion R.dom_char R.cod_char
	+ isomorphic_implies_equicomposable
	+ by auto
	+ show ?thesis
	+ proof -
	+ have "H\<^sub>R a' (R.comp \<nu> \<mu>) = (\<nu> \<cdot> \<mu>) \<star> a'"
	+ using \<mu> \<nu> H\<^sub>R_def R.comp_def by fastforce
	+ also have "... = (\<nu> \<star> a') \<cdot> (\<mu> \<star> a')"
	+ proof -
	+ have "seq \<nu> \<mu>"
	+ using \<mu> \<nu> \<mu>\<nu> by (elim R.seqE, auto)
	+ thus ?thesis
	+ using a' \<nu> whisker_right right_def by blast
	+ qed
	+ also have "... = R.comp (H\<^sub>R a' \<nu>) (H\<^sub>R a' \<mu>)"
	+ using assms \<mu> 1 2 preserves_arr R.comp_char R.inclusion H\<^sub>R_def by auto
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+ qed
	+
	+ lemma H\<^sub>L_preserved_along_iso:
	+ assumes "weak_unit a" and "a \<cong> a'"
	+ shows "endofunctor (Left a) (H\<^sub>L a')"
	+ proof -
	+ have a: "ide a \<and> weak_unit a" using assms isomorphic_def by auto
	+ have a': "ide a'" using assms isomorphic_def by auto
	+ (* TODO: The following interpretation re-introduces unwanted notation for "in_hom" *)
	+ interpret L: subcategory V \<open>left a\<close> using a left_hom_is_subcategory by simp
	+ have *: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> H\<^sub>L a' \<mu> = a' \<star> \<mu>"
	+ using assms H\<^sub>L_def by simp
	+ have preserves_arr: "\<And>\<mu>. L.arr \<mu> \<Longrightarrow> L.arr (H\<^sub>L a' \<mu>)"
	+ using assms a' * L.arr_char left_def weak_unit_def weak_unit_self_composable
	+ isomorphic_implies_equicomposable L.ide_char match_4 hcomp_simps\<^sub>W\<^sub>C(1)
	+ null_agreement
	+ by metis
	+ show "endofunctor L.comp (H\<^sub>L a')"
	+ proof
	+ show "\<And>\<mu>. \<not> L.arr \<mu> \<Longrightarrow> H\<^sub>L a' \<mu> = L.null"
	+ using assms L.arr_char L.null_char left_def H\<^sub>L_def null_agreement
	+ left_respects_isomorphic
	+ by metis
	+ fix \<mu>
	+ assume "L.arr \<mu>"
	+ hence \<mu>: "L.arr \<mu> \<and> arr \<mu> \<and> left a \<mu> \<and> left a' \<mu> \<and> a \<star> \<mu> \<noteq> null \<and> a' \<star> \<mu> \<noteq> null"
	+ using assms L.arr_char left_respects_isomorphic composable_implies_arr null_agreement
	+ left_def
	+ by metis
	+ show "L.arr (H\<^sub>L a' \<mu>)" using \<mu> preserves_arr by blast
	+ show "L.dom (H\<^sub>L a' \<mu>) = H\<^sub>L a' (L.dom \<mu>)"
	+ using a' \<mu> * L.arr_char L.dom_char preserves_arr hom_connected(2) left_def
	+ by simp
	+ show "L.cod (H\<^sub>L a' \<mu>) = H\<^sub>L a' (L.cod \<mu>)"
	+ using a' \<mu> * L.arr_char L.cod_char preserves_arr hom_connected(4) left_def
	+ by simp
	+ next
	+ fix \<mu> \<nu>
	+ assume \<mu>\<nu>: "L.seq \<nu> \<mu>"
	+ have "L.arr \<mu>"
	+ using \<mu>\<nu> by (elim L.seqE, auto)
	+ hence \<mu>: "L.arr \<mu> \<and> arr \<mu> \<and> left a \<mu> \<and> left a' \<mu> \<and> a \<star> \<mu> \<noteq> null \<and> a' \<star> \<mu> \<noteq> null"
	+ using assms L.arr_char left_respects_isomorphic composable_implies_arr null_agreement
	+ left_def
	+ by metis
	+ have "L.in_hom \<nu> (L.cod \<mu>) (L.cod \<nu>)"
	+ using \<mu>\<nu> by (elim L.seqE, auto)
	+ hence "\<guillemotleft>\<nu> : L.cod \<mu> \<Rightarrow> L.cod \<nu>\<guillemotright> \<and> arr \<nu> \<and> \<nu> \<in> Collect (left a)"
	+ using L.hom_char by blast
	+ hence \<nu>: "\<guillemotleft>\<nu> : L.cod \<mu> \<Rightarrow> L.cod \<nu>\<guillemotright> \<and> arr \<nu> \<and>
	+ left a \<nu> \<and> a \<star> \<nu> \<noteq> null \<and> left a' \<nu> \<and> a' \<star> \<nu> \<noteq> null"
	+ using assms left_def left_respects_isomorphic isomorphic_implies_equicomposable
	+ by simp
	+ show "H\<^sub>L a' (L.comp \<nu> \<mu>) = L.comp (H\<^sub>L a' \<nu>) (H\<^sub>L a' \<mu>)"
	+ proof -
	+ have 1: "L.arr (H\<^sub>L a' \<nu>)"
	+ using \<nu> preserves_arr by blast
	+ have 2: "seq (a' \<star> \<nu>) (a' \<star> \<mu>)"
	+ using a' \<mu> \<nu> L.arr_char L.inclusion L.dom_char L.cod_char
	+ isomorphic_implies_equicomposable
	+ by auto
	+ have "H\<^sub>L a' (L.comp \<nu> \<mu>) = a' \<star> (\<nu> \<cdot> \<mu>)"
	+ using \<mu> \<nu> H\<^sub>L_def L.comp_def by fastforce
	+ also have "... = (a' \<star> \<nu>) \<cdot> (a' \<star> \<mu>)"
	+ proof -
	+ have "seq \<nu> \<mu>"
	+ using \<mu> \<nu> \<mu>\<nu> by (elim L.seqE, auto)
	+ thus ?thesis
	+ using a' \<nu> whisker_left right_def by blast
	+ qed
	+ also have "... = L.comp (H\<^sub>L a' \<nu>) (H\<^sub>L a' \<mu>)"
	+ using assms \<mu> 1 2 preserves_arr L.comp_char L.inclusion H\<^sub>L_def by auto
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ subsection "Regularity"
	+
	+ text \<open>
	+ We call a weak composition \emph{regular} if \<open>f \<star> a \<cong> f\<close> whenever \<open>a\<close> is a source of
	+ 1-cell \<open>f\<close>, and \<open>b \<star> f \<cong> f\<close> whenever \<open>b\<close> is a target of \<open>f\<close>. A consequence of regularity
	+ is that horizontal composability of 2-cells is fully determined by their sets of
	+ sources and targets.
	+ \<close>
	+
	+ locale regular_weak_composition =
	+ weak_composition +
	+ assumes comp_ide_source: "\<lbrakk> a \<in> sources f; ide f \<rbrakk> \<Longrightarrow> f \<star> a \<cong> f"
	+ and comp_target_ide: "\<lbrakk> b \<in> targets f; ide f \<rbrakk> \<Longrightarrow> b \<star> f \<cong> f"
	+ begin
	+
	+ lemma sources_determine_composability:
	+ assumes "a \<in> sources \<tau>"
	+ shows "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> a \<star> \<mu> \<noteq> null"
	+ proof -
	+ have *: "\<And>\<tau>. ide \<tau> \<and> a \<in> sources \<tau> \<Longrightarrow> \<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> a \<star> \<mu> \<noteq> null"
	+ proof -
	+ fix \<tau>
	+ assume \<tau>: "ide \<tau> \<and> a \<in> sources \<tau>"
	+ show "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> a \<star> \<mu> \<noteq> null"
	+ proof
	+ assume \<mu>: "\<tau> \<star> \<mu> \<noteq> null"
	+ show "a \<star> \<mu> \<noteq> null"
	+ using assms \<mu> \<tau> comp_ide_source isomorphic_implies_equicomposable match_1
	+ by blast
	+ next
	+ assume \<mu>: "a \<star> \<mu> \<noteq> null"
	+ show "\<tau> \<star> \<mu> \<noteq> null"
	+ using assms \<mu> \<tau> comp_ide_source isomorphic_implies_equicomposable match_3
	+ by blast
	+ qed
	+ qed
	+ show ?thesis
	+ proof -
	+ have "arr \<tau>" using assms composable_implies_arr by auto
	+ thus ?thesis
	+ using assms * [of "dom \<tau>"] hom_connected(1) by auto
	+ qed
	+ qed
	+
	+ lemma targets_determine_composability:
	+ assumes "b \<in> targets \<mu>"
	+ shows "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<tau> \<star> b \<noteq> null"
	+ proof -
	+ have *: "\<And>\<mu>. ide \<mu> \<and> b \<in> targets \<mu> \<Longrightarrow> \<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<tau> \<star> b \<noteq> null"
	+ proof -
	+ fix \<mu>
	+ assume \<mu>: "ide \<mu> \<and> b \<in> targets \<mu>"
	+ show "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<tau> \<star> b \<noteq> null"
	+ proof
	+ assume \<tau>: "\<tau> \<star> \<mu> \<noteq> null"
	+ show "\<tau> \<star> b \<noteq> null"
	+ using assms \<mu> \<tau> comp_target_ide isomorphic_implies_equicomposable match_2
	+ by blast
	+ next
	+ assume \<tau>: "\<tau> \<star> b \<noteq> null"
	+ show "\<tau> \<star> \<mu> \<noteq> null"
	+ using assms \<mu> \<tau> comp_target_ide isomorphic_implies_equicomposable match_4
	+ by blast
	+ qed
	+ qed
	+ show ?thesis
	+ proof -
	+ have "arr \<mu>" using assms composable_implies_arr by auto
	+ thus ?thesis
	+ using assms * [of "dom \<mu>"] hom_connected(2) by auto
	+ qed
	+ qed
	+
	+ lemma composable_if_connected:
	+ assumes "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
	+ shows "\<nu> \<star> \<mu> \<noteq> null"
	+ using assms targets_determine_composability by blast
	+
	+ lemma connected_if_composable:
	+ assumes "\<nu> \<star> \<mu> \<noteq> null"
	+ shows "sources \<nu> = targets \<mu>"
	+ using assms sources_determine_composability targets_determine_composability by blast
	+
	+ lemma iso_hcomp\<^sub>R\<^sub>W\<^sub>C:
	+ assumes "iso \<mu>" and "iso \<nu>" and "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
	+ shows "iso (\<nu> \<star> \<mu>)"
	+ and "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
	+ proof -
	+ have \<mu>: "arr \<mu> \<and> \<guillemotleft>\<mu> : dom \<mu> \<Rightarrow> cod \<mu>\<guillemotright> \<and>
	+ iso \<mu> \<and> \<guillemotleft>inv \<mu> : cod \<mu> \<Rightarrow> dom \<mu>\<guillemotright>"
	+ using assms inv_in_hom arr_iff_in_hom iso_is_arr by auto
	+ have \<nu>: "arr \<nu> \<and> \<guillemotleft>\<nu> : dom \<nu> \<Rightarrow> cod \<nu>\<guillemotright> \<and>
	+ iso \<nu> \<and> \<guillemotleft>inv \<nu> : cod \<nu> \<Rightarrow> dom \<nu>\<guillemotright>"
	+ using assms inv_in_hom by blast
	+ have 1: "sources (inv \<nu>) \<inter> targets (inv \<mu>) \<noteq> {}"
	+ proof -
	+ have "sources (inv \<nu>) \<inter> targets (inv \<mu>) = sources \<nu> \<inter> targets \<mu>"
	+ proof -
	+ have "sources (inv \<nu>) \<inter> targets (inv \<mu>)
	+ = sources (cod (inv \<nu>)) \<inter> targets (cod (inv \<mu>))"
	+ using assms \<mu> \<nu> sources_cod targets_cod arr_inv by presburger
	+ also have "... = sources (dom \<nu>) \<inter> targets (dom \<mu>)"
	+ using \<mu> \<nu> by simp
	+ also have "... = sources \<nu> \<inter> targets \<mu>"
	+ using \<mu> \<nu> sources_dom targets_dom by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis using assms by simp
	+ qed
	+ show "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
	+ proof
	+ have "(inv \<nu> \<star> inv \<mu>) \<cdot> (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>"
	+ using assms \<mu> \<nu> inv_in_hom inv_is_inverse comp_inv_arr
	+ interchange [of "inv \<nu>" \<nu> "inv \<mu>" \<mu>] composable_if_connected
	+ by simp
	+ moreover have "ide (dom \<nu> \<star> dom \<mu>)"
	+ using assms \<mu> \<nu> ide_hcomp\<^sub>W\<^sub>C composable_if_connected sources_dom targets_dom
	+ by auto
	+ ultimately show "ide ((inv \<nu> \<star> inv \<mu>) \<cdot> (\<nu> \<star> \<mu>))"
	+ by presburger
	+ have "(\<nu> \<star> \<mu>) \<cdot> (inv \<nu> \<star> inv \<mu>) = cod \<nu> \<star> cod \<mu>"
	+ using assms 1 \<mu> \<nu> inv_in_hom inv_is_inverse comp_arr_inv
	+ interchange [of \<nu> "inv \<nu>" \<mu> "inv \<mu>"] composable_if_connected
	+ by simp
	+ moreover have "ide (cod \<nu> \<star> cod \<mu>)"
	+ using assms \<mu> \<nu> ide_hcomp\<^sub>W\<^sub>C composable_if_connected sources_cod targets_cod
	+ by auto
	+ ultimately show "ide ((\<nu> \<star> \<mu>) \<cdot> (inv \<nu> \<star> inv \<mu>))"
	+ by presburger
	+ qed
	+ thus "iso (\<nu> \<star> \<mu>)" by auto
	+ qed
	+
	+ lemma inv_hcomp\<^sub>R\<^sub>W\<^sub>C:
	+ assumes "iso \<mu>" and "iso \<nu>" and "sources \<nu> \<inter> targets \<mu> \<noteq> {}"
	+ shows "inv (\<nu> \<star> \<mu>) = inv \<nu> \<star> inv \<mu>"
	+ using assms iso_hcomp\<^sub>R\<^sub>W\<^sub>C(2) [of \<mu> \<nu>] inverse_arrow_unique [of "H \<nu> \<mu>"] inv_is_inverse
	+ by auto
	+
	+ end
	+
	+ subsection "Associativity"
	+
	+ text \<open>
	+ An \emph{associative weak composition} consists of a weak composition that has been
	+ equipped with an \emph{associator} isomorphism: \<open>\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>\<close>
	+ for each composable triple \<open>(f, g, h)\<close> of 1-cells, subject to naturality and
	+ coherence conditions.
	+ \<close>
	+
	+ locale associative_weak_composition =
	+ weak_composition +
	+ fixes \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ assumes assoc_in_vhom\<^sub>A\<^sub>W\<^sub>C:
	+ "\<lbrakk> ide f; ide g; ide h; f \<star> g \<noteq> null; g \<star> h \<noteq> null \<rbrakk> \<Longrightarrow>
	+ \<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
	+ and assoc_naturality\<^sub>A\<^sub>W\<^sub>C:
	+ "\<lbrakk> \<tau> \<star> \<mu> \<noteq> null; \<mu> \<star> \<nu> \<noteq> null \<rbrakk> \<Longrightarrow>
	+ \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) = (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ and iso_assoc\<^sub>A\<^sub>W\<^sub>C: "\<lbrakk> ide f; ide g; ide h; f \<star> g \<noteq> null; g \<star> h \<noteq> null \<rbrakk> \<Longrightarrow> iso \<a>[f, g, h]"
	+ and pentagon\<^sub>A\<^sub>W\<^sub>C:
	+ "\<lbrakk> ide f; ide g; ide h; ide k; sources f \<inter> targets g \<noteq> {};
	+ sources g \<inter> targets h \<noteq> {}; sources h \<inter> targets k \<noteq> {} \<rbrakk> \<Longrightarrow>
	+ (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k) = \<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k]"
	+ begin
	+
	+ lemma assoc_in_hom\<^sub>A\<^sub>W\<^sub>C:
	+ assumes "ide f" and "ide g" and "ide h"
	+ and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
	+ shows "sources \<a>[f, g, h] = sources h" and "targets \<a>[f, g, h] = targets f"
	+ and "\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
	+ proof -
	+ show 1: "\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
	+ using assms assoc_in_vhom\<^sub>A\<^sub>W\<^sub>C by simp
	+ show "sources \<a>[f, g, h] = sources h"
	+ using assms 1 sources_dom [of "\<a>[f, g, h]"] sources_hcomp match_3
	+ by (elim in_homE, auto)
	+ show "targets \<a>[f, g, h] = targets f"
	+ using assms 1 targets_cod [of "\<a>[f, g, h]"] targets_hcomp match_4
	+ by (elim in_homE, auto)
	+ qed
	+
	+ lemma assoc_simps\<^sub>A\<^sub>W\<^sub>C [simp]:
	+ assumes "ide f" and "ide g" and "ide h"
	+ and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
	+ shows "arr \<a>[f, g, h]"
	+ and "dom \<a>[f, g, h] = (f \<star> g) \<star> h"
	+ and "cod \<a>[f, g, h] = f \<star> g \<star> h"
	+ proof -
	+ have 1: "\<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
	+ using assms assoc_in_hom\<^sub>A\<^sub>W\<^sub>C by auto
	+ show "arr \<a>[f, g, h]" using 1 by auto
	+ show "dom \<a>[f, g, h] = (f \<star> g) \<star> h" using 1 by auto
	+ show "cod \<a>[f, g, h] = f \<star> g \<star> h" using 1 by auto
	+ qed
	+
	+ lemma assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C:
	+ assumes "ide f" and "ide g" and "ide h"
	+ and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
	+ shows "sources (inv \<a>[f, g, h]) = sources h" and "targets (inv \<a>[f, g, h]) = targets f"
	+ and "\<guillemotleft>inv \<a>[f, g, h] : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
	+ proof -
	+ show 1: "\<guillemotleft>inv \<a>[f, g, h] : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
	+ using assms assoc_in_hom\<^sub>A\<^sub>W\<^sub>C iso_assoc\<^sub>A\<^sub>W\<^sub>C inv_in_hom by auto
	+ show "sources (inv \<a>[f, g, h]) = sources h"
	+ using assms 1 sources_hcomp [of "f \<star> g" h] sources_cod match_3 null_agreement
	+ by (elim in_homE, metis)
	+ show "targets (inv \<a>[f, g, h]) = targets f"
	+ using assms 1 targets_hcomp [of f "g \<star> h"] targets_dom match_4 null_agreement
	+ by (elim in_homE, metis)
	+ qed
	+
	+ lemma assoc'_simps\<^sub>A\<^sub>W\<^sub>C [simp]:
	+ assumes "ide f" and "ide g" and "ide h"
	+ and "f \<star> g \<noteq> null" and "g \<star> h \<noteq> null"
	+ shows "arr (inv \<a>[f, g, h])"
	+ and "dom (inv \<a>[f, g, h]) = f \<star> g \<star> h"
	+ and "cod (inv \<a>[f, g, h]) = (f \<star> g) \<star> h"
	+ proof -
	+ have 1: "\<guillemotleft>inv \<a>[f, g, h] : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
	+ using assms assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C by auto
	+ show "arr (inv \<a>[f, g, h])" using 1 by auto
	+ show "dom (inv \<a>[f, g, h]) = f \<star> g \<star> h" using 1 by auto
	+ show "cod (inv \<a>[f, g, h]) = (f \<star> g) \<star> h" using 1 by auto
	+ qed
	+
	+ lemma assoc'_naturality\<^sub>A\<^sub>W\<^sub>C:
	+ assumes "\<tau> \<star> \<mu> \<noteq> null" and "\<mu> \<star> \<nu> \<noteq> null"
	+ shows "inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) = ((\<tau> \<star> \<mu>) \<star> \<nu>) \<cdot> inv \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ proof -
	+ have \<tau>\<mu>\<nu>: "arr \<tau> \<and> arr \<mu> \<and> arr \<nu>"
	+ using assms composable_implies_arr by simp
	+ have 0: "dom \<tau> \<star> dom \<mu> \<noteq> null \<and> dom \<mu> \<star> dom \<nu> \<noteq> null \<and>
	+ cod \<tau> \<star> cod \<mu> \<noteq> null \<and> cod \<mu> \<star> cod \<nu> \<noteq> null"
	+ using assms \<tau>\<mu>\<nu> hom_connected by simp
	+ have 1: "\<guillemotleft>\<tau> \<star> \<mu> \<star> \<nu> : dom \<tau> \<star> dom \<mu> \<star> dom \<nu> \<Rightarrow> cod \<tau> \<star> cod \<mu> \<star> cod \<nu>\<guillemotright>"
	+ using assms match_4 by auto
	+ have 2: "\<guillemotleft>(\<tau> \<star> \<mu>) \<star> \<nu> : (dom \<tau> \<star> dom \<mu>) \<star> dom \<nu> \<Rightarrow> (cod \<tau> \<star> cod \<mu>) \<star> cod \<nu>\<guillemotright>"
	+ using assms match_3 by auto
	+ have "(inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>)) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>] = (\<tau> \<star> \<mu>) \<star> \<nu>"
	+ proof -
	+ have "(\<tau> \<star> \<mu>) \<star> \<nu> = (inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>]) \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
	+ using 0 2 \<tau>\<mu>\<nu> assoc_in_hom\<^sub>A\<^sub>W\<^sub>C iso_assoc\<^sub>A\<^sub>W\<^sub>C comp_inv_arr inv_is_inverse comp_cod_arr
	+ by auto
	+ also have "... = inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>)"
	+ using comp_assoc by auto
	+ also have "... = inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ using assms \<tau>\<mu>\<nu> 0 2 assoc_naturality\<^sub>A\<^sub>W\<^sub>C by presburger
	+ also have "... = (inv \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> (\<tau> \<star> \<mu> \<star> \<nu>)) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
	+ using comp_assoc by auto
	+ finally show ?thesis by argo
	+ qed
	+ thus ?thesis
	+ using 0 1 2 \<tau>\<mu>\<nu> iso_assoc\<^sub>A\<^sub>W\<^sub>C assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C inv_in_hom invert_side_of_triangle(2)
	+ by auto
	+ qed
	+
	+ end
	+
	+ subsection "Unitors"
	+
	+ text \<open>
	+ For an associative weak composition with a chosen unit isomorphism \<open>\<iota> : a \<star> a \<Rightarrow> a\<close>,
	+ where \<open>a\<close> is a weak unit, horizontal composition on the right by \<open>a\<close> is a fully faithful
	+ endofunctor \<open>R\<close> of the subcategory of arrows composable on the right with \<open>a\<close>, and is
	+ consequently an endo-equivalence of that subcategory. This equivalence, together with the
	+ associator isomorphisms and unit isomorphism \<open>\<iota>\<close>, canonically associate, with each
	+ identity arrow \<open>f\<close> composable on the right with \<open>a\<close>, a \emph{right unit} isomorphism
	+ \<open>\<guillemotleft>\<r>[f] : f \<star> a \<Rightarrow> f\<guillemotright>\<close>. These isomorphisms are the components of a natural isomorphism
	+ from \<open>R\<close> to the identity functor.
	+ \<close>
	+
	+ locale right_hom_with_unit =
	+ associative_weak_composition V H \<a> +
	+ right_hom V H a
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a comp" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<iota> :: 'a
	+ and a :: 'a +
	+ assumes weak_unit_a: "weak_unit a"
	+ and \<iota>_in_hom: "\<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ and iso_\<iota>: "iso \<iota>"
	+ begin
	+
	+ abbreviation R
	+ where "R \<equiv> H\<^sub>R a"
	+
	+ interpretation R: endofunctor S.comp R
	+ using weak_unit_a weak_unit_self_composable endofunctor_H\<^sub>R by simp
	+ interpretation R: fully_faithful_functor S.comp S.comp R
	+ using weak_unit_a weak_unit_def by simp
	+
	+ lemma fully_faithful_functor_R:
	+ shows "fully_faithful_functor S.comp S.comp R"
	+ ..
	+
	+ definition runit ("\<r>[_]")
	+ where "runit f \<equiv> THE \<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> R \<mu> = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
	+
	+ lemma iso_unit:
	+ shows "S.iso \<iota>" and "\<guillemotleft>\<iota> : a \<star> a \<Rightarrow>\<^sub>S a\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<iota> : a \<star> a \<Rightarrow>\<^sub>S a\<guillemotright>"
	+ proof -
	+ have a: "weak_unit a \<and> S.ide a"
	+ using weak_unit_a S.ide_char S.arr_char right_def weak_unit_self_composable
	+ by metis
	+ moreover have "S.arr (a \<star> a)"
	+ using a S.ideD(1) R.preserves_arr H\<^sub>R_def by auto
	+ ultimately show ?thesis
	+ using a S.in_hom_char S.arr_char right_def \<iota>_in_hom
	+ by (metis S.ideD(1) hom_connected(3) in_homE)
	+ qed
	+ thus "S.iso \<iota>"
	+ using iso_\<iota> iso_char by blast
	+ qed
	+
	+ lemma characteristic_iso:
	+ assumes "S.ide f"
	+ shows "\<guillemotleft>\<a>[f, a, a] : (f \<star> a) \<star> a \<Rightarrow>\<^sub>S f \<star> a \<star> a\<guillemotright>"
	+ and "\<guillemotleft>f \<star> \<iota> : f \<star> a \<star> a \<Rightarrow>\<^sub>S f \<star> a\<guillemotright>"
	+ and "\<guillemotleft>(f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a] : R (R f) \<Rightarrow>\<^sub>S R f\<guillemotright>"
	+ and "S.iso ((f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a])"
	+ proof -
	+ have f: "S.ide f \<and> ide f"
	+ using assms S.ide_char by simp
	+ have a: "weak_unit a \<and> ide a \<and> S.ide a"
	+ using weak_unit_a S.ide_char weak_unit_def S.arr_char right_def
	+ weak_unit_self_composable
	+ by metis
	+ have fa: "f \<star> a \<noteq> null \<and> (f \<star> a) \<star> a \<noteq> null \<and> ((f \<star> a) \<star> a) \<star> a \<noteq> null"
	+ proof -
	+ have "S.arr (f \<star> a) \<and> S.arr ((f \<star> a) \<star> a) \<and> S.arr (((f \<star> a) \<star> a) \<star> a)"
	+ using assms S.ideD(1) R.preserves_arr H\<^sub>R_def by auto
	+ thus ?thesis
	+ using S.not_arr_null by fastforce
	+ qed
	+ have aa: "a \<star> a \<noteq> null"
	+ using a S.ideD(1) R.preserves_arr H\<^sub>R_def S.not_arr_null by auto
	+ have ia_a: "\<iota> \<star> a \<noteq> null"
	+ using weak_unit_a hom_connected(3) weak_unit_self_composable \<iota>_in_hom by blast
	+ have f_ia: "f \<star> \<iota> \<noteq> null"
	+ using assms S.ide_char right_def S.arr_char hom_connected(4) \<iota>_in_hom by auto
	+ show assoc_in_hom: "\<guillemotleft>\<a>[f, a, a] : (f \<star> a) \<star> a \<Rightarrow>\<^sub>S f \<star> a \<star> a\<guillemotright>"
	+ using a f fa hom_connected(1) [of "\<a>[f, a, a]" a] S.arr_char right_def
	+ match_3 match_4 S.in_hom_char
	+ by auto
	+ show 1: "\<guillemotleft>f \<star> \<iota> : f \<star> a \<star> a \<Rightarrow>\<^sub>S f \<star> a\<guillemotright>"
	+ using a f fa iso_unit
	+ by (simp add: f_ia ide_in_hom)
	+ moreover have "S.iso (f \<star> \<iota>)"
	+ using a f fa f_ia 1 VoV.arr_char VxV.inv_simp
	+ inv_in_hom hom_connected(2) [of f "inv \<iota>"] VoV.arr_char VoV.iso_char
	+ preserves_iso iso_char iso_\<iota>
	+ by auto
	+ ultimately have unit_part: "\<guillemotleft>f \<star> \<iota> : f \<star> a \<star> a \<Rightarrow>\<^sub>S f \<star> a\<guillemotright> \<and> S.iso (f \<star> \<iota>)"
	+ by blast
	+ show "S.iso ((f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a])"
	+ using assms a f fa aa hom_connected(1) [of "\<a>[f, a, a]" a] right_def
	+ iso_assoc\<^sub>A\<^sub>W\<^sub>C iso_char S.arr_char unit_part assoc_in_hom isos_compose
	+ using S.isos_compose S.seqI' by auto
	+ show "\<guillemotleft>(f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a] : R (R f) \<Rightarrow>\<^sub>S R f\<guillemotright>"
	+ unfolding H\<^sub>R_def using unit_part assoc_in_hom by blast
	+ qed
	+
	+ lemma runit_char:
	+ assumes "S.ide f"
	+ shows "\<guillemotleft>\<r>[f] : R f \<Rightarrow>\<^sub>S f\<guillemotright>" and "R \<r>[f] = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
	+ and "\<exists>!\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> R \<mu> = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
	+ proof -
	+ let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> R \<mu> = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]"
	+ show "\<exists>!\<mu>. ?P \<mu>"
	+ proof -
	+ have "\<exists>\<mu>. ?P \<mu>"
	+ proof -
	+ have 1: "S.ide f"
	+ using assms S.ide_char S.arr_char by simp
	+ moreover have "S.ide (R f)"
	+ using 1 R.preserves_ide by simp
	+ ultimately show ?thesis
	+ using assms characteristic_iso(3) R.is_full by blast
	+ qed
	+ moreover have "\<forall>\<mu> \<mu>'. ?P \<mu> \<and> ?P \<mu>' \<longrightarrow> \<mu> = \<mu>'"
	+ proof
	+ fix \<mu>
	+ show "\<forall>\<mu>'. ?P \<mu> \<and> ?P \<mu>' \<longrightarrow> \<mu> = \<mu>'"
	+ using R.is_faithful [of \<mu>] by fastforce
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ hence "?P (THE \<mu>. ?P \<mu>)"
	+ using theI' [of ?P] by fastforce
	+ hence 1: "?P \<r>[f]"
	+ unfolding runit_def by blast
	+ show "\<guillemotleft>\<r>[f] : R f \<Rightarrow>\<^sub>S f\<guillemotright>" using 1 by fast
	+ show "R \<r>[f] = (f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a]" using 1 by fast
	+ qed
	+
	+ lemma iso_runit:
	+ assumes "S.ide f"
	+ shows "S.iso \<r>[f]"
	+ using assms characteristic_iso(4) runit_char R.reflects_iso by metis
	+
	+ lemma runit_eqI:
	+ assumes "\<guillemotleft>f : a \<Rightarrow>\<^sub>S b\<guillemotright>" and "\<guillemotleft>\<mu> : R f \<Rightarrow>\<^sub>S f\<guillemotright>"
	+ and "R \<mu> = ((f \<star> \<iota>) \<cdot>\<^sub>S \<a>[f, a, a])"
	+ shows "\<mu> = \<r>[f]"
	+ proof -
	+ have "S.ide f" using assms(2) S.ide_cod by auto
	+ thus ?thesis using assms runit_char [of f] by auto
	+ qed
	+
	+ lemma runit_naturality:
	+ assumes "S.arr \<mu>"
	+ shows "\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu> = \<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>]"
	+ proof -
	+ have 1: "\<guillemotleft>\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu> : R (S.dom \<mu>) \<Rightarrow>\<^sub>S S.cod \<mu>\<guillemotright>"
	+ using assms runit_char(1) S.ide_cod by blast
	+ have 2: "S.par (\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu>) (\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>])"
	+ proof -
	+ have "\<guillemotleft>\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>] : R (S.dom \<mu>) \<Rightarrow>\<^sub>S S.cod \<mu>\<guillemotright>"
	+ using assms S.ide_dom runit_char(1) by blast
	+ thus ?thesis using 1 by (elim S.in_homE, auto)
	+ qed
	+ moreover have "R (\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu>) = R (\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>])"
	+ proof -
	+ have 3: "\<guillemotleft>\<mu> \<star> a \<star> a : S.dom \<mu> \<star> a \<star> a \<Rightarrow>\<^sub>S S.cod \<mu> \<star> a \<star> a\<guillemotright>"
	+ using assms weak_unit_a R.preserves_hom H\<^sub>R_def S.arr_iff_in_hom S.arr_char
	+ by (metis match_4 weak_unit_in_vhom weak_unit_self_right S.in_hom_char
	+ left_hcomp_closed S.not_arr_null S.null_char)
	+ have 4: "R (\<r>[S.cod \<mu>] \<cdot>\<^sub>S R \<mu>) = R \<r>[S.cod \<mu>] \<cdot>\<^sub>S R (R \<mu>)"
	+ using assms 1 R.preserves_comp_2 by blast
	+ also have 5: "... = ((S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S \<a>[S.cod \<mu>, a, a]) \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
	+ using assms R.preserves_arr runit_char S.ide_cod H\<^sub>R_def by auto
	+ also have 6: "... = (S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S \<a>[S.cod \<mu>, a, a] \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
	+ using assms S.comp_assoc by simp
	+ also have "... = (S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S (\<mu> \<star> a \<star> a) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
	+ proof -
	+ have "(\<mu> \<star> a \<star> a) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a] = \<a>[S.cod \<mu>, a, a] \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
	+ proof -
	+ have "(\<mu> \<star> a \<star> a) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a] = (\<mu> \<star> a \<star> a) \<cdot> \<a>[S.dom \<mu>, a, a]"
	+ using assms 3 S.ide_dom characteristic_iso(1) S.in_hom_char
	+ S.comp_char [of "\<mu> \<star> a \<star> a" "\<a>[S.dom \<mu>, a, a]"]
	+ by fastforce
	+ also have "... = \<a>[S.cod \<mu>, a, a] \<cdot> ((\<mu> \<star> a) \<star> a)"
	+ proof -
	+ have "\<mu> \<star> a \<noteq> null"
	+ using assms S.arr_char right_def by simp
	+ thus ?thesis
	+ using assms weak_unit_a assoc_naturality\<^sub>A\<^sub>W\<^sub>C [of \<mu> a a] by fastforce
	+ qed
	+ also have "... = \<a>[S.cod \<mu>, a, a] \<cdot>\<^sub>S ((\<mu> \<star> a) \<star> a)"
	+ using S.in_hom_char S.comp_char
	+ by (metis 2 4 5 6 R.preserves_arr S.seq_char)
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by argo
	+ qed
	+ also have "... = ((S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S (\<mu> \<star> a \<star> a)) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
	+ using S.comp_assoc by auto
	+ also have "... = ((\<mu> \<star> a) \<cdot>\<^sub>S (S.dom \<mu> \<star> \<iota>)) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
	+ proof -
	+ have "\<mu> \<star> a \<star> a \<noteq> null"
	+ using 3 S.not_arr_null by (elim S.in_homE, auto)
	+ moreover have "S.dom \<mu> \<star> \<iota> \<noteq> null"
	+ using assms S.not_arr_null
	+ by (metis S.dom_char \<iota>_in_hom calculation hom_connected(1-2) in_homE)
	+ ultimately have "(S.cod \<mu> \<star> \<iota>) \<cdot>\<^sub>S (\<mu> \<star> a \<star> a) = (\<mu> \<star> a) \<cdot>\<^sub>S (S.dom \<mu> \<star> \<iota>)"
	+ using assms weak_unit_a iso_unit S.comp_arr_dom S.comp_cod_arr
	+ interchange [of "S.cod \<mu>" \<mu> \<iota> "a \<star> a"] interchange [of \<mu> "S.dom \<mu>" a \<iota>]
	+ by auto
	+ thus ?thesis by argo
	+ qed
	+ also have "... = (\<mu> \<star> a) \<cdot>\<^sub>S (S.dom \<mu> \<star> \<iota>) \<cdot>\<^sub>S \<a>[S.dom \<mu>, a, a]"
	+ using S.comp_assoc by auto
	+ also have "... = R \<mu> \<cdot>\<^sub>S R \<r>[S.dom \<mu>]"
	+ using assms runit_char(2) S.ide_dom H\<^sub>R_def by auto
	+ also have "... = R (\<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>])"
	+ using assms S.arr_iff_in_hom [of \<mu>] runit_char(1) S.ide_dom by fastforce
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show "\<r>[S.cod \<mu>] \<cdot>\<^sub>S (R \<mu>) = \<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>]"
	+ using R.is_faithful by blast
	+ qed
	+
	+ abbreviation \<rr>
	+ where "\<rr> \<mu> \<equiv> if S.arr \<mu> then \<mu> \<cdot>\<^sub>S \<r>[S.dom \<mu>] else null"
	+
	+ interpretation \<rr>: natural_transformation S.comp S.comp R S.map \<rr>
	+ proof -
	+ interpret \<rr>: transformation_by_components S.comp S.comp R S.map runit
	+ using runit_char(1) runit_naturality by (unfold_locales, simp_all)
	+ have "\<rr>.map = \<rr>"
	+ using \<rr>.is_extensional \<rr>.map_def \<rr>.naturality \<rr>.map_simp_ide S.ide_dom S.ide_cod
	+ S.map_def
	+ by auto
	+ thus "natural_transformation S.comp S.comp R S.map \<rr>"
	+ using \<rr>.natural_transformation_axioms by auto
	+ qed
	+
	+ lemma natural_transformation_\<rr>:
	+ shows "natural_transformation S.comp S.comp R S.map \<rr>" ..
	+
	+ interpretation \<rr>: natural_isomorphism S.comp S.comp R S.map \<rr>
	+ using S.ide_is_iso iso_runit runit_char(1) S.isos_compose
	+ by (unfold_locales, force)
	+
	+ lemma natural_isomorphism_\<rr>:
	+ shows "natural_isomorphism S.comp S.comp R S.map \<rr>" ..
	+
	+ interpretation R: equivalence_functor S.comp S.comp R
	+ using natural_isomorphism_\<rr> R.isomorphic_to_identity_is_equivalence by blast
	+
	+ lemma equivalence_functor_R:
	+ shows "equivalence_functor S.comp S.comp R"
	+ ..
	+
	+ lemma runit_commutes_with_R:
	+ assumes "S.ide f"
	+ shows "\<r>[R f] = R \<r>[f]"
	+ proof -
	+ have "S.seq \<r>[f] (R \<r>[f])"
	+ using assms runit_char(1) R.preserves_hom [of "\<r>[f]" "R f" f] by fastforce
	+ moreover have "S.seq \<r>[f] \<r>[R f]"
	+ using assms runit_char(1) [of f] runit_char(1) [of "R f"] by auto
	+ ultimately show ?thesis
	+ using assms runit_char(1) runit_naturality [of "\<r>[f]"] iso_runit S.iso_is_section
	+ S.section_is_mono S.monoE [of "\<r>[f]" "R \<r>[f]" "\<r>[R f]"]
	+ by force
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ Symmetric results hold for the subcategory of all arrows composable on the left with
	+ a specified weak unit \<open>b\<close>. This yields the \emph{left unitors}.
	+ \<close>
	+
	+ locale left_hom_with_unit =
	+ associative_weak_composition V H \<a> +
	+ left_hom V H b
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a comp" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<iota> :: 'a
	+ and b :: 'a +
	+ assumes weak_unit_b: "weak_unit b"
	+ and \<iota>_in_hom: "\<guillemotleft>\<iota> : b \<star> b \<Rightarrow> b\<guillemotright>"
	+ and iso_\<iota>: "iso \<iota>"
	+ begin
	+
	+ abbreviation L
	+ where "L \<equiv> H\<^sub>L b"
	+
	+ interpretation L: endofunctor S.comp L
	+ using weak_unit_b weak_unit_self_composable endofunctor_H\<^sub>L by simp
	+ interpretation L: fully_faithful_functor S.comp S.comp L
	+ using weak_unit_b weak_unit_def by simp
	+
	+ lemma fully_faithful_functor_L:
	+ shows "fully_faithful_functor S.comp S.comp L"
	+ ..
	+
	+ definition lunit ("\<l>[_]")
	+ where "lunit f \<equiv> THE \<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> L \<mu> = (\<iota> \<star> f) \<cdot>\<^sub>S (inv \<a>[b, b, f])"
	+
	+ lemma iso_unit:
	+ shows "S.iso \<iota>" and "\<guillemotleft>\<iota> : b \<star> b \<Rightarrow>\<^sub>S b\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<iota> : b \<star> b \<Rightarrow>\<^sub>S b\<guillemotright>"
	+ proof -
	+ have b: "weak_unit b \<and> S.ide b"
	+ using weak_unit_b S.ide_char S.arr_char left_def weak_unit_self_composable
	+ by metis
	+ moreover have "S.arr (b \<star> b)"
	+ using b S.ideD(1) L.preserves_arr H\<^sub>L_def by auto
	+ ultimately show ?thesis
	+ using b S.in_hom_char S.arr_char left_def \<iota>_in_hom
	+ by (metis S.ideD(1) hom_connected(4) in_homE)
	+ qed
	+ thus "S.iso \<iota>"
	+ using iso_\<iota> iso_char by blast
	+ qed
	+
	+ lemma characteristic_iso:
	+ assumes "S.ide f"
	+ shows "\<guillemotleft>inv \<a>[b, b, f] : b \<star> b \<star> f \<Rightarrow>\<^sub>S (b \<star> b) \<star> f\<guillemotright>"
	+ and "\<guillemotleft>\<iota> \<star> f : (b \<star> b) \<star> f \<Rightarrow>\<^sub>S b \<star> f\<guillemotright>"
	+ and "\<guillemotleft>(\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f] : L (L f) \<Rightarrow>\<^sub>S L f\<guillemotright>"
	+ and "S.iso ((\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f])"
	+ proof -
	+ have f: "S.ide f \<and> ide f"
	+ using assms S.ide_char by simp
	+ have b: "weak_unit b \<and> ide b \<and> S.ide b"
	+ using weak_unit_b S.ide_char weak_unit_def S.arr_char left_def
	+ weak_unit_self_composable
	+ by metis
	+ have bf: "b \<star> f \<noteq> null \<and> b \<star> b \<star> b \<star> f \<noteq> null"
	+ proof -
	+ have "S.arr (b \<star> f) \<and> S.arr (b \<star> b \<star> f) \<and> S.arr (b \<star> b \<star> b \<star> f)"
	+ using assms S.ideD(1) L.preserves_arr H\<^sub>L_def by auto
	+ thus ?thesis
	+ using S.not_arr_null by fastforce
	+ qed
	+ have bb: "b \<star> b \<noteq> null"
	+ proof -
	+ have "S.arr (b \<star> b)"
	+ using b S.ideD(1) L.preserves_arr H\<^sub>L_def by auto
	+ thus ?thesis
	+ using S.not_arr_null by fastforce
	+ qed
	+ have b_ib: "b \<star> \<iota> \<noteq> null"
	+ using weak_unit_b hom_connected(4) weak_unit_self_composable \<iota>_in_hom by blast
	+ have ib_f: "\<iota> \<star> f \<noteq> null"
	+ using assms S.ide_char left_def S.arr_char hom_connected(3) \<iota>_in_hom
	+ by auto
	+ show assoc_in_hom: "\<guillemotleft>inv \<a>[b, b, f] : b \<star> b \<star> f \<Rightarrow>\<^sub>S (b \<star> b) \<star> f\<guillemotright>"
	+ using b f bf bb hom_connected(2) [of b "inv \<a>[b, b, f]"] left_def
	+ by (metis S.arrI S.cod_closed S.in_hom_char assoc'_in_hom\<^sub>A\<^sub>W\<^sub>C(3) assoc'_simps\<^sub>A\<^sub>W\<^sub>C(2-3))
	+ show 1: "\<guillemotleft>\<iota> \<star> f : (b \<star> b) \<star> f \<Rightarrow>\<^sub>S b \<star> f\<guillemotright>"
	+ using b f bf by (simp add: ib_f ide_in_hom iso_unit(2))
	+ moreover have "S.iso (\<iota> \<star> f)"
	+ using b f bf ib_f 1 VoV.arr_char VxV.inv_simp
	+ inv_in_hom hom_connected(1) [of "inv \<iota>" f] VoV.arr_char VoV.iso_char
	+ preserves_iso iso_char iso_\<iota>
	+ by auto
	+ ultimately have unit_part: "\<guillemotleft>\<iota> \<star> f : (b \<star> b) \<star> f \<Rightarrow>\<^sub>S b \<star> f\<guillemotright> \<and> S.iso (\<iota> \<star> f)"
	+ by blast
	+ show "S.iso ((\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f])"
	+ proof -
	+ have "S.iso (inv \<a>[b, b, f])"
	+ using assms b f bf bb hom_connected(2) [of b "inv \<a>[b, b, f]"] left_def
	+ iso_assoc\<^sub>A\<^sub>W\<^sub>C iso_inv_iso iso_char S.arr_char left_def
	+ by simp
	+ thus ?thesis
	+ using unit_part assoc_in_hom isos_compose by blast
	+ qed
	+ show "\<guillemotleft>(\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f] : L (L f) \<Rightarrow>\<^sub>S L f\<guillemotright>"
	+ unfolding H\<^sub>L_def using unit_part assoc_in_hom by blast
	+ qed
	+
	+ lemma lunit_char:
	+ assumes "S.ide f"
	+ shows "\<guillemotleft>\<l>[f] : L f \<Rightarrow>\<^sub>S f\<guillemotright>" and "L \<l>[f] = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]"
	+ and "\<exists>!\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> L \<mu> = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]"
	+ proof -
	+ let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright> \<and> L \<mu> = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]"
	+ show "\<exists>!\<mu>. ?P \<mu>"
	+ proof -
	+ have "\<exists>\<mu>. ?P \<mu>"
	+ proof -
	+ have 1: "S.ide f"
	+ using assms S.ide_char S.arr_char by simp
	+ moreover have "S.ide (L f)"
	+ using 1 L.preserves_ide by simp
	+ ultimately show ?thesis
	+ using assms characteristic_iso(3) L.is_full by blast
	+ qed
	+ moreover have "\<forall>\<mu> \<mu>'. ?P \<mu> \<and> ?P \<mu>' \<longrightarrow> \<mu> = \<mu>'"
	+ proof
	+ fix \<mu>
	+ show "\<forall>\<mu>'. ?P \<mu> \<and> ?P \<mu>' \<longrightarrow> \<mu> = \<mu>'"
	+ using L.is_faithful [of \<mu>] by fastforce
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ hence "?P (THE \<mu>. ?P \<mu>)"
	+ using theI' [of ?P] by fastforce
	+ hence 1: "?P \<l>[f]"
	+ unfolding lunit_def by blast
	+ show "\<guillemotleft>\<l>[f] : L f \<Rightarrow>\<^sub>S f\<guillemotright>" using 1 by fast
	+ show "L \<l>[f] = (\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f]" using 1 by fast
	+ qed
	+
	+ lemma iso_lunit:
	+ assumes "S.ide f"
	+ shows "S.iso \<l>[f]"
	+ using assms characteristic_iso(4) lunit_char L.reflects_iso by metis
	+
	+ lemma lunit_eqI:
	+ assumes "\<guillemotleft>f : a \<Rightarrow>\<^sub>S b\<guillemotright>" and "\<guillemotleft>\<mu> : L f \<Rightarrow>\<^sub>S f\<guillemotright>"
	+ and "L \<mu> = ((\<iota> \<star> f) \<cdot>\<^sub>S inv \<a>[b, b, f])"
	+ shows "\<mu> = \<l>[f]"
	+ proof -
	+ have "S.ide f" using assms(2) S.ide_cod by auto
	+ thus ?thesis using assms lunit_char [of f] by auto
	+ qed
	+
	+ lemma lunit_naturality:
	+ assumes "S.arr \<mu>"
	+ shows "\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu> = \<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>]"
	+ proof -
	+ have 1: "\<guillemotleft>\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu> : L (S.dom \<mu>) \<Rightarrow>\<^sub>S S.cod \<mu>\<guillemotright>"
	+ using assms lunit_char(1) [of "S.cod \<mu>"] S.ide_cod by blast
	+ have "S.par (\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu>) (\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>])"
	+ proof -
	+ have "\<guillemotleft>\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>] : L (S.dom \<mu>) \<Rightarrow>\<^sub>S S.cod \<mu>\<guillemotright>"
	+ using assms S.ide_dom lunit_char(1) by blast
	+ thus ?thesis using 1 by (elim S.in_homE, auto)
	+ qed
	+ moreover have "L (\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu>) = L (\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>])"
	+ proof -
	+ have 2: "\<guillemotleft>b \<star> b \<star> \<mu> : b \<star> b \<star> S.dom \<mu> \<Rightarrow>\<^sub>S b \<star> b \<star> S.cod \<mu>\<guillemotright>"
	+ using assms weak_unit_b L.preserves_hom H\<^sub>L_def S.arr_iff_in_hom [of \<mu>] S.arr_char
	+ by simp
	+ have 3: "\<guillemotleft>(b \<star> b) \<star> \<mu> : (b \<star> b) \<star> S.dom \<mu> \<Rightarrow>\<^sub>S (b \<star> b) \<star> S.cod \<mu>\<guillemotright>"
	+ using assms weak_unit_b L.preserves_hom H\<^sub>L_def S.arr_iff_in_hom S.arr_char
	+ by (metis match_3 weak_unit_in_vhom weak_unit_self_left S.in_hom_char
	+ S.not_arr_null S.null_char right_hcomp_closed)
	+
	+ have "L (\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu>) = L \<l>[S.cod \<mu>] \<cdot>\<^sub>S L (L \<mu>)"
	+ using assms 1 L.preserves_comp_2 by blast
	+ also have "... = ((\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.cod \<mu>]) \<cdot>\<^sub>S (b \<star> b \<star> \<mu>)"
	+ using assms L.preserves_arr lunit_char S.ide_cod H\<^sub>L_def by auto
	+ also have "... = (\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.cod \<mu>] \<cdot>\<^sub>S (b \<star> b \<star> \<mu>)"
	+ using S.comp_assoc by auto
	+ also have "... = (\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S ((b \<star> b) \<star> \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
	+ proof -
	+ have "inv \<a>[b, b, S.cod \<mu>] \<cdot>\<^sub>S (b \<star> b \<star> \<mu>) = ((b \<star> b) \<star> \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
	+ proof -
	+ have "((b \<star> b) \<star> \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>] = ((b \<star> b) \<star> \<mu>) \<cdot> inv \<a>[b, b, S.dom \<mu>]"
	+ using assms 3 S.in_hom_char S.comp_char [of "(b \<star> b) \<star> \<mu>" "inv \<a>[b, b, S.dom \<mu>]"]
	+ by (metis S.ide_dom characteristic_iso(1) ext)
	+ also have "... = inv \<a>[b, b, S.cod \<mu>] \<cdot> (b \<star> b \<star> \<mu>)"
	+ proof -
	+ have "b \<star> \<mu> \<noteq> null"
	+ using assms S.arr_char left_def by simp
	+ thus ?thesis
	+ using assms weak_unit_b assoc'_naturality\<^sub>A\<^sub>W\<^sub>C [of b b \<mu>] by fastforce
	+ qed
	+ also have "... = inv \<a>[b, b, S.cod \<mu>] \<cdot>\<^sub>S (b \<star> b \<star> \<mu>)"
	+ using assms 2 S.in_hom_char S.comp_char
	+ by (metis S.comp_simp S.ide_cod S.seqI' characteristic_iso(1))
	+ finally show ?thesis by argo
	+ qed
	+ thus ?thesis by argo
	+ qed
	+ also have "... = ((\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S ((b \<star> b) \<star> \<mu>)) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
	+ using S.comp_assoc by auto
	+ also have "... = ((b \<star> \<mu>) \<cdot>\<^sub>S (\<iota> \<star> S.dom \<mu>)) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
	+ proof -
	+ have "(b \<star> b) \<star> \<mu> \<noteq> null"
	+ using 3 S.not_arr_null by (elim S.in_homE, auto)
	+ moreover have "\<iota> \<star> S.dom \<mu> \<noteq> null"
	+ using assms S.not_arr_null
	+ by (metis S.dom_char \<iota>_in_hom calculation hom_connected(1-2) in_homE)
	+ ultimately have "(\<iota> \<star> S.cod \<mu>) \<cdot>\<^sub>S ((b \<star> b) \<star> \<mu>) = (b \<star> \<mu>) \<cdot>\<^sub>S (\<iota> \<star> S.dom \<mu>)"
	+ using assms weak_unit_b iso_unit S.comp_arr_dom S.comp_cod_arr
	+ interchange [of \<iota> "b \<star> b" "S.cod \<mu>" \<mu> ] interchange [of b \<iota> \<mu> "S.dom \<mu>"]
	+ by auto
	+ thus ?thesis by argo
	+ qed
	+ also have "... = (b \<star> \<mu>) \<cdot>\<^sub>S (\<iota> \<star> S.dom \<mu>) \<cdot>\<^sub>S inv \<a>[b, b, S.dom \<mu>]"
	+ using S.comp_assoc by auto
	+ also have "... = L \<mu> \<cdot>\<^sub>S L \<l>[S.dom \<mu>]"
	+ using assms lunit_char(2) S.ide_dom H\<^sub>L_def by auto
	+ also have "... = L (\<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>])"
	+ using assms S.arr_iff_in_hom [of \<mu>] lunit_char(1) S.ide_dom S.seqI
	+ by fastforce
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show "\<l>[S.cod \<mu>] \<cdot>\<^sub>S L \<mu> = \<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>]"
	+ using L.is_faithful by blast
	+ qed
	+
	+ abbreviation \<ll>
	+ where "\<ll> \<mu> \<equiv> if S.arr \<mu> then \<mu> \<cdot>\<^sub>S \<l>[S.dom \<mu>] else null"
	+
	+ interpretation \<ll>: natural_transformation S.comp S.comp L S.map \<ll>
	+ proof -
	+ interpret \<ll>: transformation_by_components S.comp S.comp L S.map lunit
	+ using lunit_char(1) lunit_naturality by (unfold_locales, simp_all)
	+ have "\<ll>.map = \<ll>"
	+ using \<ll>.is_extensional \<ll>.map_def \<ll>.naturality \<ll>.map_simp_ide S.ide_dom S.ide_cod
	+ S.map_def
	+ by auto
	+ thus "natural_transformation S.comp S.comp L S.map \<ll>"
	+ using \<ll>.natural_transformation_axioms by auto
	+ qed
	+
	+ lemma natural_transformation_\<ll>:
	+ shows "natural_transformation S.comp S.comp L S.map \<ll>" ..
	+
	+ interpretation \<ll>: natural_isomorphism S.comp S.comp L S.map \<ll>
	+ using S.ide_is_iso iso_lunit lunit_char(1) S.isos_compose
	+ by (unfold_locales, force)
	+
	+ lemma natural_isomorphism_\<ll>:
	+ shows "natural_isomorphism S.comp S.comp L S.map \<ll>" ..
	+
	+ interpretation L: equivalence_functor S.comp S.comp L
	+ using natural_isomorphism_\<ll> L.isomorphic_to_identity_is_equivalence by blast
	+
	+ lemma equivalence_functor_L:
	+ shows "equivalence_functor S.comp S.comp L"
	+ ..
	+
	+ lemma lunit_commutes_with_L:
	+ assumes "S.ide f"
	+ shows "\<l>[L f] = L \<l>[f]"
	+ proof -
	+ have "S.seq \<l>[f] (L \<l>[f])"
	+ using assms lunit_char(1) L.preserves_hom [of "\<l>[f]" "L f" f] by fastforce
	+ moreover have "S.seq \<l>[f] \<l>[L f]"
	+ using assms lunit_char(1) [of f] lunit_char(1) [of "L f"] by auto
	+ ultimately show ?thesis
	+ using assms lunit_char(1) lunit_naturality [of "\<l>[f]"] iso_lunit S.iso_is_section
	+ S.section_is_mono S.monoE [of "\<l>[f]" "L \<l>[f]" "\<l>[L f]"]
	+ by force
	+ qed
	+
	+ end
	+
	+ subsection "Prebicategories"
	+
	+ text \<open>
	+ A \emph{prebicategory} is an associative weak composition satisfying the additional assumption
	+ that every arrow has a source and a target.
	+ \<close>
	+
	+ locale prebicategory =
	+ associative_weak_composition +
	+ assumes arr_has_source: "arr \<mu> \<Longrightarrow> sources \<mu> \<noteq> {}"
	+ and arr_has_target: "arr \<mu> \<Longrightarrow> targets \<mu> \<noteq> {}"
	+ begin
	+
	+ lemma arr_iff_has_src:
	+ shows "arr \<mu> \<longleftrightarrow> sources \<mu> \<noteq> {}"
	+ using arr_has_source composable_implies_arr by auto
	+
	+ lemma arr_iff_has_trg:
	+ shows "arr \<mu> \<longleftrightarrow> targets \<mu> \<noteq> {}"
	+ using arr_has_target composable_implies_arr by auto
	+
	+ end
	+
	+ text \<open>
	+ The horizontal composition of a prebicategory is regular.
	+ \<close>
	+
	+ sublocale prebicategory \<subseteq> regular_weak_composition V H
	+ proof
	+ show "\<And>a f. a \<in> sources f \<Longrightarrow> ide f \<Longrightarrow> f \<star> a \<cong> f"
	+ proof -
	+ fix a f
	+ assume a: "a \<in> sources f" and f: "ide f"
	+ interpret Right_a: subcategory V \<open>right a\<close>
	+ using a right_hom_is_subcategory weak_unit_self_composable by force
	+ interpret Right_a: right_hom_with_unit V H \<a> \<open>some_unit a\<close> a
	+ using a iso_some_unit by (unfold_locales, auto)
	+ show "f \<star> a \<cong> f"
	+ proof -
	+ have "Right_a.ide f"
	+ using a f Right_a.ide_char Right_a.arr_char right_def by auto
	+ hence "Right_a.iso (Right_a.runit f) \<and> (Right_a.runit f) \<in> Right_a.hom (f \<star> a) f"
	+ using Right_a.iso_runit Right_a.runit_char(1) H\<^sub>R_def by simp
	+ hence "iso (Right_a.runit f) \<and> (Right_a.runit f) \<in> hom (f \<star> a) f"
	+ using Right_a.iso_char Right_a.hom_char by auto
	+ thus ?thesis using f isomorphic_def by auto
	+ qed
	+ qed
	+ show "\<And>b f. b \<in> targets f \<Longrightarrow> ide f \<Longrightarrow> b \<star> f \<cong> f"
	+ proof -
	+ fix b f
	+ assume b: "b \<in> targets f" and f: "ide f"
	+ interpret Left_b: subcategory V \<open>left b\<close>
	+ using b left_hom_is_subcategory weak_unit_self_composable by force
	+ interpret Left_b: left_hom_with_unit V H \<a> \<open>some_unit b\<close> b
	+ using b iso_some_unit by (unfold_locales, auto)
	+ show "b \<star> f \<cong> f"
	+ proof -
	+ have "Left_b.ide f"
	+ using b f Left_b.ide_char Left_b.arr_char left_def by auto
	+ hence "Left_b.iso (Left_b.lunit f) \<and> (Left_b.lunit f) \<in> Left_b.hom (b \<star> f) f"
	+ using b f Left_b.iso_lunit Left_b.lunit_char(1) H\<^sub>L_def by simp
	+ hence "iso (Left_b.lunit f) \<and> (Left_b.lunit f) \<in> hom (b \<star> f) f"
	+ using Left_b.iso_char Left_b.hom_char by auto
	+ thus ?thesis using isomorphic_def by auto
	+ qed
	+ qed
	+ qed
	+
	+ text \<open>
	+ The regularity allows us to show that, in a prebicategory, all sources of
	+ a given arrow are isomorphic, and similarly for targets.
	+ \<close>
	+
	+ context prebicategory
	+ begin
	+
	+ lemma sources_are_isomorphic:
	+ assumes "a \<in> sources \<mu>" and "a' \<in> sources \<mu>"
	+ shows "a \<cong> a'"
	+ proof -
	+ have \<mu>: "arr \<mu>" using assms composable_implies_arr by auto
	+ have 0: "\<And>f. \<lbrakk> ide f; a \<in> sources f; a' \<in> sources f \<rbrakk> \<Longrightarrow> a \<cong> a'"
	+ proof -
	+ fix f
	+ assume f: "ide f" and a: "a \<in> sources f" and a': "a' \<in> sources f"
	+ have 1: "a \<star> a' \<noteq> null"
	+ using a a' f \<mu> assms(1) sources_determine_composability sourcesD(2-3) by meson
	+ have 2: "a \<in> targets a' \<and> a' \<in> sources a"
	+ using assms 1 by blast
	+ show "a \<cong> a'"
	+ using a a' 1 2 comp_ide_source comp_target_ide [of a a']
	+ weak_unit_self_composable(1) [of a] weak_unit_self_composable(1) [of a']
	+ isomorphic_transitive isomorphic_symmetric
	+ by blast
	+ qed
	+ have "ide (dom \<mu>) \<and> a \<in> sources (dom \<mu>) \<and> a' \<in> sources (dom \<mu>)"
	+ using assms \<mu> sources_dom by auto
	+ thus ?thesis using 0 by auto
	+ qed
	+
	+ lemma targets_are_isomorphic:
	+ assumes "b \<in> targets \<mu>" and "b' \<in> targets \<mu>"
	+ shows "b \<cong> b'"
	+ proof -
	+ have \<mu>: "arr \<mu>" using assms composable_implies_arr by auto
	+ have 0: "\<And>f. \<lbrakk> ide f; b \<in> targets f; b' \<in> targets f \<rbrakk> \<Longrightarrow> b \<cong> b'"
	+ proof -
	+ fix f
	+ assume f: "ide f" and b: "b \<in> targets f" and b': "b' \<in> targets f"
	+ have 1: "b \<star> b' \<noteq> null"
	+ using b b' f \<mu> assms(1) targets_determine_composability targetsD(2-3) by meson
	+ have 2: "b \<in> targets b' \<and> b' \<in> sources b"
	+ using assms 1 by blast
	+ show "b \<cong> b'"
	+ using b b' 1 2 comp_ide_source comp_target_ide [of b b']
	+ weak_unit_self_composable(1) [of b] weak_unit_self_composable(1) [of b']
	+ isomorphic_transitive isomorphic_symmetric
	+ by blast
	+ qed
	+ have "ide (dom \<mu>) \<and> b \<in> targets (dom \<mu>) \<and> b' \<in> targets (dom \<mu>)"
	+ using assms \<mu> targets_dom [of \<mu>] by auto
	+ thus ?thesis using 0 by auto
	+ qed
	+
	+ text \<open>
	+ In fact, we now show that the sets of sources and targets of a 2-cell are
	+ isomorphism-closed, and hence are isomorphism classes.
	+ We first show that the notion ``weak unit'' is preserved under isomorphism.
	+ \<close>
	+
	+ interpretation H: partial_magma H
	+ using is_partial_magma by auto
	+
	+ lemma isomorphism_respects_weak_units:
	+ assumes "weak_unit a" and "a \<cong> a'"
	+ shows "weak_unit a'"
	+ proof -
	+ obtain \<phi> where \<phi>: "iso \<phi> \<and> \<guillemotleft>\<phi> : a \<Rightarrow> a'\<guillemotright>"
	+ using assms by auto
	+ interpret Left_a: subcategory V \<open>left a\<close>
	+ using assms left_hom_is_subcategory by fastforce
	+ interpret Left_a: left_hom_with_unit V H \<a> \<open>some_unit a\<close> a
	+ using assms iso_some_unit
	+ apply unfold_locales by auto
	+ interpret Right_a: subcategory V "right a"
	+ using assms right_hom_is_subcategory by fastforce
	+ interpret Right_a: right_hom_with_unit V H \<a> \<open>some_unit a\<close> a
	+ using assms iso_some_unit
	+ apply unfold_locales by auto
	+ have a': "ide a' \<and> a \<star> a' \<noteq> null \<and> a' \<star> a \<noteq> null \<and> a' \<star> a' \<noteq> null \<and>
	+ \<phi> \<star> a' \<noteq> null \<and> Left_a.ide a'"
	+ using assms \<phi> weak_unit_self_composable hom_connected
	+ Left_a.ide_char Left_a.arr_char left_def
	+ apply auto
	+ apply (meson weak_unit_self_composable(3) isomorphic_implies_equicomposable)
	+ apply (meson weak_unit_self_composable(3) isomorphic_implies_equicomposable)
	+ apply (meson weak_unit_self_composable(3) isomorphic_implies_equicomposable)
	+ apply (metis weak_unit_self_composable(3) in_homE)
	+ by (meson weak_unit_self_composable(3) isomorphic_implies_equicomposable)
	+ have iso: "a' \<star> a' \<cong> a'"
	+ proof -
	+ have 1: "Right a' = Right a"
	+ using assms right_respects_isomorphic by simp
	+ interpret Right_a': subcategory V \<open>right a'\<close>
	+ using assms right_hom_is_subcategory by fastforce
	+ (* TODO: The previous interpretation brings in unwanted notation for in_hom. *)
	+ interpret Ra': endofunctor \<open>Right a'\<close> \<open>H\<^sub>R a'\<close>
	+ using assms a' endofunctor_H\<^sub>R by auto
	+ let ?\<psi> = "Left_a.lunit a' \<cdot> inv (\<phi> \<star> a')"
	+ have "iso ?\<psi> \<and> \<guillemotleft>?\<psi> : a' \<star> a' \<Rightarrow> a'\<guillemotright>"
	+ proof -
	+ have "iso (Left_a.lunit a') \<and> \<guillemotleft>Left_a.lunit a' : a \<star> a' \<Rightarrow> a'\<guillemotright>"
	+ using a' Left_a.lunit_char(1) Left_a.iso_lunit Left_a.iso_char
	+ Left_a.in_hom_char H\<^sub>L_def
	+ by auto
	+ moreover have "iso (\<phi> \<star> a') \<and> \<guillemotleft>\<phi> \<star> a' : a \<star> a' \<Rightarrow> a' \<star> a'\<guillemotright>"
	+ proof -
	+ have 1: "Right_a'.iso \<phi> \<and> \<phi> \<in> Right_a'.hom (Right_a'.dom \<phi>) (Right_a'.cod \<phi>)"
	+ using a' \<phi> Right_a'.iso_char Right_a'.arr_char right_def right_iff_right_inv
	+ Right_a'.arr_iff_in_hom [of \<phi>]
	+ by simp
	+ have "Right_a'.iso (H\<^sub>R a' \<phi>) \<and>
	+ Right_a'.in_hom (H\<^sub>R a' \<phi>) (H\<^sub>R a' (Right_a'.dom \<phi>)) (H\<^sub>R a' (Right_a'.cod \<phi>))"
	+ using \<phi> 1 Ra'.preserves_iso Ra'.preserves_hom Right_a'.iso_char
	+ Ra'.preserves_dom Ra'.preserves_cod Right_a'.arr_iff_in_hom [of "H\<^sub>R a' \<phi>"]
	+ by simp
	+ thus ?thesis
	+ using \<phi> 1 Right_a'.in_hom_char Right_a'.iso_char H\<^sub>R_def by auto
	+ qed
	+ ultimately show ?thesis
	+ using isos_compose iso_inv_iso inv_in_hom by blast
	+ qed
	+ thus ?thesis using isomorphic_def by auto
	+ qed
	+ text \<open>
	+ We show that horizontal composition on the left and right by @{term a'}
	+ is naturally isomorphic to the identity functor. This follows from the fact
	+ that if @{term a} is isomorphic to @{term a'}, then horizontal composition with @{term a}
	+ is naturally isomorphic to horizontal composition with @{term a'}, hence the latter is
	+ naturally isomorphic to the identity if the former is.
	+ This is conceptually simple, but there are tedious composability details to handle.
	+ \<close>
	+ have 1: "Left a' = Left a \<and> Right a' = Right a"
	+ using assms left_respects_isomorphic right_respects_isomorphic by simp
	+ interpret L: fully_faithful_functor \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close>
	+ using assms weak_unit_def by simp
	+ interpret L': endofunctor \<open>Left a\<close> \<open>H\<^sub>L a'\<close>
	+ using a' 1 endofunctor_H\<^sub>L [of a'] by auto
	+ interpret \<Phi>: natural_isomorphism \<open>Left a\<close> \<open>Left a\<close> \<open>H\<^sub>L a\<close> \<open>H\<^sub>L a'\<close> \<open>H\<^sub>L \<phi>\<close>
	+ proof
	+ fix \<mu>
	+ show "\<not> Left_a.arr \<mu> \<Longrightarrow> H\<^sub>L \<phi> \<mu> = Left_a.null"
	+ using left_def \<phi> H\<^sub>L_def hom_connected(1) Left_a.null_char null_agreement
	+ Left_a.arr_char
	+ by auto
	+ assume "Left_a.arr \<mu>"
	+ hence \<mu>: "Left_a.arr \<mu> \<and> arr \<mu> \<and> a \<star> \<mu> \<noteq> null"
	+ using Left_a.arr_char left_def composable_implies_arr by simp
	+ have 2: "\<phi> \<star> \<mu> \<noteq> null"
	+ using assms \<phi> \<mu> Left_a.arr_char left_def hom_connected by auto
	+ show "Left_a.dom (H\<^sub>L \<phi> \<mu>) = H\<^sub>L a (Left_a.dom \<mu>)"
	+ using assms 2 \<phi> \<mu> Left_a.arr_char left_def hom_connected(2) [of a \<phi>]
	+ weak_unit_self_composable match_4 Left_a.dom_char H\<^sub>L_def by auto
	+ show "Left_a.cod (H\<^sub>L \<phi> \<mu>) = H\<^sub>L a' (Left_a.cod \<mu>)"
	+ using assms 2 \<phi> \<mu> Left_a.arr_char left_def hom_connected(2) [of a \<phi>]
	+ weak_unit_self_composable match_4 Left_a.cod_char H\<^sub>L_def
	+ by auto
	+ show "Left_a.comp (H\<^sub>L a' \<mu>) (H\<^sub>L \<phi> (Left_a.dom \<mu>)) = H\<^sub>L \<phi> \<mu>"
	+ proof -
	+ have "Left_a.comp (H\<^sub>L a' \<mu>) (H\<^sub>L \<phi> (Left_a.dom \<mu>)) =
	+ Left_a.comp (a' \<star> \<mu>) (\<phi> \<star> dom \<mu>)"
	+ using assms 1 2 \<phi> \<mu> Left_a.dom_char left_def H\<^sub>L_def by simp
	+ also have "... = (a' \<star> \<mu>) \<cdot> (\<phi> \<star> dom \<mu>)"
	+ proof -
	+ have "Left_a.seq (a' \<star> \<mu>) (\<phi> \<star> dom \<mu>)"
	+ proof (intro Left_a.seqI)
	+ show 3: "Left_a.arr (\<phi> \<star> dom \<mu>)"
	+ using assms 2 \<phi> \<mu> Left_a.arr_char left_def
	+ by (metis H\<^sub>L_def L'.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1) in_homE right_connected
	+ paste_1)
	+ show 4: "Left_a.arr (a' \<star> \<mu>)"
	+ using \<mu> H\<^sub>L_def L'.preserves_arr by auto
	+ show "Left_a.dom (a' \<star> \<mu>) = Left_a.cod (\<phi> \<star> dom \<mu>)"
	+ using a' \<phi> \<mu> 2 3 4 Left_a.dom_char Left_a.cod_char
	+ by (metis Left_a.seqE Left_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_1)
	+ qed
	+ thus ?thesis using Left_a.comp_char Left_a.arr_char left_def by auto
	+ qed
	+ also have "... = a' \<cdot> \<phi> \<star> \<mu> \<cdot> dom \<mu>"
	+ using a' \<phi> \<mu> interchange hom_connected by auto
	+ also have "... = \<phi> \<star> \<mu>"
	+ using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
	+ finally show ?thesis using H\<^sub>L_def by simp
	+ qed
	+ show "Left_a.comp (H\<^sub>L \<phi> (Left_a.cod \<mu>)) (Left_a.L \<mu>) = H\<^sub>L \<phi> \<mu>"
	+ proof -
	+ have "Left_a.comp (H\<^sub>L \<phi> (Left_a.cod \<mu>)) (Left_a.L \<mu>) = Left_a.comp (\<phi> \<star> cod \<mu>) (a \<star> \<mu>)"
	+ using assms 1 2 \<phi> \<mu> Left_a.cod_char left_def H\<^sub>L_def by simp
	+ also have "... = (\<phi> \<star> cod \<mu>) \<cdot> (a \<star> \<mu>)"
	+ proof -
	+ have "Left_a.seq (\<phi> \<star> cod \<mu>) (a \<star> \<mu>)"
	+ proof (intro Left_a.seqI)
	+ show 3: "Left_a.arr (\<phi> \<star> cod \<mu>)"
	+ using \<phi> \<mu> 2 Left_a.arr_char left_def
	+ by (metis (no_types, lifting) H\<^sub>L_def L.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1)
	+ in_homE right_connected paste_2)
	+ show 4: "Left_a.arr (a \<star> \<mu>)"
	+ using assms \<mu> Left_a.arr_char left_def
	+ using H\<^sub>L_def L.preserves_arr by auto
	+ show "Left_a.dom (\<phi> \<star> cod \<mu>) = Left_a.cod (a \<star> \<mu>)"
	+ using assms \<phi> \<mu> 2 3 4 Left_a.dom_char Left_a.cod_char
	+ by (metis Left_a.seqE Left_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_2)
	+ qed
	+ thus ?thesis using Left_a.comp_char Left_a.arr_char left_def by auto
	+ qed
	+ also have "... = \<phi> \<cdot> a \<star> cod \<mu> \<cdot> \<mu>"
	+ using \<phi> \<mu> interchange hom_connected by auto
	+ also have "... = \<phi> \<star> \<mu>"
	+ using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
	+ finally show ?thesis using H\<^sub>L_def by simp
	+ qed
	+ next
	+ fix \<mu>
	+ assume \<mu>: "Left_a.ide \<mu>"
	+ have 1: "\<phi> \<star> \<mu> \<noteq> null"
	+ using assms \<phi> \<mu> Left_a.ide_char Left_a.arr_char left_def hom_connected by auto
	+ show "Left_a.iso (H\<^sub>L \<phi> \<mu>)"
	+ proof -
	+ have "iso (\<phi> \<star> \<mu>)"
	+ proof -
	+ have "a \<in> sources \<phi> \<inter> targets \<mu>"
	+ using assms \<phi> \<mu> 1 hom_connected weak_unit_self_composable
	+ Left_a.ide_char Left_a.arr_char left_def connected_if_composable
	+ by auto
	+ thus ?thesis
	+ using \<phi> \<mu> Left_a.ide_char ide_is_iso iso_hcomp\<^sub>R\<^sub>W\<^sub>C(1) by blast
	+ qed
	+ moreover have "left a (\<phi> \<star> \<mu>)"
	+ using assms 1 \<phi> weak_unit_self_composable hom_connected(2) [of a \<phi>]
	+ left_def match_4 null_agreement
	+ by auto
	+ ultimately show ?thesis
	+ using Left_a.iso_char Left_a.arr_char left_iff_left_inv Left_a.inv_char H\<^sub>L_def
	+ by simp
	+ qed
	+ qed
	+ interpret L': equivalence_functor \<open>Left a'\<close> \<open>Left a'\<close> \<open>H\<^sub>L a'\<close>
	+ proof -
	+ have "naturally_isomorphic (Left a) (Left a) (H\<^sub>L a) Left_a.map"
	+ using assms Left_a.natural_isomorphism_\<ll> naturally_isomorphic_def by blast
	+ moreover have "naturally_isomorphic (Left a) (Left a) (H\<^sub>L a) (H\<^sub>L a')"
	+ using naturally_isomorphic_def \<Phi>.natural_isomorphism_axioms by blast
	+ ultimately have "naturally_isomorphic (Left a) (Left a) (H\<^sub>L a')
	+ (identity_functor.map (Left a))"
	+ using naturally_isomorphic_symmetric naturally_isomorphic_transitive by fast
	+ hence "naturally_isomorphic (Left a') (Left a') (H\<^sub>L a') (identity_functor.map (Left a'))"
	+ using 1 by auto
	+ thus "equivalence_functor (Left a') (Left a') (H\<^sub>L a')"
	+ using 1 L'.isomorphic_to_identity_is_equivalence naturally_isomorphic_def by fastforce
	+ qed
	+
	+ text \<open>
	+ Now we do the same for \<open>R'\<close>.
	+ \<close>
	+ interpret R: fully_faithful_functor \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close>
	+ using assms weak_unit_def by simp
	+ interpret R': endofunctor \<open>Right a\<close> \<open>H\<^sub>R a'\<close>
	+ using a' 1 endofunctor_H\<^sub>R [of a'] by auto
	+ interpret \<Psi>: natural_isomorphism \<open>Right a\<close> \<open>Right a\<close> \<open>H\<^sub>R a\<close> \<open>H\<^sub>R a'\<close> \<open>H\<^sub>R \<phi>\<close>
	+ proof
	+ fix \<mu>
	+ show "\<not> Right_a.arr \<mu> \<Longrightarrow> H\<^sub>R \<phi> \<mu> = Right_a.null"
	+ using right_def \<phi> H\<^sub>R_def hom_connected Right_a.null_char Right_a.arr_char
	+ by auto
	+ assume "Right_a.arr \<mu>"
	+ hence \<mu>: "Right_a.arr \<mu> \<and> arr \<mu> \<and> \<mu> \<star> a \<noteq> null"
	+ using Right_a.arr_char right_def composable_implies_arr by simp
	+ have 2: "\<mu> \<star> \<phi> \<noteq> null"
	+ using assms \<phi> \<mu> Right_a.arr_char right_def hom_connected by auto
	+ show "Right_a.dom (H\<^sub>R \<phi> \<mu>) = H\<^sub>R a (Right_a.dom \<mu>)"
	+ using assms 2 \<phi> \<mu> Right_a.arr_char right_def hom_connected(1) [of \<phi> a]
	+ weak_unit_self_composable match_3 Right_a.dom_char H\<^sub>R_def
	+ by auto
	+ show "Right_a.cod (H\<^sub>R \<phi> \<mu>) = H\<^sub>R a' (Right_a.cod \<mu>)"
	+ using assms 2 a' \<phi> \<mu> Right_a.arr_char right_def hom_connected(3) [of \<phi> a]
	+ weak_unit_self_composable match_3 Right_a.cod_char H\<^sub>R_def
	+ by auto
	+ show "Right_a.comp (H\<^sub>R a' \<mu>) (H\<^sub>R \<phi> (Right_a.dom \<mu>)) = H\<^sub>R \<phi> \<mu>"
	+ proof -
	+ have "Right_a.comp (H\<^sub>R a' \<mu>) (H\<^sub>R \<phi> (Right_a.dom \<mu>)) =
	+ Right_a.comp (\<mu> \<star> a') (dom \<mu> \<star> \<phi>)"
	+ using assms 1 2 \<phi> \<mu> Right_a.dom_char right_def H\<^sub>R_def by simp
	+ also have "... = (\<mu> \<star> a') \<cdot> (dom \<mu> \<star> \<phi>)"
	+ proof -
	+ have "Right_a.seq (\<mu> \<star> a') (dom \<mu> \<star> \<phi>)"
	+ proof (intro Right_a.seqI)
	+ show 3: "Right_a.arr (dom \<mu> \<star> \<phi>)"
	+ using assms 2 \<phi> \<mu> Right_a.arr_char right_def
	+ by (metis H\<^sub>R_def R'.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1) in_homE left_connected
	+ paste_2)
	+ show 4: "Right_a.arr (\<mu> \<star> a')"
	+ using \<mu> H\<^sub>R_def R'.preserves_arr by auto
	+ show "Right_a.dom (\<mu> \<star> a') = Right_a.cod (dom \<mu> \<star> \<phi>)"
	+ using a' \<phi> \<mu> 2 3 4 Right_a.dom_char Right_a.cod_char
	+ by (metis Right_a.seqE Right_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_2)
	+ qed
	+ thus ?thesis using Right_a.comp_char Right_a.arr_char right_def by auto
	+ qed
	+ also have "... = \<mu> \<cdot> dom \<mu> \<star> a' \<cdot> \<phi>"
	+ using a' \<phi> \<mu> interchange hom_connected by auto
	+ also have "... = \<mu> \<star> \<phi>"
	+ using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
	+ finally show ?thesis using H\<^sub>R_def by simp
	+ qed
	+ show "Right_a.comp (H\<^sub>R \<phi> (Right_a.cod \<mu>)) (Right_a.R \<mu>) = H\<^sub>R \<phi> \<mu>"
	+ proof -
	+ have "Right_a.comp (H\<^sub>R \<phi> (Right_a.cod \<mu>)) (Right_a.R \<mu>)
	+ = Right_a.comp (cod \<mu> \<star> \<phi>) (\<mu> \<star> a)"
	+ using assms 1 2 \<phi> \<mu> Right_a.cod_char right_def H\<^sub>R_def by simp
	+ also have "... = (cod \<mu> \<star> \<phi>) \<cdot> (\<mu> \<star> a)"
	+ proof -
	+ have "Right_a.seq (cod \<mu> \<star> \<phi>) (\<mu> \<star> a)"
	+ proof (intro Right_a.seqI)
	+ show 3: "Right_a.arr (cod \<mu> \<star> \<phi>)"
	+ using \<phi> \<mu> 2 Right_a.arr_char right_def
	+ by (metis (no_types, lifting) H\<^sub>R_def R.preserves_arr hcomp_simps\<^sub>W\<^sub>C(1)
	+ in_homE left_connected paste_1)
	+ show 4: "Right_a.arr (\<mu> \<star> a)"
	+ using assms \<mu> Right_a.arr_char right_def
	+ using H\<^sub>R_def R.preserves_arr by auto
	+ show "Right_a.dom (cod \<mu> \<star> \<phi>) = Right_a.cod (\<mu> \<star> a)"
	+ using assms \<phi> \<mu> 2 3 4 Right_a.dom_char Right_a.cod_char
	+ by (metis Right_a.seqE Right_a.seq_char hcomp_simps\<^sub>W\<^sub>C(1) in_homE paste_1)
	+ qed
	+ thus ?thesis using Right_a.comp_char Right_a.arr_char right_def by auto
	+ qed
	+ also have "... = cod \<mu> \<cdot> \<mu> \<star> \<phi> \<cdot> a"
	+ using \<phi> \<mu> interchange hom_connected by auto
	+ also have "... = \<mu> \<star> \<phi>"
	+ using \<phi> \<mu> comp_arr_dom comp_cod_arr by auto
	+ finally show ?thesis using H\<^sub>R_def by simp
	+ qed
	+ next
	+ fix \<mu>
	+ assume \<mu>: "Right_a.ide \<mu>"
	+ have 1: "\<mu> \<star> \<phi> \<noteq> null"
	+ using assms \<phi> \<mu> Right_a.ide_char Right_a.arr_char right_def hom_connected by auto
	+ show "Right_a.iso (H\<^sub>R \<phi> \<mu>)"
	+ proof -
	+ have "iso (\<mu> \<star> \<phi>)"
	+ proof -
	+ have "a \<in> targets \<phi> \<inter> sources \<mu>"
	+ using assms \<phi> \<mu> 1 hom_connected weak_unit_self_composable
	+ Right_a.ide_char Right_a.arr_char right_def connected_if_composable
	+ by (metis (full_types) IntI targetsI)
	+ thus ?thesis
	+ using \<phi> \<mu> Right_a.ide_char ide_is_iso iso_hcomp\<^sub>R\<^sub>W\<^sub>C(1) by blast
	+ qed
	+ moreover have "right a (\<mu> \<star> \<phi>)"
	+ using assms 1 \<phi> weak_unit_self_composable hom_connected(1) [of \<phi> a]
	+ right_def match_3 null_agreement
	+ by auto
	+ ultimately show ?thesis
	+ using Right_a.iso_char Right_a.arr_char right_iff_right_inv
	+ Right_a.inv_char H\<^sub>R_def
	+ by simp
	+ qed
	+ qed
	+ interpret R': equivalence_functor \<open>Right a'\<close> \<open>Right a'\<close> \<open>H\<^sub>R a'\<close>
	+ proof -
	+ have "naturally_isomorphic (Right a) (Right a) (H\<^sub>R a) Right_a.map"
	+ using assms Right_a.natural_isomorphism_\<rr> naturally_isomorphic_def by blast
	+ moreover have "naturally_isomorphic (Right a) (Right a) (H\<^sub>R a) (H\<^sub>R a')"
	+ using naturally_isomorphic_def \<Psi>.natural_isomorphism_axioms by blast
	+ ultimately have "naturally_isomorphic (Right a) (Right a) (H\<^sub>R a') Right_a.map"
	+ using naturally_isomorphic_symmetric naturally_isomorphic_transitive by fast
	+ hence "naturally_isomorphic (Right a') (Right a') (H\<^sub>R a')
	+ (identity_functor.map (Right a'))"
	+ using 1 by auto
	+ thus "equivalence_functor (Right a') (Right a') (H\<^sub>R a')"
	+ using 1 R'.isomorphic_to_identity_is_equivalence naturally_isomorphic_def
	+ by fastforce
	+ qed
	+
	+ show "weak_unit a'"
	+ using weak_unit_def iso L'.fully_faithful_functor_axioms R'.fully_faithful_functor_axioms
	+ by blast
	+ qed
	+
	+ lemma sources_iso_closed:
	+ assumes "a \<in> sources \<mu>" and "a \<cong> a'"
	+ shows "a' \<in> sources \<mu>"
	+ using assms isomorphism_respects_weak_units isomorphic_implies_equicomposable
	+ by blast
	+
	+ lemma targets_iso_closed:
	+ assumes "a \<in> targets \<mu>" and "a \<cong> a'"
	+ shows "a' \<in> targets \<mu>"
	+ using assms isomorphism_respects_weak_units isomorphic_implies_equicomposable
	+ by blast
	+
	+ lemma sources_eqI:
	+ assumes "sources \<mu> \<inter> sources \<nu> \<noteq> {}"
	+ shows "sources \<mu> = sources \<nu>"
	+ using assms sources_iso_closed sources_are_isomorphic by blast
	+
	+ lemma targets_eqI:
	+ assumes "targets \<mu> \<inter> targets \<nu> \<noteq> {}"
	+ shows "targets \<mu> = targets \<nu>"
	+ using assms targets_iso_closed targets_are_isomorphic by blast
	+
	+ text \<open>
	+ The sets of sources and targets of a weak unit are isomorphism classes.
	+ \<close>
	+
	+ lemma sources_char:
	+ assumes "weak_unit a"
	+ shows "sources a = {x. x \<cong> a}"
	+ using assms sources_iso_closed weak_unit_iff_self_source sources_are_isomorphic
	+ isomorphic_symmetric
	+ by blast
	+
	+ lemma targets_char:
	+ assumes "weak_unit a"
	+ shows "targets a = {x. x \<cong> a}"
	+ using assms targets_iso_closed weak_unit_iff_self_target targets_are_isomorphic
	+ isomorphic_symmetric
	+ by blast
	+
	+ end
	+
	+ section "Horizontal Homs"
	+
	+ text \<open>
	+ Here we define a locale that axiomatizes a (vertical) category \<open>V\<close> that has been
	+ punctuated into ``horizontal homs'' by the choice of idempotent endofunctors \<open>src\<close> and \<open>trg\<close>
	+ that assign a specific ``source'' and ``target'' 1-cell to each of its arrows.
	+ The functors \<open>src\<close> and \<open>trg\<close> are also subject to further conditions that constrain how
	+ they commute with each other.
	+ \<close>
	+
	+ locale horizontal_homs =
	+ category V +
	+ src: endofunctor V src +
	+ trg: endofunctor V trg
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a" +
	+ assumes ide_src [simp]: "arr \<mu> \<Longrightarrow> ide (src \<mu>)"
	+ and ide_trg [simp]: "arr \<mu> \<Longrightarrow> ide (trg \<mu>)"
	+ and src_src [simp]: "arr \<mu> \<Longrightarrow> src (src \<mu>) = src \<mu>"
	+ and trg_trg [simp]: "arr \<mu> \<Longrightarrow> trg (trg \<mu>) = trg \<mu>"
	+ and trg_src [simp]: "arr \<mu> \<Longrightarrow> trg (src \<mu>) = src \<mu>"
	+ and src_trg [simp]: "arr \<mu> \<Longrightarrow> src (trg \<mu>) = trg \<mu>"
	+ begin
	+
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+ notation in_hom ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
	+
	+ text \<open>
	+ We define an \emph{object} to be an arrow that is its own source
	+ (or equivalently, its own target).
	+ \<close>
	+
	+ definition obj
	+ where "obj a \<equiv> arr a \<and> src a = a"
	+
	+ lemma obj_def':
	+ shows "obj a \<longleftrightarrow> arr a \<and> trg a = a"
	+ using trg_src src_trg obj_def by metis
	+
	+ lemma objE [elim]:
	+ assumes "obj a" and "\<lbrakk> ide a; src a = a; trg a = a \<rbrakk> \<Longrightarrow> T"
	+ shows T
	+ proof -
	+ have "ide a" using assms obj_def ide_src by metis
	+ moreover have "src a = a" using assms obj_def by simp
	+ moreover have "trg a = a" using assms obj_def' by simp
	+ ultimately show ?thesis using assms by simp
	+ qed
	+
	+ (* TODO: Can't add "arr a" or "ide a" due to looping. *)
	+ lemma obj_simps [simp]:
	+ assumes "obj a"
	+ shows "src a = a" and "trg a = a"
	+ using assms by auto
	+
	+ lemma obj_src [intro, simp]:
	+ assumes "arr \<mu>"
	+ shows "obj (src \<mu>)"
	+ using assms obj_def by auto
	+
	+ lemma obj_trg [intro, simp]:
	+ assumes "arr \<mu>"
	+ shows "obj (trg \<mu>)"
	+ using assms obj_def by auto
	+
	+ definition in_hhom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+ where "in_hhom \<mu> a b \<equiv> arr \<mu> \<and> src \<mu> = a \<and> trg \<mu> = b"
	+
	+ abbreviation hhom
	+ where "hhom a b \<equiv> {\<mu>. \<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>}"
	+
	+ abbreviation (input) hseq\<^sub>H\<^sub>H
	+ where "hseq\<^sub>H\<^sub>H \<equiv> \<lambda>\<mu> \<nu>. arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>"
	+
	+ lemma in_hhomI [intro, simp]:
	+ assumes "arr \<mu>" and "src \<mu> = a" and "trg \<mu> = b"
	+ shows "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>"
	+ using assms in_hhom_def by auto
	+
	+ lemma in_hhomE [elim]:
	+ assumes "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>"
	+ and "\<lbrakk> arr \<mu>; obj a; obj b; src \<mu> = a; trg \<mu> = b \<rbrakk> \<Longrightarrow> T"
	+ shows "T"
	+ using assms in_hhom_def by auto
	+
	+ (*
	+ * TODO: I tried removing the second assertion here, thinking that it should already
	+ * be covered by the category locale, but in fact it breaks some proofs in
	+ * SpanBicategory that ought to be trivial. So it seems that the presence of
	+ * this introduction rule adds something, and I should consider whether this rule
	+ * should be added to the category locale.
	+ *)
	+ lemma ide_in_hom [intro]:
	+ assumes "ide f"
	+ shows "\<guillemotleft>f : src f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>f : f \<Rightarrow> f\<guillemotright>"
	+ using assms by auto
	+
	+ lemma src_dom [simp]:
	+ assumes "arr \<mu>"
	+ shows "src (dom \<mu>) = src \<mu>"
	+ using assms src.preserves_dom [of \<mu>] by simp
	+
	+ lemma src_cod [simp]:
	+ assumes "arr \<mu>"
	+ shows "src (cod \<mu>) = src \<mu>"
	+ using assms src.preserves_cod [of \<mu>] by simp
	+
	+ lemma trg_dom [simp]:
	+ assumes "arr \<mu>"
	+ shows "trg (dom \<mu>) = trg \<mu>"
	+ using assms trg.preserves_dom [of \<mu>] by simp
	+
	+ lemma trg_cod [simp]:
	+ assumes "arr \<mu>"
	+ shows "trg (cod \<mu>) = trg \<mu>"
	+ using assms trg.preserves_cod [of \<mu>] by simp
	+
	+ (*
	+ * TODO: In theory, the following simps should already be available from the fact
	+ * that src and trg are endofunctors. But they seem not to get used.
	+ *)
	+ lemma dom_src [simp]:
	+ assumes "arr \<mu>"
	+ shows "dom (src \<mu>) = src \<mu>"
	+ using assms by simp
	+
	+ lemma cod_src [simp]:
	+ assumes "arr \<mu>"
	+ shows "cod (src \<mu>) = src \<mu>"
	+ using assms by simp
	+
	+ lemma dom_trg [simp]:
	+ assumes "arr \<mu>"
	+ shows "dom (trg \<mu>) = trg \<mu>"
	+ using assms by simp
	+
	+ lemma cod_trg [simp]:
	+ assumes "arr \<mu>"
	+ shows "cod (trg \<mu>) = trg \<mu>"
	+ using assms by simp
	+
	+ lemma vcomp_in_hhom [intro, simp]:
	+ assumes "seq \<nu> \<mu>" and "src \<nu> = a" and "trg \<nu> = b"
	+ shows "\<guillemotleft>\<nu> \<cdot> \<mu> : a \<rightarrow> b\<guillemotright>"
	+ using assms src_cod [of "\<nu> \<cdot> \<mu>"] trg_cod [of "\<nu> \<cdot> \<mu>"] by auto
	+
	+ lemma src_vcomp [simp]:
	+ assumes "seq \<nu> \<mu>"
	+ shows "src (\<nu> \<cdot> \<mu>) = src \<nu>"
	+ using assms src_cod [of "\<nu> \<cdot> \<mu>"] by auto
	+
	+ lemma trg_vcomp [simp]:
	+ assumes "seq \<nu> \<mu>"
	+ shows "trg (\<nu> \<cdot> \<mu>) = trg \<nu>"
	+ using assms trg_cod [of "\<nu> \<cdot> \<mu>"] by auto
	+
	+ lemma vseq_implies_hpar:
	+ assumes "seq \<nu> \<mu>"
	+ shows "src \<nu> = src \<mu>" and "trg \<nu> = trg \<mu>"
	+ using assms src_dom [of "\<nu> \<cdot> \<mu>"] trg_dom [of "\<nu> \<cdot> \<mu>"] src_cod [of "\<nu> \<cdot> \<mu>"]
	+ trg_cod [of "\<nu> \<cdot> \<mu>"]
	+ by auto
	+
	+ lemma vconn_implies_hpar:
	+ assumes "\<guillemotleft>\<mu> : f \<Rightarrow> g\<guillemotright>"
	+ shows "src \<mu> = src f" and "trg \<mu> = trg f" and "src g = src f" and "trg g = trg f"
	+ using assms by auto
	+
	+ lemma src_inv [simp]:
	+ assumes "iso \<mu>"
	+ shows "src (inv \<mu>) = src \<mu>"
	+ using assms inv_in_hom iso_is_arr src_dom src_cod iso_inv_iso dom_inv by metis
	+
	+ lemma trg_inv [simp]:
	+ assumes "iso \<mu>"
	+ shows "trg (inv \<mu>) = trg \<mu>"
	+ using assms inv_in_hom iso_is_arr trg_dom trg_cod iso_inv_iso cod_inv by metis
	+
	+ lemma inv_in_hhom [intro, simp]:
	+ assumes "iso \<mu>" and "src \<mu> = a" and "trg \<mu> = b"
	+ shows "\<guillemotleft>inv \<mu> : a \<rightarrow> b\<guillemotright>"
	+ using assms iso_is_arr by simp
	+
	+ lemma hhom_is_subcategory:
	+ shows "subcategory V (\<lambda>\<mu>. \<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>)"
	+ using src_dom trg_dom src_cod trg_cod by (unfold_locales, auto)
	+
	+ lemma isomorphic_objects_are_equal:
	+ assumes "obj a" and "obj b" and "a \<cong> b"
	+ shows "a = b"
	+ using assms isomorphic_def
	+ by (metis arr_inv dom_inv in_homE objE src_dom src_inv)
	+
	+
	+ text \<open>
	+ Having the functors \<open>src\<close> and \<open>trg\<close> allows us to form categories VV and VVV
	+ of formally horizontally composable pairs and triples of arrows.
	+ \<close>
	+
	+ interpretation VxV: product_category V V ..
	+ interpretation VV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. hseq\<^sub>H\<^sub>H (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
	+ by (unfold_locales, auto)
	+
	+ lemma subcategory_VV:
	+ shows "subcategory VxV.comp (\<lambda>\<mu>\<nu>. hseq\<^sub>H\<^sub>H (fst \<mu>\<nu>) (snd \<mu>\<nu>))"
	+ ..
	+
	+ interpretation VxVxV: product_category V VxV.comp ..
	+ interpretation VVV: subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using VV.arr_char
	+ by (unfold_locales, auto)
	+
	+ lemma subcategory_VVV:
	+ shows "subcategory VxVxV.comp
	+ (\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>)))"
	+ ..
	+
	+ end
	+
	+ subsection "Prebicategories with Homs"
	+
	+ text \<open>
	+ A \emph{weak composition with homs} consists of a weak composition that is
	+ equipped with horizontal homs in such a way that the chosen source and
	+ target of each 2-cell \<open>\<mu>\<close> in fact lie in the set of sources and targets,
	+ respectively, of \<open>\<mu>\<close>, such that horizontal composition respects the
	+ chosen sources and targets, and such that if 2-cells \<open>\<mu>\<close> and \<open>\<nu>\<close> are
	+ horizontally composable, then the chosen target of \<open>\<mu>\<close> coincides with
	+ the chosen source of \<open>\<nu>\<close>.
	+ \<close>
	+
	+ locale weak_composition_with_homs =
	+ weak_composition +
	+ horizontal_homs +
	+ assumes src_in_sources: "arr \<mu> \<Longrightarrow> src \<mu> \<in> sources \<mu>"
	+ and trg_in_targets: "arr \<mu> \<Longrightarrow> trg \<mu> \<in> targets \<mu>"
	+ and src_hcomp: "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> src (\<nu> \<star> \<mu>) = src \<mu>"
	+ and trg_hcomp: "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> trg (\<nu> \<star> \<mu>) = trg \<nu>"
	+ and seq_if_composable: "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> src \<nu> = trg \<mu>"
	+
	+ locale prebicategory_with_homs =
	+ prebicategory +
	+ weak_composition_with_homs
	+ begin
	+
	+ lemma composable_char\<^sub>P\<^sub>B\<^sub>H:
	+ shows "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
	+ proof
	+ show "arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu> \<Longrightarrow> \<nu> \<star> \<mu> \<noteq> null"
	+ using trg_in_targets src_in_sources composable_if_connected
	+ by (metis sourcesD(3) targets_determine_composability)
	+ show "\<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
	+ using seq_if_composable composable_implies_arr by auto
	+ qed
	+
	+ lemma hcomp_in_hom\<^sub>P\<^sub>B\<^sub>H:
	+ assumes "\<guillemotleft>\<mu> : a \<rightarrow>\<^sub>W\<^sub>C b\<guillemotright>" and "\<guillemotleft>\<nu> : b \<rightarrow>\<^sub>W\<^sub>C c\<guillemotright>"
	+ shows "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow>\<^sub>W\<^sub>C c\<guillemotright>"
	+ and "\<guillemotleft>\<nu> \<star> \<mu> : dom \<nu> \<star> dom \<mu> \<Rightarrow> cod \<nu> \<star> cod \<mu>\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow>\<^sub>W\<^sub>C c\<guillemotright>"
	+ using assms sources_determine_composability sources_hcomp targets_hcomp by auto
	+ thus "\<guillemotleft>\<nu> \<star> \<mu> : dom \<nu> \<star> dom \<mu> \<Rightarrow> cod \<nu> \<star> cod \<mu>\<guillemotright>"
	+ using assms by auto
	+ qed
	+
	+ text \<open>
	+ In a prebicategory with homs, if \<open>a\<close> is an object (i.e. \<open>src a = a\<close> and \<open>trg a = a\<close>),
	+ then \<open>a\<close> is a weak unit. The converse need not hold: there can be weak units that the
	+ \<open>src\<close> and \<open>trg\<close> mappings send to other 1-cells in the same isomorphism class.
	+ \<close>
	+
	+ lemma obj_is_weak_unit:
	+ assumes "obj a"
	+ shows "weak_unit a"
	+ proof -
	+ have "a \<in> sources a"
	+ using assms objE src_in_sources ideD(1) by metis
	+ thus ?thesis by auto
	+ qed
	+
	+ end
	+
	+ subsection "Choosing Homs"
	+
	+ text \<open>
	+ Every prebicategory extends to a prebicategory with homs, by choosing an arbitrary
	+ representative of each isomorphism class of weak units to serve as an object.
	+ ``The source'' of a 2-cell is defined to be the chosen representative of the set of
	+ all its sources (which is an isomorphism class), and similarly for ``the target''.
	+ \<close>
	+
	+ context prebicategory
	+ begin
	+
	+ definition rep
	+ where "rep f \<equiv> SOME f'. f' \<in> { f'. f \<cong> f' }"
	+
	+ definition some_src
	+ where "some_src \<mu> \<equiv> if arr \<mu> then rep (SOME a. a \<in> sources \<mu>) else null"
	+
	+ definition some_trg
	+ where "some_trg \<mu> \<equiv> if arr \<mu> then rep (SOME b. b \<in> targets \<mu>) else null"
	+
	+ lemma isomorphic_ide_rep:
	+ assumes "ide f"
	+ shows "f \<cong> rep f"
	+ proof -
	+ have "\<exists>f'. f' \<in> { f'. f \<cong> f' }"
	+ using assms isomorphic_reflexive by blast
	+ thus ?thesis using rep_def someI_ex by simp
	+ qed
	+
	+ lemma rep_rep:
	+ assumes "ide f"
	+ shows "rep (rep f) = rep f"
	+ proof -
	+ have "rep f \<in> { f'. f \<cong> f' }"
	+ using assms isomorphic_ide_rep by simp
	+ have "{ f'. f \<cong> f' } = { f'. rep f \<cong> f' }"
	+ proof -
	+ have "\<And>f'. f \<cong> f' \<longleftrightarrow> rep f \<cong> f'"
	+ proof
	+ fix f'
	+ assume f': "f \<cong> f'"
	+ show "rep f \<cong> f'"
	+ proof -
	+ obtain \<phi> where \<phi>: "\<phi> \<in> hom f f' \<and> iso \<phi>"
	+ using f' by auto
	+ obtain \<psi> where \<psi>: "\<psi> \<in> hom f (rep f) \<and> iso \<psi>"
	+ using assms isomorphic_ide_rep by blast
	+ have "inv \<psi> \<in> hom (rep f) f \<and> iso (inv \<psi>)"
	+ using \<psi> iso_inv_iso inv_in_hom by simp
	+ hence "iso (V \<phi> (inv \<psi>)) \<and> V \<phi> (inv \<psi>) \<in> hom (rep f) f'"
	+ using \<phi> isos_compose by auto
	+ thus ?thesis using isomorphic_def by auto
	+ qed
	+ next
	+ fix f'
	+ assume f': "rep f \<cong> f'"
	+ show "f \<cong> f'"
	+ using assms f' isomorphic_ide_rep isos_compose isomorphic_def by blast
	+ qed
	+ thus ?thesis by auto
	+ qed
	+ hence "rep (rep f) = (SOME f'. f' \<in> { f'. f \<cong> f' })"
	+ using assms rep_def by fastforce
	+ also have "... = rep f"
	+ using assms rep_def by simp
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma some_src_in_sources:
	+ assumes "arr \<mu>"
	+ shows "some_src \<mu> \<in> sources \<mu>"
	+ proof -
	+ have 1: "(SOME a. a \<in> sources \<mu>) \<in> sources \<mu>"
	+ using assms arr_iff_has_src someI_ex [of "\<lambda>a. a \<in> sources \<mu>"] by blast
	+ moreover have "ide (SOME a. a \<in> sources \<mu>)"
	+ using 1 weak_unit_self_composable by auto
	+ ultimately show ?thesis
	+ using assms 1 some_src_def
	+ sources_iso_closed [of "SOME a. a \<in> sources \<mu>" \<mu>]
	+ isomorphic_ide_rep [of "SOME a. a \<in> sources \<mu>"]
	+ by metis
	+ qed
	+
	+ lemma some_trg_in_targets:
	+ assumes "arr \<mu>"
	+ shows "some_trg \<mu> \<in> targets \<mu>"
	+ proof -
	+ have 1: "(SOME a. a \<in> targets \<mu>) \<in> targets \<mu>"
	+ using assms arr_iff_has_trg someI_ex [of "\<lambda>a. a \<in> targets \<mu>"] by blast
	+ moreover have "ide (SOME a. a \<in> targets \<mu>)"
	+ using 1 weak_unit_self_composable by auto
	+ ultimately show ?thesis
	+ using assms 1 some_trg_def
	+ targets_iso_closed [of "SOME a. a \<in> targets \<mu>" \<mu>]
	+ isomorphic_ide_rep [of "SOME a. a \<in> targets \<mu>"]
	+ by presburger
	+ qed
	+
	+ lemma some_src_dom:
	+ assumes "arr \<mu>"
	+ shows "some_src (dom \<mu>) = some_src \<mu>"
	+ using assms some_src_def sources_dom by simp
	+
	+ lemma some_src_cod:
	+ assumes "arr \<mu>"
	+ shows "some_src (cod \<mu>) = some_src \<mu>"
	+ using assms some_src_def sources_cod by simp
	+
	+ lemma some_trg_dom:
	+ assumes "arr \<mu>"
	+ shows "some_trg (dom \<mu>) = some_trg \<mu>"
	+ using assms some_trg_def targets_dom by simp
	+
	+ lemma some_trg_cod:
	+ assumes "arr \<mu>"
	+ shows "some_trg (cod \<mu>) = some_trg \<mu>"
	+ using assms some_trg_def targets_cod by simp
	+
	+ lemma ide_some_src:
	+ assumes "arr \<mu>"
	+ shows "ide (some_src \<mu>)"
	+ using assms some_src_in_sources weak_unit_self_composable by blast
	+
	+ lemma ide_some_trg:
	+ assumes "arr \<mu>"
	+ shows "ide (some_trg \<mu>)"
	+ using assms some_trg_in_targets weak_unit_self_composable by blast
	+
	+ lemma some_src_composable:
	+ assumes "arr \<tau>"
	+ shows "\<tau> \<star> \<mu> \<noteq> null \<longleftrightarrow> some_src \<tau> \<star> \<mu> \<noteq> null"
	+ using assms some_src_in_sources sources_determine_composability by blast
	+
	+ lemma some_trg_composable:
	+ assumes "arr \<sigma>"
	+ shows "\<mu> \<star> \<sigma> \<noteq> null \<longleftrightarrow> \<mu> \<star> some_trg \<sigma> \<noteq> null"
	+ using assms some_trg_in_targets targets_determine_composability by blast
	+
	+ lemma sources_some_src:
	+ assumes "arr \<mu>"
	+ shows "sources (some_src \<mu>) = sources \<mu>"
	+ using assms sources_determine_composability some_src_in_sources by blast
	+
	+ lemma targets_some_trg:
	+ assumes "arr \<mu>"
	+ shows "targets (some_trg \<mu>) = targets \<mu>"
	+ using assms targets_determine_composability some_trg_in_targets by blast
	+
	+ lemma src_some_src:
	+ assumes "arr \<mu>"
	+ shows "some_src (some_src \<mu>) = some_src \<mu>"
	+ using assms some_src_def ide_some_src sources_some_src by force
	+
	+ lemma trg_some_trg:
	+ assumes "arr \<mu>"
	+ shows "some_trg (some_trg \<mu>) = some_trg \<mu>"
	+ using assms some_trg_def ide_some_trg targets_some_trg by force
	+
	+ lemma sources_char':
	+ assumes "arr \<mu>"
	+ shows "a \<in> sources \<mu> \<longleftrightarrow> some_src \<mu> \<cong> a"
	+ using assms some_src_in_sources sources_iso_closed sources_are_isomorphic by meson
	+
	+ lemma targets_char':
	+ assumes "arr \<mu>"
	+ shows "a \<in> targets \<mu> \<longleftrightarrow> some_trg \<mu> \<cong> a"
	+ using assms some_trg_in_targets targets_iso_closed targets_are_isomorphic by blast
	+
	+ text \<open>
	+ An arbitrary choice of sources and targets in a prebicategory results in a notion of
	+ formal composability that coincides with the actual horizontal composability
	+ of the prebicategory.
	+ \<close>
	+
	+ lemma composable_char\<^sub>P\<^sub>B:
	+ shows "\<tau> \<star> \<sigma> \<noteq> null \<longleftrightarrow> arr \<sigma> \<and> arr \<tau> \<and> some_src \<tau> = some_trg \<sigma>"
	+ proof
	+ assume \<sigma>\<tau>: "\<tau> \<star> \<sigma> \<noteq> null"
	+ show "arr \<sigma> \<and> arr \<tau> \<and> some_src \<tau> = some_trg \<sigma>"
	+ using \<sigma>\<tau> composable_implies_arr connected_if_composable some_src_def some_trg_def
	+ by force
	+ next
	+ assume \<sigma>\<tau>: "arr \<sigma> \<and> arr \<tau> \<and> some_src \<tau> = some_trg \<sigma>"
	+ show "\<tau> \<star> \<sigma> \<noteq> null"
	+ using \<sigma>\<tau> some_src_in_sources some_trg_composable by force
	+ qed
	+
	+ text \<open>
	+ A 1-cell is its own source if and only if it is its own target.
	+ \<close>
	+
	+ lemma self_src_iff_self_trg:
	+ assumes "ide a"
	+ shows "a = some_src a \<longleftrightarrow> a = some_trg a"
	+ proof
	+ assume a: "a = some_src a"
	+ have "weak_unit a \<and> a \<star> a \<noteq> null"
	+ using assms a some_src_in_sources [of a] by force
	+ thus "a = some_trg a" using a composable_char\<^sub>P\<^sub>B by simp
	+ next
	+ assume a: "a = some_trg a"
	+ have "weak_unit a \<and> a \<star> a \<noteq> null"
	+ using assms a some_trg_in_targets [of a] by force
	+ thus "a = some_src a" using a composable_char\<^sub>P\<^sub>B by simp
	+ qed
	+
	+ lemma some_trg_some_src:
	+ assumes "arr \<mu>"
	+ shows "some_trg (some_src \<mu>) = some_src \<mu>"
	+ using assms ide_some_src some_src_def some_trg_def some_src_in_sources sources_char
	+ targets_char sources_some_src
	+ by force
	+
	+ lemma src_some_trg:
	+ assumes "arr \<mu>"
	+ shows "some_src (some_trg \<mu>) = some_trg \<mu>"
	+ using assms ide_some_trg some_src_def some_trg_def some_trg_in_targets sources_char
	+ targets_char targets_some_trg
	+ by force
	+
	+ lemma some_src_eqI:
	+ assumes "a \<in> sources \<mu>" and "some_src a = a"
	+ shows "some_src \<mu> = a"
	+ proof -
	+ have 1: "arr \<mu> \<and> arr a" using assms composable_implies_arr by auto
	+ have "some_src \<mu> = rep (SOME x. x \<in> sources \<mu>)"
	+ using assms 1 some_src_def by simp
	+ also have "... = rep (SOME x. some_src \<mu> \<cong> x)"
	+ using assms 1 sources_char' by simp
	+ also have "... = rep (SOME x. some_src a \<cong> x)"
	+ using assms 1 some_src_in_sources sources_are_isomorphic
	+ isomorphic_symmetric isomorphic_transitive
	+ by metis
	+ also have "... = rep (SOME x. x \<in> sources a)"
	+ using assms 1 sources_char' by auto
	+ also have "... = some_src a"
	+ using assms 1 some_src_def by simp
	+ also have "... = a"
	+ using assms by auto
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma some_trg_eqI:
	+ assumes "b \<in> targets \<mu>" and "some_trg b = b"
	+ shows "some_trg \<mu> = b"
	+ proof -
	+ have 1: "arr \<mu> \<and> arr b" using assms composable_implies_arr by auto
	+ have "some_trg \<mu> = rep (SOME x. x \<in> targets \<mu>)"
	+ using assms 1 some_trg_def by simp
	+ also have "... = rep (SOME x. some_trg \<mu> \<cong> x)"
	+ using assms 1 targets_char' by simp
	+ also have "... = rep (SOME x. some_trg b \<cong> x)"
	+ using assms 1 some_trg_in_targets targets_are_isomorphic
	+ isomorphic_symmetric isomorphic_transitive
	+ by metis
	+ also have "... = rep (SOME x. x \<in> targets b)"
	+ using assms 1 targets_char' by auto
	+ also have "... = some_trg b"
	+ using assms 1 some_trg_def by simp
	+ also have "... = b"
	+ using assms by auto
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma some_src_comp:
	+ assumes "\<tau> \<star> \<sigma> \<noteq> null"
	+ shows "some_src (\<tau> \<star> \<sigma>) = some_src \<sigma>"
	+ proof (intro some_src_eqI [of "some_src \<sigma>" "\<tau> \<star> \<sigma>"])
	+ show "some_src (some_src \<sigma>) = some_src \<sigma>"
	+ using assms src_some_src composable_implies_arr by simp
	+ show "some_src \<sigma> \<in> sources (H \<tau> \<sigma>)"
	+ using assms some_src_in_sources composable_char\<^sub>P\<^sub>B match_3 [of \<sigma> "some_src \<sigma>"]
	+ by (simp add: sources_hcomp)
	+ qed
	+
	+ lemma some_trg_comp:
	+ assumes "\<tau> \<star> \<sigma> \<noteq> null"
	+ shows "some_trg (\<tau> \<star> \<sigma>) = some_trg \<tau>"
	+ proof (intro some_trg_eqI [of "some_trg \<tau>" "\<tau> \<star> \<sigma>"])
	+ show "some_trg (some_trg \<tau>) = some_trg \<tau>"
	+ using assms trg_some_trg composable_implies_arr by simp
	+ show "some_trg \<tau> \<in> targets (H \<tau> \<sigma>)"
	+ using assms some_trg_in_targets composable_char\<^sub>P\<^sub>B match_4 [of \<tau> \<sigma> "some_trg \<tau>"]
	+ by (simp add: targets_hcomp)
	+ qed
	+
	+ text \<open>
	+ The mappings that take an arrow to its chosen source or target are endofunctors
	+ of the vertical category, which commute with each other in the manner required
	+ for horizontal homs.
	+ \<close>
	+
	+ interpretation S: endofunctor V some_src
	+ apply unfold_locales
	+ using some_src_def apply simp
	+ using ide_some_src apply simp
	+ using some_src_dom ide_some_src apply simp
	+ using some_src_cod ide_some_src apply simp
	+ proof -
	+ fix \<nu> \<mu>
	+ assume \<mu>\<nu>: "seq \<nu> \<mu>"
	+ show "some_src (\<nu> \<cdot> \<mu>) = some_src \<nu> \<cdot> some_src \<mu>"
	+ using \<mu>\<nu> some_src_dom [of "\<nu> \<cdot> \<mu>"] some_src_dom some_src_cod [of "\<nu> \<cdot> \<mu>"]
	+ some_src_cod ide_some_src
	+ by auto
	+ qed
	+
	+ interpretation T: endofunctor V some_trg
	+ apply unfold_locales
	+ using some_trg_def apply simp
	+ using ide_some_trg apply simp
	+ using some_trg_dom ide_some_trg apply simp
	+ using some_trg_cod ide_some_trg apply simp
	+ proof -
	+ fix \<nu> \<mu>
	+ assume \<mu>\<nu>: "seq \<nu> \<mu>"
	+ show "some_trg (\<nu> \<cdot> \<mu>) = some_trg \<nu> \<cdot> some_trg \<mu>"
	+ using \<mu>\<nu> some_trg_dom [of "\<nu> \<cdot> \<mu>"] some_trg_dom some_trg_cod [of "\<nu> \<cdot> \<mu>"]
	+ some_trg_cod ide_some_trg
	+ by auto
	+ qed
	+
	+ interpretation weak_composition_with_homs V H some_src some_trg
	+ apply unfold_locales
	+ using some_src_in_sources some_trg_in_targets
	+ src_some_src trg_some_trg src_some_trg some_trg_some_src
	+ some_src_comp some_trg_comp composable_char\<^sub>P\<^sub>B ide_some_src ide_some_trg
	+ by simp_all
	+
	+ proposition extends_to_weak_composition_with_homs:
	+ shows "weak_composition_with_homs V H some_src some_trg"
	+ ..
	+
	+ proposition extends_to_prebicategory_with_homs:
	+ shows "prebicategory_with_homs V H \<a> some_src some_trg"
	+ ..
	+
	+ end
	+
	+ subsection "Choosing Units"
	+
	+ text \<open>
	+ A \emph{prebicategory with units} is a prebicategory equipped with a choice,
	+ for each weak unit \<open>a\<close>, of a ``unit isomorphism'' \<open>\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>\<close>.
	+ \<close>
	+
	+ locale prebicategory_with_units =
	+ prebicategory V H \<a> +
	+ weak_composition V H
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a comp" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]") +
	+ assumes unit_in_vhom\<^sub>P\<^sub>B\<^sub>U: "weak_unit a \<Longrightarrow> \<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ and iso_unit\<^sub>P\<^sub>B\<^sub>U: "weak_unit a \<Longrightarrow> iso \<i>[a]"
	+ begin
	+
	+ lemma unit_in_hom\<^sub>P\<^sub>B\<^sub>U:
	+ assumes "weak_unit a"
	+ shows "\<guillemotleft>\<i>[a] : a \<rightarrow>\<^sub>W\<^sub>C a\<guillemotright>" and "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ proof -
	+ show 1: "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ using assms unit_in_vhom\<^sub>P\<^sub>B\<^sub>U by auto
	+ show "\<guillemotleft>\<i>[a] : a \<rightarrow>\<^sub>W\<^sub>C a\<guillemotright>"
	+ using assms 1 weak_unit_iff_self_source weak_unit_iff_self_target
	+ sources_cod [of "\<i>[a]"] targets_cod [of "\<i>[a]"]
	+ by (elim in_homE, auto)
	+ qed
	+
	+ lemma unit_simps [simp]:
	+ assumes "weak_unit a"
	+ shows "arr \<i>[a]" and "dom \<i>[a] = a \<star> a" and "cod \<i>[a] = a"
	+ using assms unit_in_vhom\<^sub>P\<^sub>B\<^sub>U by auto
	+
	+ end
	+
	+ text \<open>
	+ Every prebicategory extends to a prebicategory with units, simply by choosing the
	+ unit isomorphisms arbitrarily.
	+ \<close>
	+
	+ context prebicategory
	+ begin
	+
	+ proposition extends_to_prebicategory_with_units:
	+ shows "prebicategory_with_units V H \<a> some_unit"
	+ using iso_some_unit by (unfold_locales, auto)
	+
	+ end
	+
	+ subsection "Horizontal Composition"
	+
	+ text \<open>
	+ The following locale axiomatizes a (vertical) category \<open>V\<close> with horizontal homs,
	+ which in addition has been equipped with a functorial operation \<open>H\<close> of
	+ horizontal composition from \<open>VV\<close> to \<open>V\<close>, assumed to preserve source and target.
	+ \<close>
	+
	+ locale horizontal_composition =
	+ horizontal_homs V src trg +
	+ VxV: product_category V V +
	+ VV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. hseq\<^sub>H\<^sub>H (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> +
	+ H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. H (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a" +
	+ assumes src_hcomp': "arr (\<mu> \<star> \<nu>) \<Longrightarrow> src (\<mu> \<star> \<nu>) = src \<nu>"
	+ and trg_hcomp': "arr (\<mu> \<star> \<nu>) \<Longrightarrow> trg (\<mu> \<star> \<nu>) = trg \<mu>"
	+ begin
	+ (* TODO: Why does this get re-introduced? *)
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+
	+ text \<open>
	+ \<open>H\<close> is a partial magma, which shares its null with \<open>V\<close>.
	+ \<close>
	+
	+ lemma is_partial_magma:
	+ shows "partial_magma H" and "partial_magma.null H = null"
	+ proof -
	+ have 1: "\<forall>f. null \<star> f = null \<and> f \<star> null = null"
	+ using H.is_extensional VV.arr_char not_arr_null by auto
	+ interpret H: partial_magma H
	+ proof
	+ show "\<exists>!n. \<forall>f. n \<star> f = n \<and> f \<star> n = n"
	+ proof
	+ show "\<forall>f. null \<star> f = null \<and> f \<star> null = null" by fact
	+ show "\<And>n. \<forall>f. n \<star> f = n \<and> f \<star> n = n \<Longrightarrow> n = null"
	+ using 1 VV.arr_char H.is_extensional not_arr_null by metis
	+ qed
	+ qed
	+ show "partial_magma H" ..
	+ show "H.null = null"
	+ using 1 H.null_def the1_equality [of "\<lambda>n. \<forall>f. n \<star> f = n \<and> f \<star> n = n"]
	+ by metis
	+ qed
	+
	+ text \<open>
	+ \textbf{Note:} The following is ``almost'' \<open>H.seq\<close>, but for that we would need
	+ \<open>H.arr = V.arr\<close>.
	+ This would be unreasonable to expect, in general, as the definition of \<open>H.arr\<close> is based
	+ on ``strict'' units rather than weak units.
	+ Later we will show that we do have \<open>H.arr = V.arr\<close> if the vertical category is discrete.
	+ \<close>
	+
	+ abbreviation hseq
	+ where "hseq \<nu> \<mu> \<equiv> arr (\<nu> \<star> \<mu>)"
	+
	+ lemma hseq_char:
	+ shows "hseq \<nu> \<mu> \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
	+ proof -
	+ have "hseq \<nu> \<mu> \<longleftrightarrow> VV.arr (\<nu>, \<mu>)"
	+ using H.is_extensional H.preserves_arr by force
	+ also have "... \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu>"
	+ using VV.arr_char by force
	+ finally show ?thesis by blast
	+ qed
	+
	+ lemma hseq_char':
	+ shows "hseq \<nu> \<mu> \<longleftrightarrow> \<nu> \<star> \<mu> \<noteq> null"
	+ using VV.arr_char H.preserves_arr H.is_extensional hseq_char [of \<nu> \<mu>] by auto
	+
	+ (*
	+ * The following is pretty useful as a simp, but it really slows things down,
	+ * so it is not one by default.
	+ *)
	+ lemma hseqI' (* [simp] *):
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
	+ shows "hseq \<nu> \<mu>"
	+ using assms hseq_char by simp
	+
	+ lemma hseqI [intro]:
	+ assumes "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>\<nu> : b \<rightarrow> c\<guillemotright>"
	+ shows "hseq \<nu> \<mu>"
	+ using assms hseq_char by auto
	+
	+ lemma hseqE [elim]:
	+ assumes "hseq \<nu> \<mu>"
	+ and "arr \<mu> \<Longrightarrow> arr \<nu> \<Longrightarrow> src \<nu> = trg \<mu> \<Longrightarrow> T"
	+ shows "T"
	+ using assms hseq_char by simp
	+
	+ lemma hcomp_simps [simp]:
	+ assumes "hseq \<nu> \<mu>"
	+ shows "src (\<nu> \<star> \<mu>) = src \<mu>" and "trg (\<nu> \<star> \<mu>) = trg \<nu>"
	+ and "dom (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>" and "cod (\<nu> \<star> \<mu>) = cod \<nu> \<star> cod \<mu>"
	+ using assms VV.arr_char src_hcomp' apply force
	+ using assms VV.arr_char trg_hcomp' apply force
	+ using assms VV.arr_char H.preserves_dom apply force
	+ using assms VV.arr_char H.preserves_cod by force
	+
	+ lemma ide_hcomp [intro, simp]:
	+ assumes "ide \<nu>" and "ide \<mu>" and "src \<nu> = trg \<mu>"
	+ shows "ide (\<nu> \<star> \<mu>)"
	+ using assms VV.ide_char VV.arr_char H.preserves_ide [of "(\<nu>, \<mu>)"] by auto
	+
	+ lemma hcomp_in_hhom [intro, simp]:
	+ assumes "\<guillemotleft>\<mu> : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>\<nu> : b \<rightarrow> c\<guillemotright>"
	+ shows "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow> c\<guillemotright>"
	+ using assms hseq_char by fastforce
	+
	+ lemma hcomp_in_hhomE [elim]:
	+ assumes "\<guillemotleft>\<nu> \<star> \<mu> : a \<rightarrow> c\<guillemotright>"
	+ and "\<lbrakk> arr \<mu>; arr \<nu>; src \<nu> = trg \<mu>; src \<mu> = a; trg \<nu> = c \<rbrakk> \<Longrightarrow> T"
	+ shows T
	+ using assms in_hhom_def by fastforce
	+
	+ lemma hcomp_in_vhom [intro, simp]:
	+ assumes "\<guillemotleft>\<mu> : f \<Rightarrow> g\<guillemotright>" and "\<guillemotleft>\<nu> : h \<Rightarrow> k\<guillemotright>" and "src h = trg f"
	+ shows "\<guillemotleft>\<nu> \<star> \<mu> : h \<star> f \<Rightarrow> k \<star> g\<guillemotright>"
	+ using assms hseqI' by fastforce
	+
	+ lemma hcomp_in_vhomE [elim]:
	+ assumes "\<guillemotleft>\<nu> \<star> \<mu> : f \<Rightarrow> g\<guillemotright>"
	+ and "\<lbrakk> arr \<mu>; arr \<nu>; src \<nu> = trg \<mu>; src \<mu> = src f; src \<mu> = src g;
	+ trg \<nu> = trg f; trg \<nu> = trg g \<rbrakk> \<Longrightarrow> T"
	+ shows T
	+ using assms in_hom_def
	+ by (metis in_homE hseqE src_cod src_dom src_hcomp' trg_cod trg_dom trg_hcomp')
	+
	+ text \<open>
	+ A horizontal composition yields a weak composition by simply forgetting
	+ the \<open>src\<close> and \<open>trg\<close> functors.
	+ \<close>
	+
	+ lemma match_1:
	+ assumes "\<nu> \<star> \<mu> \<noteq> null" and "(\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null"
	+ shows "\<mu> \<star> \<tau> \<noteq> null"
	+ using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
	+
	+ lemma match_2:
	+ assumes "\<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null" and "\<mu> \<star> \<tau> \<noteq> null"
	+ shows "\<nu> \<star> \<mu> \<noteq> null"
	+ using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
	+
	+ lemma match_3:
	+ assumes "\<mu> \<star> \<tau> \<noteq> null" and "\<nu> \<star> \<mu> \<noteq> null"
	+ shows "(\<nu> \<star> \<mu>) \<star> \<tau> \<noteq> null"
	+ using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
	+
	+ lemma match_4:
	+ assumes "\<mu> \<star> \<tau> \<noteq> null" and "\<nu> \<star> \<mu> \<noteq> null"
	+ shows "\<nu> \<star> (\<mu> \<star> \<tau>) \<noteq> null"
	+ using assms H.is_extensional not_arr_null VV.arr_char hseq_char hseq_char' by auto
	+
	+ lemma left_connected:
	+ assumes "seq \<nu> \<nu>'"
	+ shows "\<nu> \<star> \<mu> \<noteq> null \<longleftrightarrow> \<nu>' \<star> \<mu> \<noteq> null"
	+ using assms H.is_extensional not_arr_null VV.arr_char hseq_char'
	+ by (metis hseq_char seqE vseq_implies_hpar(1))
	+
	+ lemma right_connected:
	+ assumes "seq \<mu> \<mu>'"
	+ shows "H \<nu> \<mu> \<noteq> null \<longleftrightarrow> H \<nu> \<mu>' \<noteq> null"
	+ using assms H.is_extensional not_arr_null VV.arr_char hseq_char'
	+ by (metis hseq_char seqE vseq_implies_hpar(2))
	+
	+ proposition is_weak_composition:
	+ shows "weak_composition V H"
	+ proof -
	+ have 1: "(\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu> \<noteq> null)
	+ = (\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and> src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>))"
	+ using hseq_char' by auto
	+ interpret VoV: subcategory VxV.comp \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu> \<noteq> null\<close>
	+ using 1 VV.subcategory_axioms by simp
	+ interpret H: "functor" VoV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
	+ using H.functor_axioms 1 by simp
	+ show ?thesis
	+ using match_1 match_2 match_3 match_4 left_connected right_connected
	+ by (unfold_locales, metis)
	+ qed
	+
	+ interpretation weak_composition V H
	+ using is_weak_composition by auto
	+
	+ text \<open>
	+ It can be shown that \<open>arr ((\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>)) \<Longrightarrow> (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)\<close>.
	+ However, we do not have \<open>arr ((\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)) \<Longrightarrow> (\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)\<close>,
	+ because it does not follow from \<open>arr ((\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>))\<close> that \<open>dom \<nu> = cod \<mu>\<close>
	+ and \<open>dom \<tau> = cod \<sigma>\<close>, only that \<open>dom \<nu> \<star> dom \<tau> = cod \<mu> \<star> cod \<sigma>\<close>.
	+ So we don't get interchange unconditionally.
	+ \<close>
	+
	+ lemma interchange:
	+ assumes "seq \<nu> \<mu>" and "seq \<tau> \<sigma>"
	+ shows "(\<nu> \<cdot> \<mu>) \<star> (\<tau> \<cdot> \<sigma>) = (\<nu> \<star> \<tau>) \<cdot> (\<mu> \<star> \<sigma>)"
	+ using assms interchange by simp
	+
	+ lemma whisker_right:
	+ assumes "ide f" and "seq \<nu> \<mu>"
	+ shows "(\<nu> \<cdot> \<mu>) \<star> f = (\<nu> \<star> f) \<cdot> (\<mu> \<star> f)"
	+ using assms whisker_right by simp
	+
	+ lemma whisker_left:
	+ assumes "ide f" and "seq \<nu> \<mu>"
	+ shows "f \<star> (\<nu> \<cdot> \<mu>) = (f \<star> \<nu>) \<cdot> (f \<star> \<mu>)"
	+ using assms whisker_left by simp
	+
	+ lemma inverse_arrows_hcomp:
	+ assumes "iso \<mu>" and "iso \<nu>" and "src \<nu> = trg \<mu>"
	+ shows "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
	+ proof -
	+ show "inverse_arrows (\<nu> \<star> \<mu>) (inv \<nu> \<star> inv \<mu>)"
	+ proof
	+ show "ide ((inv \<nu> \<star> inv \<mu>) \<cdot> (\<nu> \<star> \<mu>))"
	+ proof -
	+ have "(inv \<nu> \<star> inv \<mu>) \<cdot> (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>"
	+ using assms interchange iso_is_arr comp_inv_arr'
	+ by (metis arr_dom)
	+ thus ?thesis
	+ using assms iso_is_arr by simp
	+ qed
	+ show "ide ((\<nu> \<star> \<mu>) \<cdot> (inv \<nu> \<star> inv \<mu>))"
	+ proof -
	+ have "(\<nu> \<star> \<mu>) \<cdot> (inv \<nu> \<star> inv \<mu>) = cod \<nu> \<star> cod \<mu>"
	+ using assms interchange iso_is_arr comp_arr_inv'
	+ by (metis arr_cod)
	+ thus ?thesis
	+ using assms iso_is_arr by simp
	+ qed
	+ qed
	+ qed
	+
	+ lemma iso_hcomp [intro, simp]:
	+ assumes "iso \<mu>" and "iso \<nu>" and "src \<nu> = trg \<mu>"
	+ shows "iso (\<nu> \<star> \<mu>)"
	+ using assms inverse_arrows_hcomp by auto
	+
	+ lemma isomorphic_implies_ide:
	+ assumes "f \<cong> g"
	+ shows "ide f" and "ide g"
	+ using assms isomorphic_def by auto
	+
	+ lemma hcomp_ide_isomorphic:
	+ assumes "ide f" and "g \<cong> h" and "src f = trg g"
	+ shows "f \<star> g \<cong> f \<star> h"
	+ proof -
	+ obtain \<mu> where \<mu>: "iso \<mu> \<and> \<guillemotleft>\<mu> : g \<Rightarrow> h\<guillemotright>"
	+ using assms isomorphic_def by auto
	+ have "iso (f \<star> \<mu>) \<and> \<guillemotleft>f \<star> \<mu> : f \<star> g \<Rightarrow> f \<star> h\<guillemotright>"
	+ using assms \<mu> iso_hcomp by auto
	+ thus ?thesis
	+ using isomorphic_def by auto
	+ qed
	+
	+ lemma hcomp_isomorphic_ide:
	+ assumes "f \<cong> g" and "ide h" and "src f = trg h"
	+ shows "f \<star> h \<cong> g \<star> h"
	+ proof -
	+ obtain \<mu> where \<mu>: "iso \<mu> \<and> \<guillemotleft>\<mu> : f \<Rightarrow> g\<guillemotright>"
	+ using assms isomorphic_def by auto
	+ have "iso (\<mu> \<star> h) \<and> \<guillemotleft>\<mu> \<star> h : f \<star> h \<Rightarrow> g \<star> h\<guillemotright>"
	+ using assms \<mu> iso_hcomp by auto
	+ thus ?thesis
	+ using isomorphic_def by auto
	+ qed
	+
	+ lemma isomorphic_implies_hpar:
	+ assumes "f \<cong> f'"
	+ shows "ide f" and "ide f'" and "src f = src f'" and "trg f = trg f'"
	+ using assms isomorphic_def by auto
	+
	+ lemma inv_hcomp [simp]:
	+ assumes "iso \<nu>" and "iso \<mu>" and "src \<nu> = trg \<mu>"
	+ shows "inv (\<nu> \<star> \<mu>) = inv \<nu> \<star> inv \<mu>"
	+ using assms inverse_arrow_unique [of "\<nu> \<star> \<mu>"] inv_is_inverse inverse_arrows_hcomp
	+ by auto
	+
	+ interpretation VxVxV: product_category V VxV.comp ..
	+ interpretation VVV: subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using subcategory_VVV by auto
	+
	+ text \<open>
	+ The following define the two ways of using horizontal composition to compose three arrows.
	+ \<close>
	+
	+ definition HoHV
	+ where "HoHV \<mu> \<equiv> if VVV.arr \<mu> then (fst \<mu> \<star> fst (snd \<mu>)) \<star> snd (snd \<mu>) else null"
	+
	+ definition HoVH
	+ where "HoVH \<mu> \<equiv> if VVV.arr \<mu> then fst \<mu> \<star> fst (snd \<mu>) \<star> snd (snd \<mu>) else null"
	+
	+ lemma functor_HoHV:
	+ shows "functor VVV.comp V HoHV"
	+ apply unfold_locales
	+ using VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char VVV.comp_char
	+ HoHV_def hseqI'
	+ apply auto[4]
	+ proof -
	+ fix f g
	+ assume fg: "VVV.seq g f"
	+ show "HoHV (VVV.comp g f) = HoHV g \<cdot> HoHV f"
	+ proof -
	+ have "VxVxV.comp g f =
	+ (fst g \<cdot> fst f, fst (snd g) \<cdot> fst (snd f), snd (snd g) \<cdot> snd (snd f))"
	+ using fg VVV.seq_char VVV.arr_char VV.arr_char VxVxV.comp_char VxV.comp_char
	+ by (metis (no_types, lifting) VxV.seqE VxVxV.seqE)
	+ hence "HoHV (VVV.comp g f) =
	+ (fst g \<cdot> fst f \<star> fst (snd g) \<cdot> fst (snd f)) \<star> snd (snd g) \<cdot> snd (snd f)"
	+ using HoHV_def VVV.comp_simp fg by auto
	+ also have "... = ((fst g \<star> fst (snd g)) \<star> snd (snd g)) \<cdot>
	+ ((fst f \<star> fst (snd f)) \<star> snd (snd f))"
	+ using fg VVV.seq_char VVV.arr_char VV.arr_char interchange
	+ by (metis (no_types, lifting) VxV.seqE VxVxV.seqE hseqI' src_vcomp trg_vcomp)
	+ also have "... = HoHV g \<cdot> HoHV f"
	+ using HoHV_def fg by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma functor_HoVH:
	+ shows "functor VVV.comp V HoVH"
	+ apply unfold_locales
	+ using VVV.arr_char VV.arr_char VVV.dom_char VVV.cod_char VVV.comp_char
	+ HoHV_def HoVH_def hseqI'
	+ apply auto[4]
	+ proof -
	+ fix f g
	+ assume fg: "VVV.seq g f"
	+ show "HoVH (VVV.comp g f) = HoVH g \<cdot> HoVH f"
	+ proof -
	+ have "VxVxV.comp g f =
	+ (fst g \<cdot> fst f, fst (snd g) \<cdot> fst (snd f), snd (snd g) \<cdot> snd (snd f))"
	+ using fg VVV.seq_char VVV.arr_char VV.arr_char VxVxV.comp_char VxV.comp_char
	+ by (metis (no_types, lifting) VxV.seqE VxVxV.seqE)
	+ hence "HoVH (VVV.comp g f) =
	+ fst g \<cdot> fst f \<star> fst (snd g) \<cdot> fst (snd f) \<star> snd (snd g) \<cdot> snd (snd f)"
	+ using HoVH_def VVV.comp_simp fg by auto
	+ also have "... = (fst g \<star> fst (snd g) \<star> snd (snd g)) \<cdot>
	+ (fst f \<star> fst (snd f) \<star> snd (snd f))"
	+ using fg VVV.seq_char VVV.arr_char VV.arr_char interchange
	+ by (metis (no_types, lifting) VxV.seqE VxVxV.seqE hseqI' src_vcomp trg_vcomp)
	+ also have "... = HoVH g \<cdot> HoVH f"
	+ using fg VVV.seq_char VVV.arr_char HoVH_def VVV.comp_char VV.arr_char
	+ by (metis (no_types, lifting))
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ text \<open>
	+ The following define horizontal composition of an arrow on the left by its target
	+ and on the right by its source.
	+ \<close>
	+
	+ abbreviation L
	+ where "L \<equiv> \<lambda>\<mu>. if arr \<mu> then trg \<mu> \<star> \<mu> else null"
	+
	+ abbreviation R
	+ where "R \<equiv> \<lambda>\<mu>. if arr \<mu> then \<mu> \<star> src \<mu> else null"
	+
	+ lemma endofunctor_L:
	+ shows "endofunctor V L"
	+ using hseqI' vseq_implies_hpar(2) whisker_left
	+ by (unfold_locales, auto)
	+
	+ lemma endofunctor_R:
	+ shows "endofunctor V R"
	+ using hseqI' vseq_implies_hpar(1) whisker_right
	+ by (unfold_locales, auto)
	+
	+ end
	+
	+end
	diff --git a/thys/Bicategory/Pseudofunctor.thy b/thys/Bicategory/Pseudofunctor.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/Pseudofunctor.thy
	@@ -0,0 +1,5544 @@
	+(* Title: Pseudofunctor
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Pseudofunctors"
	+
	+theory Pseudofunctor
	+imports MonoidalCategory.MonoidalFunctor Bicategory Subbicategory InternalEquivalence
	+ Coherence
	+begin
	+
	+ text \<open>
	+ The traditional definition of a pseudofunctor \<open>F : C \<rightarrow> D\<close> between bicategories \<open>C\<close> and \<open>D\<close>
	+ is in terms of two maps: an ``object map'' \<open>F\<^sub>o\<close> that takes objects of \<open>C\<close> to objects of \<open>D\<close>
	+ and an ``arrow map'' \<open>F\<^sub>a\<close> that assigns to each pair of objects \<open>a\<close> and \<open>b\<close> of \<open>C\<close>
	+ a functor \<open>F\<^sub>a a b\<close> from the hom-category \<open>hom\<^sub>C a b\<close> to the hom-category \<open>hom\<^sub>D (F\<^sub>o a) (F\<^sub>o b)\<close>.
	+ In addition, there is assigned to each object \<open>a\<close> of \<open>C\<close> an invertible 2-cell
	+ \<open>\<guillemotleft>\<Psi> a : F\<^sub>o a \<Rightarrow>\<^sub>D (F\<^sub>a a a) a\<guillemotright>\<close>, and to each pair \<open>(f, g)\<close> of composable 1-cells of C there
	+ is assigned an invertible 2-cell \<open>\<guillemotleft>\<Phi> (f, g) : F g \<star> F f \<Rightarrow> F (g \<star> f)\<guillemotright>\<close>, all subject to
	+ naturality and coherence conditions.
	+
	+ In keeping with the ``object-free'' style in which we have been working, we do not wish
	+ to adopt a definition of pseudofunctor that distinguishes between objects and other
	+ arrows. Instead, we would like to understand a pseudofunctor as an ordinary functor between
	+ (vertical) categories that weakly preserves horizontal composition in a suitable sense.
	+ So, we take as a starting point that a pseudofunctor \<open>F : C \<rightarrow> D\<close> is a functor from
	+ \<open>C\<close> to \<open>D\<close>, when these are regarded as ordinary categories with respect to vertical
	+ composition. Next, \<open>F\<close> should preserve source and target, but only ``weakly''
	+ (up to isomorphism, rather than ``on the nose'').
	+ Weak preservation of horizontal composition is expressed by specifying, for each horizontally
	+ composable pair of vertical identities \<open>(f, g)\<close> of \<open>C\<close>, a ``compositor''
	+ \<open>\<guillemotleft>\<Phi> (f, g) : F g \<star> F f \<Rightarrow> F (g \<star> f)\<guillemotright>\<close> in \<open>D\<close>, such that the \<open>\<Phi> (f, g)\<close> are the components
	+ of a natural isomorphism.
	+ Associators must also be weakly preserved by F; this is expressed by a coherence
	+ condition that relates an associator \<open>\<a>\<^sub>C[f, g, h]\<close> in \<open>C\<close>, its image \<open>F \<a>\<^sub>C[f, g, h]\<close>,
	+ the associator \<open>\<a>\<^sub>D[F f, F g, F h]\<close> in \<open>D\<close> and compositors involving \<open>f\<close>, \<open>g\<close>, and \<open>h\<close>.
	+ As regards the weak preservation of unitors, just as for monoidal functors,
	+ which are in fact pseudofunctors between one-object bicategories, it is only necessary
	+ to assume that \<open>F \<i>\<^sub>C[a]\<close> and \<open>\<i>\<^sub>D[F a]\<close> are isomorphic in \<open>D\<close> for each object \<open>a\<close> of \<open>C\<close>,
	+ for there is then a canonical way to obtain, for each \<open>a\<close>, an isomorphism
	+ \<open>\<guillemotleft>\<Psi> a : src (F a) \<rightarrow> F a\<guillemotright>\<close> that satisfies the usual coherence conditions relating the
	+ unitors and the associators. Note that the map \<open>a \<mapsto> src (F a)\<close> amounts to the traditional
	+ ``object map'' \<open>F\<^sub>o\<close>, so that this becomes a derived notion, rather than a primitive one.
	+ \<close>
	+
	+ subsection "Weak Arrows of Homs"
	+
	+ text \<open>
	+ We begin with a locale that defines a functor between ``horizontal homs'' that preserves
	+ source and target up to isomorphism.
	+ \<close>
	+
	+ locale weak_arrow_of_homs =
	+ C: horizontal_homs C src\<^sub>C trg\<^sub>C +
	+ D: horizontal_homs D src\<^sub>D trg\<^sub>D +
	+ "functor" C D F
	+ for C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
	+ and src\<^sub>C :: "'c \<Rightarrow> 'c"
	+ and trg\<^sub>C :: "'c \<Rightarrow> 'c"
	+ and D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
	+ and src\<^sub>D :: "'d \<Rightarrow> 'd"
	+ and trg\<^sub>D :: "'d \<Rightarrow> 'd"
	+ and F :: "'c \<Rightarrow> 'd" +
	+ assumes weakly_preserves_src: "\<And>\<mu>. C.arr \<mu> \<Longrightarrow> D.isomorphic (F (src\<^sub>C \<mu>)) (src\<^sub>D (F \<mu>))"
	+ and weakly_preserves_trg: "\<And>\<mu>. C.arr \<mu> \<Longrightarrow> D.isomorphic (F (trg\<^sub>C \<mu>)) (trg\<^sub>D (F \<mu>))"
	+ begin
	+
	+ lemma isomorphic_src:
	+ assumes "C.obj a"
	+ shows "D.isomorphic (src\<^sub>D (F a)) (F a)"
	+ using assms weakly_preserves_src C.obj_def D.isomorphic_symmetric by force
	+
	+ lemma isomorphic_trg:
	+ assumes "C.obj a"
	+ shows "D.isomorphic (trg\<^sub>D (F a)) (F a)"
	+ using assms weakly_preserves_trg C.objE
	+ by (metis C.obj_def D.isomorphic_symmetric)
	+
	+ abbreviation (input) hseq\<^sub>C
	+ where "hseq\<^sub>C \<mu> \<nu> \<equiv> C.arr \<mu> \<and> C.arr \<nu> \<and> src\<^sub>C \<mu> = trg\<^sub>C \<nu>"
	+
	+ abbreviation (input) hseq\<^sub>D
	+ where "hseq\<^sub>D \<mu> \<nu> \<equiv> D.arr \<mu> \<and> D.arr \<nu> \<and> src\<^sub>D \<mu> = trg\<^sub>D \<nu>"
	+
	+ lemma preserves_hseq:
	+ assumes "hseq\<^sub>C \<mu> \<nu>"
	+ shows "hseq\<^sub>D (F \<mu>) (F \<nu>)"
	+ proof -
	+ have "src\<^sub>C \<mu> = trg\<^sub>C \<nu>"
	+ using assms by auto
	+ hence "D.isomorphic (F (src\<^sub>C \<mu>)) (trg\<^sub>D (F \<nu>))"
	+ using assms weakly_preserves_trg by auto
	+ moreover have "D.isomorphic (src\<^sub>D (F \<mu>)) (F (src\<^sub>C \<mu>))"
	+ using assms weakly_preserves_src D.isomorphic_symmetric by blast
	+ ultimately have "D.isomorphic (src\<^sub>D (F \<mu>)) (trg\<^sub>D (F \<nu>))"
	+ using D.isomorphic_transitive by blast
	+ hence "src\<^sub>D (F \<mu>) = trg\<^sub>D (F \<nu>)"
	+ using assms D.isomorphic_objects_are_equal by auto
	+ thus ?thesis
	+ using assms by auto
	+ qed
	+
	+ text \<open>
	+ Though \<open>F\<close> does not preserve objects ``on the nose'', we can recover from it the
	+ usual ``object map'', which does.
	+ It is slightly confusing at first to get used to the idea that applying the
	+ object map of a weak arrow of homs to an object does not give the same thing
	+ as applying the underlying functor, but rather only something isomorphic to it.
	+
	+ The following defines the object map associated with \<open>F\<close>.
	+ \<close>
	+
	+ definition map\<^sub>0
	+ where "map\<^sub>0 a \<equiv> src\<^sub>D (F a)"
	+
	+ lemma map\<^sub>0_simps [simp]:
	+ assumes "C.obj a"
	+ shows "D.obj (map\<^sub>0 a)"
	+ and "src\<^sub>D (map\<^sub>0 a) = map\<^sub>0 a" and "trg\<^sub>D (map\<^sub>0 a) = map\<^sub>0 a"
	+ and "D.dom (map\<^sub>0 a) = map\<^sub>0 a" and "D.cod (map\<^sub>0 a) = map\<^sub>0 a"
	+ using assms map\<^sub>0_def by auto
	+
	+ lemma preserves_src [simp]:
	+ assumes "C.arr \<mu>"
	+ shows "src\<^sub>D (F \<mu>) = map\<^sub>0 (src\<^sub>C \<mu>)"
	+ using assms
	+ by (metis C.src.preserves_arr C.src_src C.trg_src map\<^sub>0_def preserves_hseq)
	+
	+ lemma preserves_trg [simp]:
	+ assumes "C.arr \<mu>"
	+ shows "trg\<^sub>D (F \<mu>) = map\<^sub>0 (trg\<^sub>C \<mu>)"
	+ using assms map\<^sub>0_def preserves_hseq C.src_trg C.trg.preserves_arr by presburger
	+
	+ lemma preserves_hhom [intro]:
	+ assumes "C.arr \<mu>"
	+ shows "D.in_hhom (F \<mu>) (map\<^sub>0 (src\<^sub>C \<mu>)) (map\<^sub>0 (trg\<^sub>C \<mu>))"
	+ using assms by simp
	+
	+ interpretation CxC: product_category C C ..
	+ interpretation CC: subcategory CxC.comp
	+ \<open>\<lambda>\<mu>\<nu>. C.arr (fst \<mu>\<nu>) \<and> C.arr (snd \<mu>\<nu>) \<and> src\<^sub>C (fst \<mu>\<nu>) = trg\<^sub>C (snd \<mu>\<nu>)\<close>
	+ by (unfold_locales, auto)
	+ interpretation DxD: product_category D D ..
	+ interpretation DD: subcategory DxD.comp
	+ \<open>\<lambda>\<mu>\<nu>. D.arr (fst \<mu>\<nu>) \<and> D.arr (snd \<mu>\<nu>) \<and> src\<^sub>D (fst \<mu>\<nu>) = trg\<^sub>D (snd \<mu>\<nu>)\<close>
	+ by (unfold_locales, auto)
	+
	+ text \<open>
	+ We define here the lifting of \<open>F\<close> to a functor \<open>FF: CC \<rightarrow> DD\<close>.
	+ We need this to define the domains and codomains of the compositors.
	+ \<close>
	+
	+ definition FF
	+ where "FF \<equiv> \<lambda>\<mu>\<nu>. if CC.arr \<mu>\<nu> then (F (fst \<mu>\<nu>), F (snd \<mu>\<nu>)) else DD.null"
	+
	+ interpretation FF: "functor" CC.comp DD.comp FF
	+ proof -
	+ have 1: "\<And>\<mu>\<nu>. CC.arr \<mu>\<nu> \<Longrightarrow> DD.arr (FF \<mu>\<nu>)"
	+ unfolding FF_def using CC.arr_char DD.arr_char preserves_hseq by simp
	+ show "functor CC.comp DD.comp FF"
	+ proof
	+ fix \<mu>\<nu>
	+ show "\<not> CC.arr \<mu>\<nu> \<Longrightarrow> FF \<mu>\<nu> = DD.null"
	+ using FF_def by simp
	+ show "CC.arr \<mu>\<nu> \<Longrightarrow> DD.arr (FF \<mu>\<nu>)"
	+ using 1 by simp
	+ assume \<mu>\<nu>: "CC.arr \<mu>\<nu>"
	+ show "DD.dom (FF \<mu>\<nu>) = FF (CC.dom \<mu>\<nu>)"
	+ using \<mu>\<nu> 1 FF_def CC.arr_char DD.arr_char by simp
	+ show "DD.cod (FF \<mu>\<nu>) = FF (CC.cod \<mu>\<nu>)"
	+ using \<mu>\<nu> 1 FF_def CC.arr_char DD.arr_char by simp
	+ next
	+ fix \<mu>\<nu> \<tau>\<pi>
	+ assume 2: "CC.seq \<mu>\<nu> \<tau>\<pi>"
	+ show "FF (CC.comp \<mu>\<nu> \<tau>\<pi>) = DD.comp (FF \<mu>\<nu>) (FF \<tau>\<pi>)"
	+ proof -
	+ have "FF (CC.comp \<mu>\<nu> \<tau>\<pi>) = (F (fst \<mu>\<nu>) \<cdot>\<^sub>D F (fst \<tau>\<pi>), F (snd \<mu>\<nu>) \<cdot>\<^sub>D F (snd \<tau>\<pi>))"
	+ using 1 2 FF_def CC.comp_char CxC.comp_char CC.arr_char
	+ by (metis (no_types, lifting) CC.seq_char CxC.seqE fst_conv preserves_comp_2 snd_conv)
	+ also have "... = DD.comp (FF \<mu>\<nu>) (FF \<tau>\<pi>)"
	+ using 1 2 FF_def DD.comp_char DxD.comp_char CC.arr_char DD.arr_char
	+ CC.seq_char CxC.seqE preserves_seq
	+ by (simp, meson)
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+
	+ lemma functor_FF:
	+ shows "functor CC.comp DD.comp FF"
	+ ..
	+
	+ end
	+
	+ subsection "Definition of Pseudofunctors"
	+
	+ text \<open>
	+ I don't much like the term "pseudofunctor", which is suggestive of something that
	+ is ``not really'' a functor. In the development here we can see that a pseudofunctor
	+ is really a \emph{bona fide} functor with respect to vertical composition,
	+ which happens to have in addition a weak preservation property with respect to
	+ horizontal composition.
	+ This weak preservation of horizontal composition is captured by extra structure,
	+ the ``compositors'', which are the components of a natural transformation.
	+ So ``pseudofunctor'' is really a misnomer; it's an actual functor that has been equipped
	+ with additional structure relating to horizontal composition. I would use the term
	+ ``bifunctor'' for such a thing, but it seems to not be generally accepted and also tends
	+ to conflict with the usage of that term to refer to an ordinary functor of two
	+ arguments; which I have called a ``binary functor''. Sadly, there seem to be no other
	+ plausible choices of terminology, other than simply ``functor''
	+ (recommended on n-Lab @{url \<open>https://ncatlab.org/nlab/show/pseudofunctor\<close>}),
	+ but that is not workable here because we need a name that does not clash with that
	+ used for an ordinary functor between categories.
	+ \<close>
	+
	+ locale pseudofunctor =
	+ C: bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C +
	+ D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D +
	+ weak_arrow_of_homs V\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D src\<^sub>D trg\<^sub>D F +
	+ FoH\<^sub>C: composite_functor C.VV.comp V\<^sub>C V\<^sub>D \<open>\<lambda>\<mu>\<nu>. H\<^sub>C (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> F +
	+ H\<^sub>DoFF: composite_functor C.VV.comp D.VV.comp V\<^sub>D
	+ FF \<open>\<lambda>\<mu>\<nu>. H\<^sub>D (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> +
	+ \<Phi>: natural_isomorphism C.VV.comp V\<^sub>D H\<^sub>DoFF.map FoH\<^sub>C.map \<Phi>
	+ for V\<^sub>C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
	+ and H\<^sub>C :: "'c comp" (infixr "\<star>\<^sub>C" 53)
	+ and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c" ("\<a>\<^sub>C[_, _, _]")
	+ and \<i>\<^sub>C :: "'c \<Rightarrow> 'c" ("\<i>\<^sub>C[_]")
	+ and src\<^sub>C :: "'c \<Rightarrow> 'c"
	+ and trg\<^sub>C :: "'c \<Rightarrow> 'c"
	+ and V\<^sub>D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
	+ and H\<^sub>D :: "'d comp" (infixr "\<star>\<^sub>D" 53)
	+ and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd" ("\<a>\<^sub>D[_, _, _]")
	+ and \<i>\<^sub>D :: "'d \<Rightarrow> 'd" ("\<i>\<^sub>D[_]")
	+ and src\<^sub>D :: "'d \<Rightarrow> 'd"
	+ and trg\<^sub>D :: "'d \<Rightarrow> 'd"
	+ and F :: "'c \<Rightarrow> 'd"
	+ and \<Phi> :: "'c * 'c \<Rightarrow> 'd" +
	+ assumes assoc_coherence:
	+ "\<lbrakk> C.ide f; C.ide g; C.ide h; src\<^sub>C f = trg\<^sub>C g; src\<^sub>C g = trg\<^sub>C h \<rbrakk> \<Longrightarrow>
	+ F \<a>\<^sub>C[f, g, h] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) =
	+ \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
	+ begin
	+
	+ no_notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
	+ no_notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
	+ notation C.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
	+ notation C.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>C _\<guillemotright>")
	+ notation D.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
	+ notation D.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>D _\<guillemotright>")
	+
	+ notation C.lunit ("\<l>\<^sub>C[_]")
	+ notation C.runit ("\<r>\<^sub>C[_]")
	+ notation C.lunit' ("\<l>\<^sub>C\<^sup>-\<^sup>1[_]")
	+ notation C.runit' ("\<r>\<^sub>C\<^sup>-\<^sup>1[_]")
	+ notation C.\<a>' ("\<a>\<^sub>C\<^sup>-\<^sup>1[_, _, _]")
	+ notation D.lunit ("\<l>\<^sub>D[_]")
	+ notation D.runit ("\<r>\<^sub>D[_]")
	+ notation D.lunit' ("\<l>\<^sub>D\<^sup>-\<^sup>1[_]")
	+ notation D.runit' ("\<r>\<^sub>D\<^sup>-\<^sup>1[_]")
	+ notation D.\<a>' ("\<a>\<^sub>D\<^sup>-\<^sup>1[_, _, _]")
	+
	+ lemma weakly_preserves_objects:
	+ assumes "C.obj a"
	+ shows "D.isomorphic (map\<^sub>0 a) (F a)"
	+ using assms weakly_preserves_src [of a] D.isomorphic_symmetric by auto
	+
	+ lemma \<Phi>_in_hom [intro]:
	+ assumes "C.ide a" and "C.ide b" and "src\<^sub>C a = trg\<^sub>C b"
	+ shows "\<guillemotleft>\<Phi> (a, b) : map\<^sub>0 (src\<^sub>C b) \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C a)\<guillemotright>"
	+ and "\<guillemotleft>\<Phi> (a, b) : F a \<star>\<^sub>D F b \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C b)\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<Phi> (a, b) : F a \<star>\<^sub>D F b \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C b)\<guillemotright>"
	+ proof -
	+ have "H\<^sub>DoFF.map (a, b) = F a \<star>\<^sub>D F b"
	+ using assms C.VV.ide_char FF_def by auto
	+ moreover have "FoH\<^sub>C.map (a, b) = F (a \<star>\<^sub>C b)"
	+ using assms C.VV.ide_char by simp
	+ ultimately show ?thesis
	+ using assms C.VV.ide_char \<Phi>.preserves_hom
	+ apply simp
	+ by (metis (no_types, lifting) C.VV.ideI C.VV.ide_in_hom C.VxV.ide_Ide C.ideD(1)
	+ fst_conv snd_conv)
	+ qed
	+ show "\<guillemotleft>\<Phi> (a, b) : map\<^sub>0 (src\<^sub>C b) \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C a)\<guillemotright>"
	+ proof -
	+ have "C.hseq a b"
	+ by (simp add: assms(1-3))
	+ thus ?thesis
	+ by (metis C.src_hcomp' C.trg_hcomp' D.in_hhom_def D.in_homE D.src_cod D.trg_cod
	+ \<open>\<guillemotleft>\<Phi> (a, b) : F a \<star>\<^sub>D F b \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C b)\<guillemotright>\<close> preserves_src preserves_trg)
	+ qed
	+ qed
	+
	+ lemma \<Phi>_simps [simp]:
	+ assumes "C.ide f" and "C.ide g" and "src\<^sub>C f = trg\<^sub>C g"
	+ shows "D.arr (\<Phi> (f, g))"
	+ and "src\<^sub>D (\<Phi> (f, g)) = src\<^sub>D (F g)" and "trg\<^sub>D (\<Phi> (f, g)) = trg\<^sub>D (F f)"
	+ and "D.dom (\<Phi> (f, g)) = F f \<star>\<^sub>D F g" and "D.cod (\<Phi> (f, g)) = F (f \<star>\<^sub>C g)"
	+ and "D.iso (\<Phi> (f, g))"
	+ proof -
	+ show "D.arr (\<Phi> (f, g))"
	+ using assms \<Phi>_in_hom by auto
	+ show "src\<^sub>D (\<Phi> (f, g)) = src\<^sub>D (F g)"
	+ using assms \<Phi>_in_hom by auto
	+ show "trg\<^sub>D (\<Phi> (f, g)) = trg\<^sub>D (F f)"
	+ using assms \<Phi>_in_hom by auto
	+ show "D.dom (\<Phi> (f, g)) = F f \<star>\<^sub>D F g"
	+ using assms \<Phi>_in_hom by blast
	+ show "D.cod (\<Phi> (f, g)) = F (f \<star>\<^sub>C g)"
	+ using assms \<Phi>_in_hom by blast
	+ show "D.iso (\<Phi> (f, g))"
	+ using assms \<Phi>.components_are_iso C.VV.ide_char C.VV.arr_char by simp
	+ qed
	+
	+ lemma \<Phi>_components_are_iso:
	+ assumes "C.ide f" and "C.ide g" and "src\<^sub>C f = trg\<^sub>C g"
	+ shows "D.iso (\<Phi> (f, g))"
	+ using assms C.VV.ide_char C.VV.arr_char \<Phi>.components_are_iso by simp
	+
	+ lemma weakly_preserves_hcomp:
	+ assumes "C.ide f" and "C.ide g" and "src\<^sub>C f = trg\<^sub>C g"
	+ shows "D.isomorphic (F f \<star>\<^sub>D F g) (F (f \<star>\<^sub>C g))"
	+ using assms \<Phi>_in_hom \<Phi>_components_are_iso D.isomorphic_def by auto
	+
	+ text \<open>
	+ The following defines the image of the unit isomorphism \<open>\<i>\<^sub>C[a]\<close> under \<open>F\<close>.
	+ We will use \<open>(F a, \<i>[a])\<close> as an ``alternate unit'', to substitute for
	+ \<open>(src\<^sub>D (F a), \<i>\<^sub>D[src\<^sub>D (F a)])\<close>.
	+ \<close>
	+
	+ abbreviation (input) \<i> ("\<i>[_]")
	+ where "\<i>[a] \<equiv> F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a)"
	+
	+ lemma \<i>_in_hom [intro]:
	+ assumes "C.obj a"
	+ shows "\<guillemotleft>F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a) : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 a\<guillemotright>"
	+ and "\<guillemotleft>\<i>[a] : F a \<star>\<^sub>D F a \<Rightarrow>\<^sub>D F a\<guillemotright>"
	+ proof (unfold map\<^sub>0_def)
	+ show "\<guillemotleft>F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a) : F a \<star>\<^sub>D F a \<Rightarrow>\<^sub>D F a\<guillemotright>"
	+ using assms preserves_hom \<Phi>_in_hom
	+ by (intro D.comp_in_homI, auto)
	+ show "\<guillemotleft>F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a) : src\<^sub>D (F a) \<rightarrow>\<^sub>D src\<^sub>D (F a)\<guillemotright>"
	+ using assms C.VV.arr_char
	+ by (intro D.vcomp_in_hhom D.seqI, auto)
	+ qed
	+
	+ lemma \<i>_simps [simp]:
	+ assumes "C.obj a"
	+ shows "D.arr (\<i> a)"
	+ and "src\<^sub>D \<i>[a] = map\<^sub>0 a" and "trg\<^sub>D \<i>[a] = map\<^sub>0 a"
	+ and "D.dom \<i>[a] = F a \<star>\<^sub>D F a" and "D.cod \<i>[a] = F a"
	+ proof -
	+ show "src\<^sub>D \<i>[a] = map\<^sub>0 a"
	+ unfolding map\<^sub>0_def
	+ using assms \<i>_in_hom D.src_cod [of "F a"]
	+ by (metis C.unit_simps(1) C.unit_simps(5) D.arrI D.src_vcomp D.vseq_implies_hpar(1)
	+ is_natural_2 preserves_arr)
	+ show "trg\<^sub>D \<i>[a] = map\<^sub>0 a"
	+ unfolding map\<^sub>0_def
	+ using assms \<i>_in_hom D.trg_cod [of "F a"]
	+ by (metis C.obj_def C.unit_simps(1) C.unit_simps(3) D.arrI D.trg_vcomp preserves_hseq)
	+ show "D.arr \<i>[a]"
	+ using assms \<i>_in_hom by auto
	+ show "D.dom \<i>[a] = F a \<star>\<^sub>D F a"
	+ using assms \<i>_in_hom by auto
	+ show "D.cod \<i>[a] = F a"
	+ using assms \<i>_in_hom by auto
	+ qed
	+
	+ lemma iso_\<i>:
	+ assumes "C.obj a"
	+ shows "D.iso \<i>[a]"
	+ proof -
	+ have "D.iso (\<Phi> (a, a))"
	+ using assms \<Phi>_components_are_iso by auto
	+ moreover have "D.iso (F \<i>\<^sub>C[a])"
	+ using assms C.iso_unit preserves_iso by simp
	+ moreover have "D.seq (F \<i>\<^sub>C[a]) (\<Phi> (a, a))"
	+ using assms \<Phi>_in_hom C.unit_in_hom(2) C.obj_self_composable(1) C.seq_if_composable
	+ by blast
	+ ultimately show ?thesis by auto
	+ qed
	+
	+ end
	+
	+ context pseudofunctor
	+ begin
	+
	+ text \<open>
	+ If \<open>a\<close> is an object of \<open>C\<close> and we have an isomorphism \<open>\<guillemotleft>\<Phi> (a, a) : F a \<star>\<^sub>D F a \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C a)\<guillemotright>\<close>,
	+ then there is a canonical way to define a compatible isomorphism \<open>\<guillemotleft>\<Psi> a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>\<close>.
	+ Specifically, we take \<open>\<Psi> a\<close> to be the unique isomorphism \<open>\<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>\<close> such that
	+ \<open>\<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)\<close>.
	+ \<close>
	+
	+ definition \<Psi>
	+ where "\<Psi> a \<equiv> THE \<psi>. \<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<psi> \<and>
	+ \<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)"
	+
	+ lemma \<Psi>_char:
	+ assumes "C.obj a"
	+ shows "\<guillemotleft>\<Psi> a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>" and "D.iso (\<Psi> a)"
	+ and "\<Psi> a \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<Psi> a \<star>\<^sub>D \<Psi> a)"
	+ and "\<exists>!\<psi>. \<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)"
	+ proof -
	+ let ?P = "\<lambda>\<psi>. \<guillemotleft>\<psi> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D \<psi>)"
	+ show "\<exists>!\<psi>. ?P \<psi>"
	+ proof -
	+ have "D.obj (map\<^sub>0 a)"
	+ using assms by simp
	+ moreover have "D.isomorphic (map\<^sub>0 a) (F a)"
	+ unfolding map\<^sub>0_def
	+ using assms isomorphic_src by simp
	+ ultimately show ?thesis
	+ using assms D.unit_unique_upto_unique_iso \<Phi>.preserves_hom \<i>_in_hom iso_\<i> by simp
	+ qed
	+ hence 1: "?P (\<Psi> a)"
	+ using assms \<Psi>_def the1I2 [of ?P ?P] by simp
	+ show "\<guillemotleft>\<Psi> a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>" using 1 by simp
	+ show "D.iso (\<Psi> a)" using 1 by simp
	+ show "\<Psi> a \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<Psi> a \<star>\<^sub>D \<Psi> a)"
	+ using 1 by simp
	+ qed
	+
	+ lemma \<Psi>_simps [simp]:
	+ assumes "C.obj a"
	+ shows "D.arr (\<Psi> a)"
	+ and "src\<^sub>D (\<Psi> a) = map\<^sub>0 a" and "trg\<^sub>D (\<Psi> a) = map\<^sub>0 a"
	+ and "D.dom (\<Psi> a) = map\<^sub>0 a" and "D.cod (\<Psi> a) = F a"
	+ proof -
	+ show "D.arr (\<Psi> a)"
	+ using assms \<Psi>_char(1) by auto
	+ show 1: "D.dom (\<Psi> a) = map\<^sub>0 a"
	+ using assms \<Psi>_char(1) by auto
	+ show 2: "D.cod (\<Psi> a) = F a"
	+ using assms \<Psi>_char(1) by auto
	+ show "src\<^sub>D (\<Psi> a) = map\<^sub>0 a"
	+ using assms 1 D.src_dom
	+ unfolding map\<^sub>0_def
	+ by (metis C.obj_def D.arr_dom_iff_arr D.src.preserves_reflects_arr D.src_src preserves_arr)
	+ show "trg\<^sub>D (\<Psi> a) = map\<^sub>0 a"
	+ unfolding map\<^sub>0_def
	+ using assms 2 \<Psi>_char
	+ by (metis "1" D.trg_dom map\<^sub>0_def map\<^sub>0_simps(3) \<open>D.arr (\<Psi> a)\<close>)
	+ qed
	+
	+ lemma \<Psi>_in_hom [intro]:
	+ assumes "C.obj a"
	+ shows "\<guillemotleft>\<Psi> a : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 a\<guillemotright>"
	+ and "\<guillemotleft>\<Psi> a : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>"
	+ using assms by auto
	+
	+ lemma \<Psi>_eqI:
	+ assumes "C.obj a" and "\<guillemotleft>\<mu>: map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright>" and "D.iso \<mu>"
	+ and "\<mu> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i> a \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D \<mu>)"
	+ shows "\<mu> = \<Psi> a"
	+ using assms \<Psi>_def \<Psi>_char
	+ the1_equality [of "\<lambda>\<mu>. \<guillemotleft>\<mu> : map\<^sub>0 a \<Rightarrow>\<^sub>D F a\<guillemotright> \<and> D.iso \<mu> \<and>
	+ \<mu> \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = \<i>[a] \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D \<mu>)" \<mu>]
	+ by simp
	+
	+ text \<open>
	+ The following defines the unique isomorphism satisfying the characteristic conditions
	+ for the left unitor \<open>\<l>\<^sub>D[trg\<^sub>D (F f)]\<close>, but using the ``alternate unit'' \<open>\<i>[trg\<^sub>C f]\<close>
	+ instead of \<open>\<i>\<^sub>D[trg\<^sub>D (F f)]\<close>, which is used to define \<open>\<l>\<^sub>D[trg\<^sub>D (F f)]\<close>.
	+ \<close>
	+
	+ definition lF
	+ where "lF f \<equiv> THE \<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and>
	+ F (trg\<^sub>C f) \<star>\<^sub>D \<mu> =(\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
	+
	+ lemma lF_char:
	+ assumes "C.ide f"
	+ shows "\<guillemotleft>lF f : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright>"
	+ and "F (trg\<^sub>C f) \<star>\<^sub>D lF f = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
	+ and "\<exists>!\<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and>
	+ F (trg\<^sub>C f) \<star>\<^sub>D \<mu> = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
	+ proof -
	+ let ?P = "\<lambda>\<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and>
	+ F (trg\<^sub>C f) \<star>\<^sub>D \<mu> = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
	+ show "\<exists>!\<mu>. ?P \<mu>"
	+ proof -
	+ interpret Df: prebicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D
	+ using D.is_prebicategory by simp
	+ interpret S: subcategory \<open>(\<cdot>\<^sub>D)\<close> \<open>Df.left (F (trg\<^sub>C f))\<close>
	+ using assms Df.left_hom_is_subcategory by simp
	+ interpret Df: left_hom \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<open>F (trg\<^sub>C f)\<close>
	+ using assms D.weak_unit_char
	+ apply unfold_locales by simp
	+ interpret Df: left_hom_with_unit \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<open>\<i>[trg\<^sub>C f]\<close> \<open>F (trg\<^sub>C f)\<close>
	+ proof
	+ show "Df.weak_unit (F (trg\<^sub>C f))"
	+ using assms D.weak_unit_char
	+ by (metis C.ideD(1) C.trg.preserves_reflects_arr C.trg_trg weakly_preserves_trg)
	+ show "\<guillemotleft>\<i>[trg\<^sub>C f] : F (trg\<^sub>C f) \<star>\<^sub>D F (trg\<^sub>C f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
	+ using assms \<i>_in_hom by simp
	+ show "D.iso \<i>[trg\<^sub>C f]"
	+ using assms iso_\<i> by simp
	+ qed
	+ have "\<exists>!\<mu>. \<guillemotleft>\<mu> : Df.L (F f) \<Rightarrow>\<^sub>S F f\<guillemotright> \<and>
	+ Df.L \<mu> = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>S \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
	+ proof -
	+ have "Df.left (F (trg\<^sub>C f)) (F f)"
	+ using assms weakly_preserves_src D.isomorphic_def D.hseq_char D.hseq_char'
	+ Df.left_def
	+ by fastforce
	+ thus ?thesis
	+ using assms Df.lunit_char(3) S.ide_char S.arr_char by simp
	+ qed
	+ moreover have "Df.L (F f) = F (trg\<^sub>C f) \<star>\<^sub>D F f"
	+ using assms by (simp add: Df.H\<^sub>L_def)
	+ moreover have "\<And>\<mu>. Df.L \<mu> = F (trg\<^sub>C f) \<star>\<^sub>D \<mu>"
	+ using Df.H\<^sub>L_def by simp
	+ moreover have "(\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>S \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f] =
	+ (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
	+ by (metis (no_types, lifting) D.assoc'_eq_inv_assoc D.ext D.hseqE D.seqE
	+ D.vconn_implies_hpar(1) D.vconn_implies_hpar(3) Df.characteristic_iso(4)
	+ Df.equivalence_functor_L Df.iso_unit(2) S.comp_simp S.ext S.ide_char
	+ S.in_hom_char S.iso_is_arr S.null_char calculation(1) category.ide_cod
	+ category.in_homE equivalence_functor_def)
	+ moreover have "\<And>\<mu>. \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<longleftrightarrow>
	+ \<guillemotleft>\<mu> : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>S F f\<guillemotright>"
	+ using assms S.in_hom_char S.arr_char
	+ by (metis D.in_homE Df.hom_connected(2) Df.left_def calculation(1) calculation(2))
	+ ultimately show ?thesis by simp
	+ qed
	+ hence 1: "?P (lF f)"
	+ using lF_def the1I2 [of ?P ?P] by simp
	+ show "\<guillemotleft>lF f : F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright>"
	+ using 1 by simp
	+ show "F (trg\<^sub>C f) \<star>\<^sub>D lF f = (\<i>[trg\<^sub>C f] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F (trg\<^sub>C f), F (trg\<^sub>C f), F f]"
	+ using 1 by simp
	+ qed
	+
	+ lemma lF_simps [simp]:
	+ assumes "C.ide f"
	+ shows "D.arr (lF f)"
	+ and "src\<^sub>D (lF f) = map\<^sub>0 (src\<^sub>C f)" and "trg\<^sub>D (lF f) = map\<^sub>0 (trg\<^sub>C f)"
	+ and "D.dom (lF f) = F (trg\<^sub>C f) \<star>\<^sub>D F f" and "D.cod (lF f) = F f"
	+ proof -
	+ show "D.arr (lF f)"
	+ using assms lF_char(1) by auto
	+ show "D.dom (lF f) = F (trg\<^sub>C f) \<star>\<^sub>D F f"
	+ using assms lF_char(1) by auto
	+ show "D.cod (lF f) = F f"
	+ using assms lF_char(1) by auto
	+ show "src\<^sub>D (lF f) = map\<^sub>0 (src\<^sub>C f)"
	+ unfolding map\<^sub>0_def
	+ using assms \<open>D.arr (lF f)\<close> \<open>D.cod (lF f) = F f\<close> D.src_cod by fastforce
	+ show "trg\<^sub>D (lF f) = map\<^sub>0 (trg\<^sub>C f)"
	+ using assms \<open>D.arr (lF f)\<close> \<open>D.cod (lF f) = F f\<close> D.trg_cod by fastforce
	+ qed
	+
	+ text \<open>
	+ \sloppypar
	+ The next two lemmas generalize the eponymous results from
	+ @{theory MonoidalCategory.MonoidalFunctor}. See the proofs of those results for diagrams.
	+ \<close>
	+
	+ lemma lunit_coherence1:
	+ assumes "C.ide f"
	+ shows "\<l>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) = lF f"
	+ proof -
	+ let ?b = "trg\<^sub>C f"
	+ have 1: "trg\<^sub>D (F f) = map\<^sub>0 ?b"
	+ using assms by simp
	+ have "lF f \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D F f) = \<l>\<^sub>D[F f]"
	+ proof -
	+ have "D.par (lF f \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D F f)) \<l>\<^sub>D[F f]"
	+ using assms 1 D.lunit_in_hom \<Psi>_char(1-2) lF_char(1) D.ideD(1) D.hseqI'
	+ by auto
	+ moreover have "map\<^sub>0 ?b \<star>\<^sub>D (lF f \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D F f)) = map\<^sub>0 ?b \<star>\<^sub>D \<l>\<^sub>D[F f]"
	+ proof -
	+ have "map\<^sub>0 ?b \<star>\<^sub>D (lF f \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D F f)) =
	+ (map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (map\<^sub>0 ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f)"
	+ using assms D.objE [of "map\<^sub>0 (trg\<^sub>C f)"] D.hseqI'
	+ D.whisker_left [of "map\<^sub>0 ?b" "lF f" "\<Psi> ?b \<star>\<^sub>D F f"]
	+ by auto
	+ also have "... = (map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D
	+ (D.inv (\<Psi> ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f)"
	+ proof -
	+ have "(D.inv (\<Psi> ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f) =
	+ D.inv (\<Psi> ?b) \<cdot>\<^sub>D \<Psi> ?b \<star>\<^sub>D F ?b \<cdot>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f \<cdot>\<^sub>D F f"
	+ using assms \<Psi>_char(1-2) D.hseqI'
	+ D.interchange [of "F ?b" "\<Psi> ?b" "F f" "F f"]
	+ D.interchange [of "D.inv (\<Psi> ?b)" "\<Psi> ?b" "F ?b \<star>\<^sub>D F f" "\<Psi> ?b \<star>\<^sub>D F f"]
	+ by simp
	+ also have "... = map\<^sub>0 ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f"
	+ using assms \<Psi>_char(1-2) [of ?b] D.comp_arr_dom D.comp_cod_arr D.comp_inv_arr
	+ by (simp add: D.inv_is_inverse)
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = (D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (\<Psi> ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f)"
	+ proof -
	+ have "(map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (D.inv (\<Psi> ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) =
	+ (D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
	+ proof -
	+ have "(map\<^sub>0 ?b \<star>\<^sub>D lF f) \<cdot>\<^sub>D (D.inv (\<Psi> ?b) \<star>\<^sub>D F ?b \<star>\<^sub>D F f) = D.inv (\<Psi> ?b) \<star>\<^sub>D lF f"
	+ using assms \<Psi>_char(1-2) lF_char(1) D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of "map\<^sub>0 ?b" "D.inv (\<Psi> ?b)" "lF f" "F ?b \<star>\<^sub>D F f"]
	+ by simp
	+ also have "... = D.inv (\<Psi> ?b) \<cdot>\<^sub>D F ?b \<star>\<^sub>D F f \<cdot>\<^sub>D lF f"
	+ using assms \<Psi>_char(1-2) lF_char(1) D.comp_arr_dom D.comp_cod_arr
	+ D.inv_in_hom
	+ by auto
	+ also have "... = (D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
	+ using assms \<Psi>_char(1-2) lF_char(1) D.inv_in_hom
	+ D.interchange [of "D.inv (\<Psi> ?b)" "F ?b" "F f" "lF f"]
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using assms \<Psi>_char(1-2) D.inv_in_hom D.comp_assoc by metis
	+ qed
	+ also have "... = (D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f] \<cdot>\<^sub>D
	+ (\<Psi> ?b \<star>\<^sub>D \<Psi> ?b \<star>\<^sub>D F f)"
	+ using assms \<Psi>_char(1-2) lF_char(2) D.comp_assoc by auto
	+ also have "... = ((D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D ((\<Psi> ?b \<star>\<^sub>D \<Psi> ?b) \<star>\<^sub>D F f))
	+ \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[map\<^sub>0 ?b, map\<^sub>0 ?b, F f]"
	+ using assms \<Psi>_char(1-2) D.assoc'_naturality [of "\<Psi> ?b" "\<Psi> ?b" "F f"] D.comp_assoc
	+ by (simp add: \<open>trg\<^sub>D (F f) = map\<^sub>0 (trg\<^sub>C f)\<close>)
	+ also have "... = (\<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[map\<^sub>0 ?b, map\<^sub>0 ?b, F f]"
	+ proof -
	+ have "((D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D ((\<Psi> ?b \<star>\<^sub>D \<Psi> ?b) \<star>\<^sub>D F f)) =
	+ \<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f"
	+ proof -
	+ have "((D.inv (\<Psi> ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D ((\<Psi> ?b \<star>\<^sub>D \<Psi> ?b) \<star>\<^sub>D F f)) =
	+ D.inv (\<Psi> ?b) \<cdot>\<^sub>D \<Psi> ?b \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f"
	+ using assms 1 D.unit_in_hom D.whisker_right [of "F f"] \<Psi>_char(2-3)
	+ D.invert_side_of_triangle(1)
	+ by (metis C.ideD(1) C.obj_trg D.seqI' map\<^sub>0_simps(1) \<Psi>_in_hom(2) preserves_ide)
	+ also have "... = \<i>\<^sub>D[map\<^sub>0 ?b] \<star>\<^sub>D F f"
	+ proof -
	+ have "(D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D \<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 ?b] = \<i>\<^sub>D[map\<^sub>0 ?b]"
	+ by (simp add: D.comp_cod_arr D.comp_inv_arr D.inv_is_inverse \<Psi>_char(2) assms)
	+ thus ?thesis
	+ by (simp add: D.comp_assoc)
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = map\<^sub>0 ?b \<star>\<^sub>D \<l>\<^sub>D[F f]"
	+ using assms D.lunit_char [of "F f"] \<open>trg\<^sub>D (F f) = map\<^sub>0 ?b\<close> by simp
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis
	+ using assms D.L.is_faithful
	+ by (metis D.trg_cod D.trg_vcomp D.vseq_implies_hpar(2) lF_simps(3))
	+ qed
	+ thus ?thesis
	+ using assms 1 \<Psi>_char(1-2) C.ideD(1) C.obj_trg D.inverse_arrows_hcomp(1)
	+ D.invert_side_of_triangle(2) D.lunit_simps(1) \<Psi>_simps(2) preserves_ide
	+ D.iso_hcomp components_are_iso
	+ by metis
	+ qed
	+
	+ lemma lunit_coherence2:
	+ assumes "C.ide f"
	+ shows "lF f = F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)"
	+ proof -
	+ let ?b = "trg\<^sub>C f"
	+ have "D.par (F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (?b, f)) (lF f)"
	+ using assms \<Phi>_in_hom [of ?b f] lF_simps by auto
	+ moreover have "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (?b, f) = F ?b \<star>\<^sub>D lF f"
	+ proof -
	+ have "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (?b, f) = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D \<Phi> (?b, f))"
	+ using assms \<Phi>_in_hom D.whisker_left [of "F ?b" "F \<l>\<^sub>C[f]" "\<Phi> (?b, f)"]
	+ by (simp add: calculation)
	+ also have "... = F ?b \<star>\<^sub>D lF f"
	+ proof -
	+ have "(F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D \<Phi> (?b, f))
	+ = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D
	+ \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
	+ proof -
	+ have 1: "D.seq (F \<a>\<^sub>C[trg\<^sub>C f, trg\<^sub>C f, f])
	+ (\<Phi> (trg\<^sub>C f \<star>\<^sub>C trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Phi> (trg\<^sub>C f, trg\<^sub>C f) \<star>\<^sub>D F f))"
	+ using assms \<Phi>_in_hom by fastforce
	+ hence 2: "D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D
	+ (\<Phi> (?b, ?b) \<star>\<^sub>D F f)
	+ = (F ?b \<star>\<^sub>D \<Phi> (?b, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F ?b, F ?b, F f]"
	+ using assms \<Phi>_in_hom assoc_coherence \<Phi>_components_are_iso
	+ D.invert_side_of_triangle(1)
	+ [of "F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f)"
	+ "\<Phi> (?b, ?b \<star>\<^sub>C f)"
	+ "(F ?b \<star>\<^sub>D \<Phi> (?b, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F ?b, F ?b, F f]"]
	+ C.ideD(1) C.ide_hcomp C.trg_hcomp' C.trg_trg C.src_trg C.trg.preserves_ide
	+ by metis
	+ hence "F ?b \<star>\<^sub>D \<Phi> (?b, f)
	+ = (D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D
	+ (\<Phi> (?b, ?b) \<star>\<^sub>D F f)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
	+ proof -
	+ have "D.seq (D.inv (\<Phi> (trg\<^sub>C f, trg\<^sub>C f \<star>\<^sub>C f)))
	+ (F \<a>\<^sub>C[trg\<^sub>C f, trg\<^sub>C f, f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f \<star>\<^sub>C trg\<^sub>C f, f) \<cdot>\<^sub>D
	+ (\<Phi> (trg\<^sub>C f, trg\<^sub>C f) \<star>\<^sub>D F f))"
	+ using assms 1 \<Phi>_in_hom \<Phi>_components_are_iso preserves_hseq preserves_inv
	+ preserves_iso D.hseq_char
	+ by auto
	+ moreover have "(F (trg\<^sub>C f) \<star>\<^sub>D \<Phi> (trg\<^sub>C f, f)) \<cdot>\<^sub>D \<a>\<^sub>D[F (trg\<^sub>C f), F (trg\<^sub>C f), F f] =
	+ D.inv (\<Phi> (trg\<^sub>C f, trg\<^sub>C f \<star>\<^sub>C f)) \<cdot>\<^sub>D
	+ F \<a>\<^sub>C[trg\<^sub>C f, trg\<^sub>C f, f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f \<star>\<^sub>C trg\<^sub>C f, f) \<cdot>\<^sub>D
	+ (\<Phi> (trg\<^sub>C f, trg\<^sub>C f) \<star>\<^sub>D F f)"
	+ using assms 2 \<Phi>_in_hom by simp
	+ ultimately show ?thesis
	+ using assms \<Phi>_components_are_iso D.iso_assoc
	+ D.invert_side_of_triangle(2)
	+ [of "D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D
	+ (\<Phi> (?b, ?b) \<star>\<^sub>D F f)"
	+ "F ?b \<star>\<^sub>D \<Phi> (?b, f)" "\<a>\<^sub>D[F ?b, F ?b, F f]"]
	+ by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
	+ (D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D F (\<i>\<^sub>C[?b] \<star>\<^sub>C f)) \<cdot>\<^sub>D
	+ \<Phi> (?b \<star>\<^sub>C ?b, f) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
	+ proof -
	+ have 1: "F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) = F (\<i>\<^sub>C[?b] \<star>\<^sub>C f) \<cdot>\<^sub>D D.inv (F \<a>\<^sub>C[?b, ?b, f])"
	+ using assms C.lunit_char(1-2) C.unit_in_hom preserves_inv C.hseqI' by auto
	+ have "F \<a>\<^sub>C[?b, ?b, f] = D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D F (\<i>\<^sub>C[?b] \<star>\<^sub>C f)"
	+ proof -
	+ have "F \<a>\<^sub>C[?b, ?b, f] \<cdot>\<^sub>D D.inv (F (\<i>\<^sub>C[?b] \<star>\<^sub>C f)) =
	+ D.inv (F (\<i>\<^sub>C[?b] \<star>\<^sub>C f) \<cdot>\<^sub>D D.inv (F \<a>\<^sub>C[?b, ?b, f]))"
	+ using assms D.iso_inv_iso
	+ by (simp add: C.hseqI' C.iso_unit D.inv_comp)
	+ thus ?thesis
	+ using assms 1 D.invert_side_of_triangle D.iso_inv_iso
	+ by (metis C.iso_hcomp C.ideD(1) C.ide_is_iso C.iso_lunit C.iso_unit
	+ C.lunit_simps(3) C.obj_trg C.src_trg C.trg.components_are_iso
	+ C.unit_simps(2) D.arr_inv D.inv_inv preserves_iso)
	+ qed
	+ thus ?thesis by argo
	+ qed
	+ also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
	+ D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D (F (\<i>\<^sub>C[?b] \<star>\<^sub>C f) \<cdot>\<^sub>D \<Phi> (?b \<star>\<^sub>C ?b, f)) \<cdot>\<^sub>D
	+ (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
	+ using D.comp_assoc by auto
	+ also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
	+ D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D (\<Phi> (?b, f) \<cdot>\<^sub>D (F \<i>\<^sub>C[?b] \<star>\<^sub>D F f)) \<cdot>\<^sub>D
	+ (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
	+ using assms \<Phi>.naturality [of "(\<i>\<^sub>C[?b], f)"] FF_def C.VV.arr_char C.VV.cod_char
	+ C.VV.dom_char
	+ by simp
	+ also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
	+ D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f) \<cdot>\<^sub>D
	+ ((F \<i>\<^sub>C[?b] \<star>\<^sub>D F f)) \<cdot>\<^sub>D (\<Phi> (?b, ?b) \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
	+ using D.comp_assoc by auto
	+ also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D
	+ D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f) \<cdot>\<^sub>D (\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f]"
	+ using assms by (simp add: D.comp_assoc D.whisker_right)
	+ also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f)) \<cdot>\<^sub>D
	+ (F ?b \<star>\<^sub>D lF f)"
	+ proof -
	+ have "(\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f] = F ?b \<star>\<^sub>D lF f"
	+ using assms lF_char by auto
	+ thus ?thesis
	+ using assms D.inv_is_inverse \<i>_in_hom \<Phi>_in_hom D.invert_side_of_triangle(2)
	+ by (simp add: D.comp_assoc)
	+ qed
	+ also have "... = (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
	+ proof -
	+ have "D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) =
	+ D.inv (((F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f))) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
	+ proof -
	+ have "D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f) = F ?b \<star>\<^sub>D F (?b \<star>\<^sub>C f)"
	+ using assms D.comp_inv_arr \<Phi>_components_are_iso D.comp_inv_arr' \<Phi>_simps(4)
	+ by auto
	+ thus ?thesis
	+ using assms D.comp_arr_dom D.comp_assoc D.hseqI' by simp
	+ qed
	+ also have "... = D.inv (D.inv (\<Phi> (?b, f)) \<cdot>\<^sub>D F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
	+ proof -
	+ have 1: "\<Phi> (?b, f) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) = F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f)"
	+ using assms \<Phi>.naturality [of "(?b, \<l>\<^sub>C[f])"] FF_def C.VV.arr_char
	+ C.VV.cod_char D.VV.null_char
	+ by simp
	+ have "(F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) =
	+ D.inv (\<Phi> (?b, f)) \<cdot>\<^sub>D F (?b \<star>\<^sub>C \<l>\<^sub>C[f])"
	+ proof -
	+ have "D.seq (\<Phi> (?b, f)) (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f])"
	+ using assms \<Phi>_in_hom(2) [of ?b f] D.hseqI' by auto
	+ moreover have "D.iso (\<Phi> (?b, f)) \<and> D.iso (\<Phi> (?b, ?b \<star>\<^sub>C f))"
	+ using assms \<Phi>_components_are_iso by simp
	+ ultimately show ?thesis
	+ using 1 D.invert_opposite_sides_of_square
	+ [of "\<Phi> (?b, f)" "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]" "F (?b \<star>\<^sub>C \<l>\<^sub>C[f])" "\<Phi> (?b, ?b \<star>\<^sub>C f)"]
	+ by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by auto
	+ qed
	+ also have "... = D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D \<Phi> (?b, f)"
	+ proof -
	+ have "D.iso (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
	+ using assms \<Phi>_components_are_iso D.isos_compose C.VV.arr_char C.iso_lunit
	+ C.hseqI'
	+ by simp
	+ moreover have "D.iso (D.inv (\<Phi> (?b, f)))"
	+ using assms D.iso_inv_iso by simp
	+ moreover have "D.seq (D.inv (\<Phi> (?b, f))) (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f))"
	+ using assms \<Phi>_in_hom(2) [of ?b f] \<Phi>_components_are_iso C.VV.arr_char C.hseqI'
	+ by simp
	+ ultimately show ?thesis
	+ using assms \<Phi>_components_are_iso D.inv_comp by simp
	+ qed
	+ also have "... = D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f)"
	+ proof -
	+ have "D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f)) =
	+ D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]))"
	+ using assms \<Phi>_components_are_iso D.isos_compose C.VV.arr_char C.iso_lunit
	+ D.inv_comp C.hseqI'
	+ by simp
	+ thus ?thesis using D.comp_assoc by simp
	+ qed
	+ finally have "D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f])
	+ = D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f])) \<cdot>\<^sub>D \<Phi> (?b, f)"
	+ by blast
	+ thus ?thesis by argo
	+ qed
	+ also have "... = ((F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]) \<cdot>\<^sub>D D.inv (F ?b \<star>\<^sub>D F \<l>\<^sub>C[f])) \<cdot>\<^sub>D (F ?b \<star>\<^sub>D lF f)"
	+ using D.comp_assoc by simp
	+ also have "... = F ?b \<star>\<^sub>D lF f"
	+ using assms D.comp_arr_inv' [of "F ?b \<star>\<^sub>D F \<l>\<^sub>C[f]"] D.comp_cod_arr preserves_iso
	+ D.hseqI'
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using assms D.L.is_faithful
	+ by (metis D.in_homI lF_char(2-3) lF_simps(4-5))
	+ qed
	+
	+ lemma lunit_coherence:
	+ assumes "C.ide f"
	+ shows "\<l>\<^sub>D[F f] = F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"
	+ proof -
	+ have 1: "\<l>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) = F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)"
	+ using assms lunit_coherence1 lunit_coherence2 by simp
	+ have "\<l>\<^sub>D[F f] = (F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"
	+ proof -
	+ have "D.seq (F \<l>\<^sub>C[f]) (\<Phi> (trg\<^sub>C f, f))"
	+ using assms \<Phi>_in_hom [of "trg\<^sub>C f" f] C.unit_in_vhom by auto
	+ moreover have "D.iso (D.inv (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f))"
	+ using assms \<Psi>_char D.iso_inv_iso \<Psi>_char(1-2)
	+ by (simp add: preserves_hseq)
	+ ultimately show ?thesis
	+ using assms 1 \<Psi>_char(2) D.iso_inv_iso \<Phi>_in_hom D.inv_inv
	+ D.invert_side_of_triangle(2)
	+ [of "F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)" "\<l>\<^sub>D[F f]" "D.inv (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"]
	+ by auto
	+ qed
	+ thus ?thesis
	+ using assms \<Psi>_char(1) D.comp_assoc by auto
	+ qed
	+
	+ text \<open>
	+ We postpone proving the dual version of this result until after we have developed
	+ the notion of the ``op bicategory'' in the next section.
	+ \<close>
	+
	+ end
	+
	+ subsection "Pseudofunctors and Opposite Bicategories"
	+
	+ text \<open>
	+ There are three duals to a bicategory:
	+ \begin{enumerate}
	+ \item ``op'': sources and targets are exchanged;
	+ \item ``co'': domains and codomains are exchanged;
	+ \item ``co-op'': both sources and targets and domains and codomains are exchanged.
	+ \end{enumerate}
	+ Here we consider the "op" case.
	+ \<close>
	+
	+ locale op_bicategory =
	+ B: bicategory V H\<^sub>B \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H\<^sub>B :: "'a comp" (infixr "\<star>\<^sub>B" 53)
	+ and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>\<^sub>B[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src\<^sub>B :: "'a \<Rightarrow> 'a"
	+ and trg\<^sub>B :: "'a \<Rightarrow> 'a"
	+ begin
	+
	+ abbreviation H (infixr "\<star>" 53)
	+ where "H f g \<equiv> H\<^sub>B g f"
	+
	+ abbreviation src
	+ where "src \<equiv> trg\<^sub>B"
	+
	+ abbreviation trg
	+ where "trg \<equiv> src\<^sub>B"
	+
	+ interpretation H: horizontal_homs V src trg
	+ by (unfold_locales, auto)
	+
	+ interpretation VV: subcategory B.VxV.comp
	+ \<open>\<lambda>\<mu>\<nu>. B.arr (fst \<mu>\<nu>) \<and> B.arr (snd \<mu>\<nu>) \<and> src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)\<close>
	+ by (unfold_locales, auto)
	+
	+ interpretation H: "functor" VV.comp V \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
	+ using VV.arr_char B.hseqI'
	+ apply unfold_locales
	+ apply (metis (no_types, lifting) B.hseqE B.hseq_char')
	+ apply auto[3]
	+ using VV.comp_char VV.seq_char VV.arr_char B.VxV.comp_char B.interchange
	+ by (metis (no_types, lifting) B.VxV.seqE fst_conv snd_conv)
	+
	+ interpretation horizontal_composition V H src trg
	+ by (unfold_locales, simp_all)
	+
	+ interpretation VVV: subcategory B.VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. B.arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and> src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using H.subcategory_VVV by auto
	+
	+ interpretation "functor" VVV.comp V HoHV
	+ using functor_HoHV by auto
	+ interpretation "functor" VVV.comp V HoVH
	+ using functor_HoVH by auto
	+
	+ abbreviation UP
	+ where "UP \<mu>\<nu>\<tau> \<equiv> if B.VVV.arr \<mu>\<nu>\<tau> then
	+ (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)
	+ else VVV.null"
	+
	+ abbreviation DN
	+ where "DN \<mu>\<nu>\<tau> \<equiv> if VVV.arr \<mu>\<nu>\<tau> then
	+ (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)
	+ else B.VVV.null"
	+
	+ lemma VVV_arr_char:
	+ shows "VVV.arr \<mu>\<nu>\<tau> \<longleftrightarrow> B.VVV.arr (DN \<mu>\<nu>\<tau>)"
	+ using VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char B.VVV.not_arr_null
	+ by auto
	+
	+ lemma VVV_ide_char:
	+ shows "VVV.ide \<mu>\<nu>\<tau> \<longleftrightarrow> B.VVV.ide (DN \<mu>\<nu>\<tau>)"
	+ proof -
	+ have "VVV.ide \<mu>\<nu>\<tau> \<longleftrightarrow> VVV.arr \<mu>\<nu>\<tau> \<and> B.VxVxV.ide \<mu>\<nu>\<tau>"
	+ using VVV.ide_char by simp
	+ also have "... \<longleftrightarrow> B.VVV.arr (DN \<mu>\<nu>\<tau>) \<and> B.VxVxV.ide (DN \<mu>\<nu>\<tau>)"
	+ using VVV_arr_char B.VxVxV.ide_char by auto
	+ also have "... \<longleftrightarrow> B.VVV.ide (DN \<mu>\<nu>\<tau>)"
	+ using B.VVV.ide_char [of "DN \<mu>\<nu>\<tau>"] by blast
	+ finally show ?thesis by fast
	+ qed
	+
	+ lemma VVV_dom_char:
	+ shows "VVV.dom \<mu>\<nu>\<tau> = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
	+ proof (cases "VVV.arr \<mu>\<nu>\<tau>")
	+ show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.dom \<mu>\<nu>\<tau> = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
	+ using VVV.dom_def VVV.has_domain_iff_arr VVV_arr_char B.VVV.dom_null
	+ by auto
	+ show "VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.dom \<mu>\<nu>\<tau> = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
	+ proof -
	+ assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
	+ have "VVV.dom \<mu>\<nu>\<tau> =
	+ (B.dom (fst \<mu>\<nu>\<tau>), B.dom (fst (snd \<mu>\<nu>\<tau>)), B.dom (snd (snd \<mu>\<nu>\<tau>)))"
	+ using \<mu>\<nu>\<tau> VVV.dom_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
	+ by simp
	+ also have "... = UP (B.dom (snd (snd \<mu>\<nu>\<tau>)), B.dom (fst (snd \<mu>\<nu>\<tau>)), B.dom (fst \<mu>\<nu>\<tau>))"
	+ using \<mu>\<nu>\<tau> VVV_arr_char B.VV.arr_char B.VVV.arr_char B.arr_dom_iff_arr H.src_dom
	+ H.trg_dom
	+ apply simp
	+ by (metis (no_types, lifting) H.src_dom H.trg_dom VV.arrE VVV.arrE)
	+ also have "... = UP (B.VVV.dom (DN \<mu>\<nu>\<tau>))"
	+ using \<mu>\<nu>\<tau> B.VVV.dom_char B.VVV.arr_char B.VV.arr_char VVV.arr_char VV.arr_char
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+
	+ lemma VVV_cod_char:
	+ shows "VVV.cod \<mu>\<nu>\<tau> = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
	+ proof (cases "VVV.arr \<mu>\<nu>\<tau>")
	+ show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.cod \<mu>\<nu>\<tau> = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
	+ using VVV.cod_def VVV.has_codomain_iff_arr VVV_arr_char B.VVV.cod_null
	+ by auto
	+ show "VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> VVV.cod \<mu>\<nu>\<tau> = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
	+ proof -
	+ assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
	+ have "VVV.cod \<mu>\<nu>\<tau> = (B.cod (fst \<mu>\<nu>\<tau>), B.cod (fst (snd \<mu>\<nu>\<tau>)), B.cod (snd (snd \<mu>\<nu>\<tau>)))"
	+ using \<mu>\<nu>\<tau> VVV.cod_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
	+ by simp
	+ also have "... = UP (B.cod (snd (snd \<mu>\<nu>\<tau>)), B.cod (fst (snd \<mu>\<nu>\<tau>)), B.cod (fst \<mu>\<nu>\<tau>))"
	+ using \<mu>\<nu>\<tau> VVV_arr_char B.VV.arr_char B.VVV.arr_char
	+ apply simp
	+ by (metis (no_types, lifting) B.arr_cod_iff_arr H.src_cod H.trg_cod VV.arrE VVV.arrE)
	+ also have "... = UP (B.VVV.cod (DN \<mu>\<nu>\<tau>))"
	+ using \<mu>\<nu>\<tau> B.VVV.cod_char B.VVV.arr_char B.VV.arr_char VVV.arr_char VV.arr_char
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+
	+ lemma HoHV_char:
	+ shows "HoHV \<mu>\<nu>\<tau> = B.HoVH (DN \<mu>\<nu>\<tau>)"
	+ using HoHV_def B.HoVH_def VVV_arr_char by simp
	+
	+ lemma HoVH_char:
	+ shows "HoVH \<mu>\<nu>\<tau> = B.HoHV (DN \<mu>\<nu>\<tau>)"
	+ using HoVH_def B.HoHV_def VVV_arr_char by simp
	+
	+ definition \<a> ("\<a>[_, _, _]")
	+ where "\<a>[\<mu>, \<nu>, \<tau>] \<equiv> B.\<alpha>' (DN (\<mu>, \<nu>, \<tau>))"
	+
	+ interpretation natural_isomorphism VVV.comp \<open>(\<cdot>)\<close> HoHV HoVH
	+ \<open>\<lambda>\<mu>\<nu>\<tau>. \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]\<close>
	+ proof
	+ fix \<mu>\<nu>\<tau>
	+ show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)] = B.null"
	+ using VVV.arr_char B.VVV.arr_char \<a>_def B.\<alpha>'.is_extensional by auto
	+ assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
	+ show "B.dom \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)] = HoHV (VVV.dom \<mu>\<nu>\<tau>)"
	+ proof -
	+ have "HoHV (VVV.dom \<mu>\<nu>\<tau>) =
	+ (B.dom (fst \<mu>\<nu>\<tau>) \<star> B.dom (fst (snd \<mu>\<nu>\<tau>))) \<star> B.dom (snd (snd \<mu>\<nu>\<tau>))"
	+ unfolding HoHV_def B.VxVxV.dom_char
	+ using \<mu>\<nu>\<tau> VVV.arr_char VVV.dom_char VV.arr_char by simp
	+ also have "... = B.HoVH (B.VVV.dom (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
	+ unfolding B.HoVH_def B.VxVxV.dom_char
	+ using \<mu>\<nu>\<tau> B.VVV.dom_char B.VxVxV.dom_char B.VVV.arr_char B.VV.arr_char
	+ apply simp
	+ by (metis (no_types, lifting) VV.arr_char VVV.arrE)
	+ also have "... = B.dom (B.\<alpha>' (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
	+ using \<mu>\<nu>\<tau> B.\<alpha>'.preserves_dom VVV_arr_char by presburger
	+ also have "... = B.dom \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
	+ using \<mu>\<nu>\<tau> \<a>_def by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "B.cod \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)] = HoVH (VVV.cod \<mu>\<nu>\<tau>)"
	+ proof -
	+ have "HoVH (VVV.cod \<mu>\<nu>\<tau>) =
	+ B.cod (fst \<mu>\<nu>\<tau>) \<star> B.cod (fst (snd \<mu>\<nu>\<tau>)) \<star> B.cod (snd (snd \<mu>\<nu>\<tau>))"
	+ unfolding HoVH_def B.VxVxV.cod_char
	+ using \<mu>\<nu>\<tau> VVV.arr_char VVV.cod_char VV.arr_char by simp
	+ also have "... = B.HoHV (B.VVV.cod (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
	+ unfolding B.HoHV_def B.VxVxV.cod_char
	+ using \<mu>\<nu>\<tau> B.VVV.cod_char B.VxVxV.cod_char B.VVV.arr_char B.VV.arr_char
	+ apply simp
	+ by (metis (no_types, lifting) VV.arr_char VVV.arrE)
	+ also have "... = B.cod (B.\<alpha>' (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
	+ using \<mu>\<nu>\<tau> B.\<alpha>'.preserves_cod VVV_arr_char by presburger
	+ also have "... = B.cod \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
	+ using \<mu>\<nu>\<tau> \<a>_def by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "HoVH \<mu>\<nu>\<tau> \<cdot>
	+ \<a>[fst (VVV.dom \<mu>\<nu>\<tau>), fst (snd (VVV.dom \<mu>\<nu>\<tau>)), snd (snd (VVV.dom \<mu>\<nu>\<tau>))] =
	+ \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
	+ proof -
	+ have "HoVH \<mu>\<nu>\<tau> \<cdot>
	+ \<a>[fst (VVV.dom \<mu>\<nu>\<tau>), fst (snd (VVV.dom \<mu>\<nu>\<tau>)), snd (snd (VVV.dom \<mu>\<nu>\<tau>))] =
	+ HoVH \<mu>\<nu>\<tau> \<cdot> B.\<alpha>' (B.VVV.dom (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>))"
	+ unfolding \<a>_def
	+ using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char VVV.dom_char B.VVV.arr_char B.VVV.dom_char
	+ by auto
	+ also have "... = B.\<alpha>' (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)"
	+ using B.\<alpha>'.is_natural_1 VVV_arr_char \<mu>\<nu>\<tau> HoVH_char by presburger
	+ also have "... = \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
	+ using \<mu>\<nu>\<tau> \<a>_def by simp
	+ finally show ?thesis by blast
	+ qed
	+ show "\<a>[fst (VVV.cod \<mu>\<nu>\<tau>), fst (snd (VVV.cod \<mu>\<nu>\<tau>)), snd (snd (VVV.cod \<mu>\<nu>\<tau>))] \<cdot>
	+ HoHV \<mu>\<nu>\<tau> =
	+ \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))"
	+ proof -
	+ have "\<a>[fst (VVV.cod \<mu>\<nu>\<tau>), fst (snd (VVV.cod \<mu>\<nu>\<tau>)), snd (snd (VVV.cod \<mu>\<nu>\<tau>))] \<cdot>
	+ HoHV \<mu>\<nu>\<tau> =
	+ B.\<alpha>' (B.VVV.cod (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)) \<cdot> HoHV \<mu>\<nu>\<tau>"
	+ unfolding \<a>_def
	+ using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char VVV.cod_char B.VVV.arr_char B.VVV.cod_char
	+ by auto
	+ also have "... = B.\<alpha>' (snd (snd \<mu>\<nu>\<tau>), fst (snd \<mu>\<nu>\<tau>), fst \<mu>\<nu>\<tau>)"
	+ using B.\<alpha>'.is_natural_2 VVV_arr_char \<mu>\<nu>\<tau> HoHV_char by presburger
	+ also have "... = \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
	+ using \<mu>\<nu>\<tau> \<a>_def by simp
	+ finally show ?thesis by blast
	+ qed
	+ next
	+ fix \<mu>\<nu>\<tau>
	+ assume \<mu>\<nu>\<tau>: "VVV.ide \<mu>\<nu>\<tau>"
	+ show "B.iso \<a>[fst \<mu>\<nu>\<tau>, fst (snd \<mu>\<nu>\<tau>), snd (snd \<mu>\<nu>\<tau>)]"
	+ proof -
	+ have "B.VVV.ide (DN \<mu>\<nu>\<tau>)"
	+ using \<mu>\<nu>\<tau> VVV_ide_char by blast
	+ thus ?thesis
	+ using \<mu>\<nu>\<tau> \<a>_def B.\<alpha>'.components_are_iso by auto
	+ qed
	+ qed
	+
	+ interpretation bicategory V H \<a> \<i> src trg
	+ proof
	+ show "\<And>a. H.obj a \<Longrightarrow> \<guillemotleft>\<i> a : H a a \<rightarrow>\<^sub>B a\<guillemotright>"
	+ using H.obj_def H.objE B.obj_def B.objE B.unit_in_hom by meson
	+ show "\<And>a. H.obj a \<Longrightarrow> B.iso (\<i> a)"
	+ using H.obj_def H.objE B.obj_def B.objE B.iso_unit by meson
	+ show "\<And>f g h k. \<lbrakk> B.ide f; B.ide g; B.ide h; B.ide k;
	+ src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
	+ (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k) = \<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k]"
	+ unfolding \<a>_def
	+ using B.\<a>'_def B.comp_assoc B.pentagon' VVV.arr_char VV.arr_char by simp
	+ qed
	+
	+ proposition is_bicategory:
	+ shows "bicategory V H \<a> \<i> src trg"
	+ ..
	+
	+ end
	+
	+ sublocale op_bicategory \<subseteq> bicategory V H \<a> \<i> src trg
	+ using is_bicategory by auto
	+
	+ context op_bicategory
	+ begin
	+
	+ lemma assoc_ide_simp:
	+ assumes "B.ide f" and "B.ide g" and "B.ide h"
	+ and "src f = trg g" and "src g = trg h"
	+ shows "\<a>[f, g, h] = B.\<a>' h g f"
	+ using assms \<a>_def B.\<a>'_def by fastforce
	+
	+ lemma lunit_ide_simp:
	+ assumes "B.ide f"
	+ shows "lunit f = B.runit f"
	+ proof (intro B.runit_eqI)
	+ show "B.ide f" by fact
	+ show "\<guillemotleft>lunit f : H (trg f) f \<rightarrow>\<^sub>B f\<guillemotright>"
	+ using assms by simp
	+ show "trg f \<star> lunit f = (\<i>[trg f] \<star> f) \<cdot> \<a>\<^sub>B[f, trg f, trg f]"
	+ proof -
	+ have "trg f \<star> lunit f = (\<i>[trg f] \<star> f) \<cdot> \<a>' (trg f) (trg f) f"
	+ using assms lunit_char(1-2) [of f] by simp
	+ moreover have "\<a>' (trg f) (trg f) f = \<a>\<^sub>B[f, trg f, trg f]"
	+ proof (unfold \<a>'_def)
	+ have 1: "VVV.ide (trg f, trg f, f)"
	+ using assms VVV.ide_char VVV.arr_char VV.arr_char by simp
	+ have "\<alpha>' (trg f, trg f, f) = B.inv \<a>[trg f, trg f, f]"
	+ using 1 B.\<alpha>'.inverts_components by simp
	+ also have "... = B.inv (B.\<alpha>' (f, trg f, trg f))"
	+ unfolding \<a>_def using 1 by simp
	+ also have "... = \<a>\<^sub>B[f, trg f, trg f]"
	+ using 1 B.VVV.ide_char B.VVV.arr_char B.VV.arr_char VVV.ide_char
	+ VVV.arr_char VV.arr_char B.\<alpha>'.inverts_components B.\<alpha>_def
	+ by force
	+ finally show "\<alpha>' (trg f, trg f, f) = \<a>\<^sub>B[f, trg f, trg f]"
	+ by blast
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma runit_ide_simp:
	+ assumes "B.ide f"
	+ shows "runit f = B.lunit f"
	+ using assms runit_char(1-2) [of f] B.\<a>'_def assoc_ide_simp
	+ apply (intro B.lunit_eqI)
	+ by simp_all
	+
	+ end
	+
	+ context pseudofunctor
	+ begin
	+
	+ interpretation C': op_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C ..
	+ interpretation D': op_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D ..
	+
	+ notation C'.H (infixr "\<star>\<^sub>C\<^sup>o\<^sup>p" 53)
	+ notation D'.H (infixr "\<star>\<^sub>D\<^sup>o\<^sup>p" 53)
	+
	+ interpretation F': weak_arrow_of_homs V\<^sub>C C'.src C'.trg V\<^sub>D D'.src D'.trg F
	+ apply unfold_locales
	+ using weakly_preserves_src weakly_preserves_trg by simp_all
	+ interpretation FF: "functor" C'.VV.comp D'.VV.comp F'.FF
	+ using F'.functor_FF by auto
	+ interpretation H\<^sub>D'oFF: composite_functor C'.VV.comp D'.VV.comp V\<^sub>D F'.FF
	+ \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>D\<^sup>o\<^sup>p snd \<mu>\<nu>\<close> ..
	+ interpretation FoH\<^sub>C': composite_functor C'.VV.comp V\<^sub>C V\<^sub>D
	+ \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>C\<^sup>o\<^sup>p snd \<mu>\<nu>\<close> F
	+ ..
	+ interpretation \<Phi>': natural_isomorphism C'.VV.comp V\<^sub>D H\<^sub>D'oFF.map FoH\<^sub>C'.map
	+ \<open>\<lambda>f. \<Phi> (snd f, fst f)\<close>
	+ using C.VV.arr_char C'.VV.arr_char C'.VV.ide_char C.VV.ide_char FF_def F'.FF_def
	+ \<Phi>.is_extensional \<Phi>.is_natural_1 \<Phi>.is_natural_2 \<Phi>.components_are_iso
	+ apply unfold_locales by auto
	+ interpretation F': pseudofunctor V\<^sub>C C'.H C'.\<a> \<i>\<^sub>C C'.src C'.trg
	+ V\<^sub>D D'.H D'.\<a> \<i>\<^sub>D D'.src D'.trg
	+ F \<open>\<lambda>f. \<Phi> (snd f, fst f)\<close>
	+ proof
	+ fix f g h
	+ assume f: "C.ide f" and g: "C.ide g" and h: "C.ide h"
	+ and fg: "C'.src f = C'.trg g" and gh: "C'.src g = C'.trg h"
	+ have "F (C'.\<a> f g h) \<cdot>\<^sub>D \<Phi> (h, f \<star>\<^sub>C\<^sup>o\<^sup>p g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D\<^sup>o\<^sup>p F h) =
	+ \<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g)) \<cdot>\<^sub>D D'.\<a> (F f) (F g) (F h)"
	+ proof -
	+ have "F (\<a>\<^sub>C h g f) \<cdot>\<^sub>D \<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g)) =
	+ (\<Phi> (h, f \<star>\<^sub>C\<^sup>o\<^sup>p g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D\<^sup>o\<^sup>p F h)) \<cdot>\<^sub>D \<a>\<^sub>D (F h) (F g) (F f)"
	+ using f g h fg gh assoc_coherence D.comp_assoc by simp
	+ moreover have "D.seq (F \<a>\<^sub>C[h, g, f]) (\<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g)))"
	+ proof -
	+ have "\<guillemotleft>F (\<a>\<^sub>C h g f) : F ((h \<star>\<^sub>C g) \<star>\<^sub>C f) \<Rightarrow>\<^sub>D F (h \<star>\<^sub>C g \<star>\<^sub>C f)\<guillemotright>"
	+ using f g h fg gh preserves_hom C.assoc_in_hom(2) by simp
	+ moreover have "\<guillemotleft>\<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) : F (h \<star>\<^sub>C g) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F ((h \<star>\<^sub>C g) \<star>\<^sub>C f)\<guillemotright>"
	+ using f g h fg gh preserves_hom \<Phi>.preserves_hom by auto
	+ moreover have "\<guillemotleft>F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g) : (F h \<star>\<^sub>D F g) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F (h \<star>\<^sub>C g) \<star>\<^sub>D F f\<guillemotright>"
	+ using f g h fg gh preserves_hom \<Phi>.preserves_hom C.VV.in_hom_char
	+ FF_def C.VV.arr_char D.hseqI'
	+ by auto
	+ ultimately show ?thesis by auto
	+ qed
	+ moreover have "D.iso (F \<a>\<^sub>C[h, g, f])"
	+ using f g h fg gh by simp
	+ moreover have "D.iso \<a>\<^sub>D[F h, F g, F f]"
	+ using f g h fg gh by simp
	+ moreover have "D.inv (F \<a>\<^sub>C[h, g, f]) = F (C'.\<a> f g h)"
	+ using f g h fg gh
	+ by (simp add: C'.assoc_ide_simp preserves_inv)
	+ moreover have "D.inv \<a>\<^sub>D[F h, F g, F f] = D'.\<a> (F f) (F g) (F h)"
	+ using f g h fg gh
	+ by (simp add: D'.assoc_ide_simp)
	+ ultimately show ?thesis
	+ using D.invert_opposite_sides_of_square
	+ [of "F (\<a>\<^sub>C h g f)" "\<Phi> (g \<star>\<^sub>C\<^sup>o\<^sup>p h, f) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (h, g))"
	+ "\<Phi> (h, f \<star>\<^sub>C\<^sup>o\<^sup>p g) \<cdot>\<^sub>D (\<Phi> (g, f) \<star>\<^sub>D\<^sup>o\<^sup>p F h)" "\<a>\<^sub>D (F h) (F g) (F f)"]
	+ D.comp_assoc
	+ by simp
	+ qed
	+ thus "F (C'.\<a> f g h) \<cdot>\<^sub>D \<Phi> (snd (f \<star>\<^sub>C\<^sup>o\<^sup>p g, h), fst (f \<star>\<^sub>C\<^sup>o\<^sup>p g, h)) \<cdot>\<^sub>D
	+ (\<Phi> (snd (f, g), fst (f, g)) \<star>\<^sub>D\<^sup>o\<^sup>p F h) =
	+ \<Phi> (snd (f, g \<star>\<^sub>C\<^sup>o\<^sup>p h), fst (f, g \<star>\<^sub>C\<^sup>o\<^sup>p h)) \<cdot>\<^sub>D (F f \<star>\<^sub>D\<^sup>o\<^sup>p \<Phi> (snd (g, h), fst (g, h))) \<cdot>\<^sub>D
	+ D'.\<a> (F f) (F g) (F h)"
	+ using f g h fg gh by simp
	+ qed
	+
	+ lemma induces_pseudofunctor_between_opposites:
	+ shows "pseudofunctor (\<cdot>\<^sub>C) (\<star>\<^sub>C\<^sup>o\<^sup>p) C'.\<a> \<i>\<^sub>C C'.src C'.trg
	+ (\<cdot>\<^sub>D) (\<star>\<^sub>D\<^sup>o\<^sup>p) D'.\<a> \<i>\<^sub>D D'.src D'.trg
	+ F (\<lambda>f. \<Phi> (snd f, fst f))"
	+ ..
	+
	+ text \<open>
	+ It is now easy to dualize the coherence condition for \<open>F\<close> with respect to
	+ left unitors to obtain the corresponding condition for right unitors.
	+ \<close>
	+
	+ lemma runit_coherence:
	+ assumes "C.ide f"
	+ shows "\<r>\<^sub>D[F f] = F \<r>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ proof -
	+ have "C'.lunit f = \<r>\<^sub>C[f]"
	+ using assms C'.lunit_ide_simp by simp
	+ moreover have "D'.lunit (F f) = \<r>\<^sub>D[F f]"
	+ using assms D'.lunit_ide_simp by simp
	+ moreover have "F'.\<Psi> (src\<^sub>C f) = \<Psi> (src\<^sub>C f)"
	+ using assms F'.\<Psi>_char F'.preserves_trg
	+ by (intro \<Psi>_eqI, auto)
	+ moreover have "D'.lunit (F f) =
	+ F (C'.lunit f) \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D F'.\<Psi> (src\<^sub>C f))"
	+ using assms F'.lunit_coherence by simp
	+ ultimately show ?thesis by simp
	+ qed
	+
	+ end
	+
	+ subsection "Preservation Properties"
	+
	+ text \<open>
	+ The objective of this section is to establish explicit formulas for the result
	+ of applying a pseudofunctor to expressions of various forms.
	+ \<close>
	+
	+ context pseudofunctor
	+ begin
	+
	+ lemma preserves_lunit:
	+ assumes "C.ide f"
	+ shows "F \<l>\<^sub>C[f] = \<l>\<^sub>D[F f] \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))"
	+ and "F \<l>\<^sub>C\<^sup>-\<^sup>1[f] = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f]"
	+ proof -
	+ have "\<l>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)) = F \<l>\<^sub>C[f]"
	+ proof -
	+ have "D.arr \<l>\<^sub>D[F f]"
	+ using assms by simp
	+ moreover have "\<l>\<^sub>D[F f] = F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"
	+ using assms lunit_coherence by simp
	+ moreover have "D.iso (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f))"
	+ using assms \<Phi>_components_are_iso \<Psi>_char D.iso_hcomp FF_def D.hseqI'
	+ by (intro D.isos_compose D.seqI, auto)
	+ ultimately show ?thesis
	+ using assms
	+ D.invert_side_of_triangle(2)
	+ [of "\<l>\<^sub>D[F f]" "F \<l>\<^sub>C[f]" "\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)"]
	+ by metis
	+ qed
	+ moreover have "D.inv (\<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f)) =
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))"
	+ using assms \<Phi>_in_hom \<Phi>_components_are_iso C.VV.arr_char \<Psi>_char
	+ D.iso_hcomp FF_def D.hseqI' D.inv_comp
	+ by simp
	+ ultimately show "F \<l>\<^sub>C[f] =
	+ \<l>\<^sub>D[F f] \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f))"
	+ by simp
	+ hence "F \<l>\<^sub>C\<^sup>-\<^sup>1[f] =
	+ D.inv (\<l>\<^sub>D[F f] \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C f, f)))"
	+ using assms preserves_inv C.iso_lunit by simp
	+ also have "... = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f]"
	+ proof -
	+ have "\<guillemotleft>\<l>\<^sub>D[F f] : map\<^sub>0 (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F f\<guillemotright> \<and> D.iso \<l>\<^sub>D[F f]"
	+ using assms D.iso_lunit by simp
	+ moreover have "\<guillemotleft>D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f :
	+ F (trg\<^sub>C f) \<star>\<^sub>D F f \<Rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C f) \<star>\<^sub>D F f\<guillemotright> \<and>
	+ D.iso (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f)"
	+ using assms \<Psi>_char [of "trg\<^sub>C f"] D.iso_inv_iso
	+ by (intro conjI D.hcomp_in_vhom, auto)
	+ moreover have
	+ "\<guillemotleft>D.inv (\<Phi> (trg\<^sub>C f, f)) : F (trg\<^sub>C f \<star>\<^sub>C f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f) \<star>\<^sub>D F f\<guillemotright> \<and>
	+ D.iso (D.inv (\<Phi> (trg\<^sub>C f, f)))"
	+ using assms \<Phi>_in_hom D.iso_inv_iso by simp
	+ moreover have "D.inv (D.inv (\<Psi> (trg\<^sub>C f)) \<star>\<^sub>D F f) = \<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f"
	+ using assms \<Psi>_char [of "trg\<^sub>C f"] D.iso_inv_iso by simp
	+ ultimately show ?thesis
	+ using assms D.iso_inv_iso D.comp_assoc D.iso_hcomp D.isos_compose
	+ by (elim conjE D.in_homE, auto simp add: D.inv_comp)
	+ qed
	+ finally show "F \<l>\<^sub>C\<^sup>-\<^sup>1[f] = \<Phi> (trg\<^sub>C f, f) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C f) \<star>\<^sub>D F f) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f]"
	+ by simp
	+ qed
	+
	+ lemma preserves_runit:
	+ assumes "C.ide f"
	+ shows "F \<r>\<^sub>C[f] = \<r>\<^sub>D[F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
	+ and "F \<r>\<^sub>C\<^sup>-\<^sup>1[f] = \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f]"
	+ proof -
	+ have "F \<r>\<^sub>C[f] = \<r>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)))"
	+ proof -
	+ have "\<r>\<^sub>D[F f] = F \<r>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ using assms runit_coherence [of f] by simp
	+ moreover have "D.iso (\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)))"
	+ using assms \<Phi>_components_are_iso \<Psi>_char D.iso_hcomp FF_def D.hseqI'
	+ apply (intro D.isos_compose D.seqI) by auto
	+ moreover have "D.arr \<r>\<^sub>D[F f]"
	+ using assms by simp
	+ ultimately show ?thesis
	+ using assms D.invert_side_of_triangle(2)
	+ [of "\<r>\<^sub>D[F f]" "F \<r>\<^sub>C[f]" "\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))"]
	+ by metis
	+ qed
	+ moreover have "D.inv (\<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f))) =
	+ (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
	+ using assms \<Phi>_in_hom \<Phi>_components_are_iso C.VV.arr_char \<Psi>_char
	+ D.iso_hcomp FF_def D.hseqI' D.inv_comp
	+ by simp
	+ ultimately show "F \<r>\<^sub>C[f] =
	+ \<r>\<^sub>D[F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f))"
	+ by simp
	+ hence "F \<r>\<^sub>C\<^sup>-\<^sup>1[f] =
	+ D.inv (\<r>\<^sub>D[F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f)))"
	+ using assms preserves_inv C.iso_runit by simp
	+ also have "... = \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f]"
	+ proof -
	+ have "\<guillemotleft>\<r>\<^sub>D[F f] : F f \<star>\<^sub>D map\<^sub>0 (src\<^sub>C f) \<Rightarrow>\<^sub>D F f\<guillemotright> \<and> D.iso \<r>\<^sub>D[F f]"
	+ using assms D.iso_runit by simp
	+ moreover have "\<guillemotleft>F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)) :
	+ F f \<star>\<^sub>D F (src\<^sub>C f) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D map\<^sub>0 (src\<^sub>C f)\<guillemotright> \<and>
	+ D.iso (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)))"
	+ using assms \<Psi>_char [of "src\<^sub>C f"] D.iso_inv_iso
	+ apply (intro conjI D.hcomp_in_vhom) by auto
	+ moreover have
	+ "\<guillemotleft>D.inv (\<Phi> (f, src\<^sub>C f)) : F (f \<star>\<^sub>C src\<^sub>C f) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F (src\<^sub>C f)\<guillemotright> \<and>
	+ D.iso (D.inv (\<Phi> (f, src\<^sub>C f)))"
	+ using assms \<Phi>_in_hom \<Phi>_components_are_iso D.iso_inv_iso by simp
	+ moreover have "D.inv (F f \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))) = F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)"
	+ using assms \<Psi>_char [of "src\<^sub>C f"] D.iso_inv_iso by simp
	+ ultimately show ?thesis
	+ using assms D.inv_comp D.iso_inv_iso D.comp_assoc D.isos_compose
	+ apply (elim conjE D.in_homE)
	+ by (auto simp add: D.inv_comp)
	+ qed
	+ finally show "F \<r>\<^sub>C\<^sup>-\<^sup>1[f] = \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f]"
	+ by simp
	+ qed
	+
	+ lemma preserves_assoc:
	+ assumes "C.ide f" and "C.ide g" and "C.ide h"
	+ and "src\<^sub>C f = trg\<^sub>C g" and "src\<^sub>C g = trg\<^sub>C h"
	+ shows "F \<a>\<^sub>C[f, g, h] = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
	+ and "F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F h] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
	+ proof -
	+ have "F \<a>\<^sub>C[f, g, h] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) =
	+ \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
	+ using assms assoc_coherence [of f g h] by simp
	+ moreover have "D.seq (\<Phi> (f, g \<star>\<^sub>C h)) ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])"
	+ using assms \<Phi>_components_are_iso C.VV.arr_char FF_def D.hseqI' by auto
	+ moreover have 1: "D.iso (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
	+ using assms \<Phi>_components_are_iso C.VV.arr_char FF_def D.hseqI' by auto
	+ moreover have "D.inv (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)) =
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
	+ using assms 1 \<Phi>_components_are_iso C.VV.arr_char FF_def D.inv_comp D.hseqI'
	+ by simp
	+ ultimately show 1: "F \<a>\<^sub>C[f, g, h] =
	+ \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
	+ using D.invert_side_of_triangle(2)
	+ [of "\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
	+ "F \<a>\<^sub>C[f, g, h]" "\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)"]
	+ D.comp_assoc
	+ by simp
	+ hence "F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] =
	+ D.inv (\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h)))"
	+ using assms preserves_inv by simp
	+ also have "... = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F h] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
	+ proof -
	+ have "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>C h) : F f \<star>\<^sub>D F (g \<star>\<^sub>C h) \<Rightarrow>\<^sub>D F (f \<star>\<^sub>C g \<star>\<^sub>C h)\<guillemotright> \<and> D.iso (\<Phi> (f, g \<star>\<^sub>C h))"
	+ using assms \<Phi>_components_are_iso by auto
	+ moreover have "\<guillemotleft>F f \<star>\<^sub>D \<Phi> (g, h) : F f \<star>\<^sub>D F g \<star>\<^sub>D F h \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F (g \<star>\<^sub>C h)\<guillemotright> \<and>
	+ D.iso (F f \<star>\<^sub>D \<Phi> (g, h))"
	+ using assms \<Phi>_components_are_iso
	+ by (intro conjI D.hcomp_in_vhom, auto)
	+ moreover have "\<guillemotleft>\<a>\<^sub>D[F f, F g, F h] : (F f \<star>\<^sub>D F g) \<star>\<^sub>D F h \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F g \<star>\<^sub>D F h\<guillemotright> \<and>
	+ D.iso \<a>\<^sub>D[F f, F g, F h]"
	+ using assms by auto
	+ moreover have
	+ "\<guillemotleft>D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h : F (f \<star>\<^sub>C g) \<star>\<^sub>D F h \<Rightarrow>\<^sub>D (F f \<star>\<^sub>D F g) \<star>\<^sub>D F h\<guillemotright> \<and>
	+ D.iso (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h)"
	+ using assms \<Phi>_components_are_iso D.iso_inv_iso
	+ by (intro conjI D.hcomp_in_vhom, auto)
	+ moreover have
	+ "\<guillemotleft>D.inv (\<Phi> (f \<star>\<^sub>C g, h)) : F ((f \<star>\<^sub>C g) \<star>\<^sub>C h) \<Rightarrow>\<^sub>D F (f \<star>\<^sub>C g) \<star>\<^sub>D F h\<guillemotright> \<and>
	+ D.iso (D.inv (\<Phi> (f \<star>\<^sub>C g, h)))"
	+ using assms \<Phi>_components_are_iso D.iso_inv_iso by auto
	+ ultimately show ?thesis
	+ using assms \<Phi>_components_are_iso D.isos_compose D.inv_comp
	+ D.comp_assoc D.iso_inv_iso
	+ apply (elim conjE D.in_homE) by (auto simp add: D.inv_comp)
	+ qed
	+ finally show "F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] =
	+ \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F h] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
	+ by simp
	+ qed
	+
	+ lemma preserves_hcomp:
	+ assumes "C.hseq \<mu> \<nu>"
	+ shows "F (\<mu> \<star>\<^sub>C \<nu>) =
	+ \<Phi> (C.cod \<mu>, C.cod \<nu>) \<cdot>\<^sub>D (F \<mu> \<star>\<^sub>D F \<nu>) \<cdot>\<^sub>D D.inv (\<Phi> (C.dom \<mu>, C.dom \<nu>))"
	+ proof -
	+ have "F (\<mu> \<star>\<^sub>C \<nu>) \<cdot>\<^sub>D \<Phi> (C.dom \<mu>, C.dom \<nu>) = \<Phi> (C.cod \<mu>, C.cod \<nu>) \<cdot>\<^sub>D (F \<mu> \<star>\<^sub>D F \<nu>)"
	+ using assms \<Phi>.naturality C.VV.arr_char C.VV.cod_char FF_def by auto
	+ thus ?thesis
	+ by (metis (no_types) assms C.hcomp_simps(3) C.hseqE C.ide_dom C.src_dom C.trg_dom
	+ D.comp_arr_inv' D.comp_assoc \<Phi>_components_are_iso \<Phi>_simps(5) is_natural_1)
	+ qed
	+
	+ lemma preserves_adjunction_data:
	+ assumes "adjunction_data_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
	+ shows "adjunction_data_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ (F f) (F g) (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
	+ proof
	+ interpret adjunction_data_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>
	+ using assms by auto
	+ show "D.ide (F f)"
	+ using preserves_ide by simp
	+ show "D.ide (F g)"
	+ using preserves_ide by simp
	+ show "\<guillemotleft>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) : src\<^sub>D (F f) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F f\<guillemotright>"
	+ using antipar C.VV.ide_char C.VV.arr_char \<Phi>_in_hom(2) \<Psi>_in_hom FF_def by auto
	+ show "\<guillemotleft>D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) : F f \<star>\<^sub>D F g \<Rightarrow>\<^sub>D src\<^sub>D (F g)\<guillemotright>"
	+ using antipar C.VV.ide_char C.VV.arr_char FF_def \<Phi>_in_hom(2) \<Psi>_in_hom(2)
	+ \<Psi>_char(2)
	+ by auto
	+ qed
	+
	+ lemma preserves_equivalence:
	+ assumes "equivalence_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
	+ shows "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ (F f) (F g) (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
	+ proof -
	+ interpret equivalence_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>
	+ using assms by auto
	+ interpret A: adjunction_data_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>F f\<close> \<open>F g\<close> \<open>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)\<close>
	+ \<open>D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)\<close>
	+ using adjunction_data_in_bicategory_axioms preserves_adjunction_data by auto
	+ show "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ (F f) (F g) (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
	+ proof
	+ show "D.iso (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))"
	+ using antipar \<Psi>_in_hom \<Phi>_components_are_iso D.iso_inv_iso FF_def unit_is_iso
	+ preserves_iso \<Psi>_char(2) D.isos_compose
	+ by simp
	+ show "D.iso (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
	+ using antipar \<Psi>_in_hom(2) \<Psi>_char(2) C.VV.ide_char C.VV.arr_char FF_def
	+ \<Phi>_in_hom(2) D.iso_inv_iso counit_is_iso preserves_iso \<Phi>_components_are_iso
	+ D.isos_compose
	+ by auto
	+ qed
	+ qed
	+
	+ lemma preserves_equivalence_maps:
	+ assumes "C.equivalence_map f"
	+ shows "D.equivalence_map (F f)"
	+ proof -
	+ obtain g \<eta> \<epsilon> where E: "equivalence_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
	+ using assms C.equivalence_map_def by auto
	+ interpret E: equivalence_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>
	+ using E by auto
	+ have E': "equivalence_in_bicategory (\<cdot>\<^sub>D) (\<star>\<^sub>D) \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
	+ (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
	+ using E preserves_equivalence by auto
	+ moreover have "src\<^sub>D (F f) = map\<^sub>0 (src\<^sub>C f) \<and> trg\<^sub>D (F f) = map\<^sub>0 (trg\<^sub>C f)"
	+ using assms C.equivalence_map_def map\<^sub>0_simps by simp
	+ ultimately show ?thesis
	+ using D.equivalence_map_def by auto
	+ qed
	+
	+ lemma preserves_equivalent_objects:
	+ assumes "C.equivalent_objects a b"
	+ shows "D.equivalent_objects (map\<^sub>0 a) (map\<^sub>0 b)"
	+ proof -
	+ obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright> \<and> C.equivalence_map f"
	+ using assms C.equivalent_objects_def by auto
	+ have "\<guillemotleft>F f : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 b\<guillemotright> \<and> D.equivalence_map (F f)"
	+ using f preserves_equivalence_maps by auto
	+ thus ?thesis
	+ using D.equivalent_objects_def by auto
	+ qed
	+
	+ end
	+
	+ subsection "Equivalence Pseudofunctors"
	+
	+ text \<open>
	+ In this section, we define ``equivalence pseudofunctors'', which are pseudofunctors
	+ that can be extended to an equivalence of bicategories. My purpose at the moment
	+ is just to have some way to establish that bicategories are equivalent and not to
	+ go so far as to give a full and proper development of equivalence of bicategories
	+ (which would involve the further definition of pseudonatural transformations and so on),
	+ nor even to prove that the pseudofunctors in an equivalence of bicategories are in fact
	+ ``equivalence pseudofunctors'' according to the definition given here.
	+ So in some sense the results we ultimately prove depend on one's having taken for
	+ granted that the definition given here is ``correct''. This is not entirely vacuous,
	+ because the definition does have some subtleties and it took me awhile to work the bugs
	+ out of the formalization. However, enough is proved using the definition that I think
	+ it is not difficult to accept it as correct. Future work can go back and give a fuller
	+ development to provide even more confidence.
	+
	+ \sloppypar
	+ It is asserted on the ``nLab'' \cite{nlab-equivalence-of-2-categories}
	+ that a pseudofunctor is part of an equivalence of bicategories if and only if it is
	+ essentially surjective on objects, essentially full on 1-cells (here: ``identities'')
	+ and fully faithful on 2-cells (here: ``arrows'').
	+ To turn this into a formal definition, it is necessary to find the proper way to express
	+ formally the notions involved. ``Essentially surjective on objects'' is perhaps the
	+ most complex of these, as it involves internal equivalences between objects.
	+
	+ The definition below requires that an equivalence pseudofunctor be (globally) faithful
	+ with respect to vertical composition. Traditional formulations do not consider a
	+ pseudofunctor as a single global functor, so we have to consider whether this condition
	+ is too strong. In fact, a pseudofunctor (as defined here) is locally faithful if and
	+ only if it is globally faithful.
	+ \<close>
	+
	+ context pseudofunctor
	+ begin
	+
	+ definition locally_faithful
	+ where "locally_faithful \<equiv>
	+ \<forall>f g \<mu> \<mu>'. \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>C g\<guillemotright> \<and> \<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>C g\<guillemotright> \<and> F \<mu> = F \<mu>' \<longrightarrow> \<mu> = \<mu>'"
	+
	+ lemma locally_faithful_iff_faithful:
	+ shows "locally_faithful \<longleftrightarrow> faithful_functor V\<^sub>C V\<^sub>D F"
	+ proof
	+ show "faithful_functor V\<^sub>C V\<^sub>D F \<Longrightarrow> locally_faithful"
	+ proof -
	+ assume 1: "faithful_functor V\<^sub>C V\<^sub>D F"
	+ interpret faithful_functor V\<^sub>C V\<^sub>D F
	+ using 1 by blast
	+ show "locally_faithful"
	+ unfolding locally_faithful_def using is_faithful by blast
	+ qed
	+ show "locally_faithful \<Longrightarrow> faithful_functor V\<^sub>C V\<^sub>D F"
	+ proof -
	+ assume 1: "locally_faithful"
	+ show "faithful_functor V\<^sub>C V\<^sub>D F"
	+ proof
	+ fix \<mu> \<mu>'
	+ assume par: "C.par \<mu> \<mu>'" and eq: "F \<mu> = F \<mu>'"
	+ obtain f g where fg: "\<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>C g\<guillemotright> \<and> \<guillemotleft>\<mu>' : f \<Rightarrow>\<^sub>C g\<guillemotright>"
	+ using par by auto
	+ show "\<mu> = \<mu>'"
	+ using 1 fg locally_faithful_def eq by simp
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ In contrast, it is not true that a pseudofunctor that is locally full is also
	+ globally full, because we can have \<open>\<guillemotleft>\<nu> : F h \<Rightarrow>\<^sub>D F k\<guillemotright>\<close> even if \<open>h\<close> and \<open>k\<close>
	+ are not in the same hom-category. So it would be a mistake to require that an
	+ equivalence functor be globally full.
	+ \<close>
	+
	+ locale equivalence_pseudofunctor =
	+ pseudofunctor +
	+ faithful_functor V\<^sub>C V\<^sub>D F +
	+ assumes surjective_on_objects_up_to_equivalence:
	+ "D.obj a' \<Longrightarrow> \<exists>a. C.obj a \<and> D.equivalent_objects (map\<^sub>0 a) a'"
	+ and locally_essentially_surjective:
	+ "\<lbrakk> C.obj a; C.obj b; \<guillemotleft>g : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 b\<guillemotright>; D.ide g \<rbrakk> \<Longrightarrow>
	+ \<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright> \<and> C.ide f \<and> D.isomorphic (F f) g"
	+ and locally_full:
	+ "\<lbrakk> C.ide f; C.ide f'; src\<^sub>C f = src\<^sub>C f'; trg\<^sub>C f = trg\<^sub>C f'; \<guillemotleft>\<nu> : F f \<Rightarrow>\<^sub>D F f'\<guillemotright> \<rbrakk> \<Longrightarrow>
	+ \<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>C f'\<guillemotright> \<and> F \<mu> = \<nu>"
	+ begin
	+
	+ lemma reflects_ide:
	+ assumes "C.endo \<mu>" and "D.ide (F \<mu>)"
	+ shows "C.ide \<mu>"
	+ using assms is_faithful [of "C.dom \<mu>" \<mu>] C.ide_char'
	+ by (metis C.arr_dom C.cod_dom C.dom_dom C.seqE D.ide_char preserves_dom)
	+
	+ lemma reflects_iso:
	+ assumes "C.arr \<mu>" and "D.iso (F \<mu>)"
	+ shows "C.iso \<mu>"
	+ proof -
	+ obtain \<mu>' where \<mu>': "\<guillemotleft>\<mu>' : C.cod \<mu> \<Rightarrow>\<^sub>C C.dom \<mu>\<guillemotright> \<and> F \<mu>' = D.inv (F \<mu>)"
	+ using assms locally_full [of "C.cod \<mu>" "C.dom \<mu>" "D.inv (F \<mu>)"]
	+ D.inv_in_hom C.in_homE preserves_hom C.in_homI
	+ by auto
	+ have "C.inverse_arrows \<mu> \<mu>'"
	+ proof
	+ have "D.ide (F (\<mu>' \<cdot>\<^sub>C \<mu>))"
	+ using assms \<mu>'
	+ by (metis (no_types, lifting) C.dom_comp C.in_homE C.seqI D.comp_inv_arr'
	+ D.ide_char' preserves_arr preserves_comp preserves_dom)
	+ moreover have "C.endo (\<mu>' \<cdot>\<^sub>C \<mu>)"
	+ using assms \<mu>' by auto
	+ ultimately show "C.ide (\<mu>' \<cdot>\<^sub>C \<mu>)"
	+ using assms \<mu>' reflects_ide by blast
	+ have "D.ide (F (\<mu> \<cdot>\<^sub>C \<mu>'))"
	+ using assms \<mu>'
	+ by (metis C.ide_compE D.comp_arr_inv' D.dom_cod D.ide_char' \<open>C.ide (\<mu>' \<cdot>\<^sub>C \<mu>)\<close>
	+ preserves_arr preserves_comp_2)
	+ moreover have "C.endo (\<mu> \<cdot>\<^sub>C \<mu>')"
	+ using assms \<mu>' by auto
	+ ultimately show "C.ide (\<mu> \<cdot>\<^sub>C \<mu>')"
	+ using assms reflects_ide by blast
	+ qed
	+ thus ?thesis by auto
	+ qed
	+
	+ lemma reflects_equivalence:
	+ assumes "C.ide f" and "C.ide g"
	+ and "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>" and "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>"
	+ and "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
	+ (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f))
	+ (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g))"
	+ shows "equivalence_in_bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
	+ proof -
	+ interpret E': equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> \<open>F g\<close>
	+ \<open>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)\<close>
	+ \<open>D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)\<close>
	+ using assms by auto
	+ show ?thesis
	+ proof
	+ show "C.ide f"
	+ using assms(1) by simp
	+ show "C.ide g"
	+ using assms(2) by simp
	+ show "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>"
	+ using assms(3) by simp
	+ show "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>"
	+ using assms(4) by simp
	+ have 0: "src\<^sub>C f = trg\<^sub>C g \<and> src\<^sub>C g = trg\<^sub>C f"
	+ using `\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>`
	+ by (metis C.hseqE C.ideD(1) C.ide_cod C.ide_dom C.in_homE assms(4))
	+ show "C.iso \<eta>"
	+ proof -
	+ have "D.iso (F \<eta>)"
	+ proof -
	+ have 1: "\<guillemotleft>D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f) : map\<^sub>0 (src\<^sub>C f) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F f\<guillemotright>"
	+ using `C.ide f` `C.ide g` `\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>`
	+ \<Psi>_char \<Phi>_in_hom \<Phi>_components_are_iso
	+ by (metis (mono_tags, lifting) C.ideD(1) E'.unit_in_vhom preserves_src)
	+ have 2: "D.iso (\<Phi> (g, f)) \<and> \<guillemotleft>\<Phi> (g, f) : F g \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C f)\<guillemotright>"
	+ using 0 `C.ide f` `C.ide g` \<Phi>_in_hom \<Phi>_components_are_iso
	+ by simp
	+ have 3: "D.iso (D.inv (\<Psi> (src\<^sub>C f))) \<and>
	+ \<guillemotleft>D.inv (\<Psi> (src\<^sub>C f)) : F (src\<^sub>C f) \<Rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C f)\<guillemotright>"
	+ using `C.ide f` \<Psi>_char D.iso_inv_iso by simp
	+ have "D.iso (\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D
	+ D.inv (\<Psi> (src\<^sub>C f)))"
	+ using 1 2 3 E'.unit_is_iso D.isos_compose by blast
	+ moreover have "\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D
	+ D.inv (\<Psi> (src\<^sub>C f)) =
	+ F \<eta>"
	+ proof -
	+ have "\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f)) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D \<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)) =
	+ (\<Phi> (g, f) \<cdot>\<^sub>D (D.inv (\<Phi> (g, f))) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D (\<Psi> (src\<^sub>C f)) \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f)))"
	+ using D.comp_assoc by simp
	+ also have "... = F (g \<star>\<^sub>C f) \<cdot>\<^sub>D F \<eta> \<cdot>\<^sub>D F (src\<^sub>C f)"
	+ using 2 3 D.comp_arr_inv D.comp_inv_arr D.inv_is_inverse
	+ by (metis C.ideD(1) C.obj_src D.comp_assoc D.dom_inv D.in_homE \<Psi>_char(2)
	+ assms(1))
	+ also have "... = F \<eta>"
	+ using `\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright>` D.comp_arr_dom D.comp_cod_arr by auto
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using assms reflects_iso by auto
	+ qed
	+ show "C.iso \<epsilon>"
	+ proof -
	+ have "D.iso (F \<epsilon>)"
	+ proof -
	+ have 1: "\<guillemotleft>D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g) : F f \<star>\<^sub>D F g \<Rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C g)\<guillemotright>"
	+ using `C.ide f` `C.ide g` `\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>`
	+ \<Psi>_char \<Phi>_in_hom \<Phi>_components_are_iso
	+ by (metis (mono_tags, lifting) C.ideD(1) E'.counit_in_vhom preserves_src)
	+ have 2: "D.iso (D.inv (\<Phi> (f, g))) \<and>
	+ \<guillemotleft>D.inv (\<Phi> (f, g)) : F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F g\<guillemotright>"
	+ using 0 `C.ide f` `C.ide g` `\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>` \<Phi>_in_hom(2)
	+ \<Phi>_components_are_iso D.inv_in_hom D.iso_inv_iso
	+ by simp
	+ have 3: "D.iso (\<Psi> (trg\<^sub>C f)) \<and> \<guillemotleft>\<Psi> (trg\<^sub>C f) : map\<^sub>0 (trg\<^sub>C f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
	+ using `C.ide f` \<Psi>_char by simp
	+ have
	+ "D.iso (\<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D D.inv (\<Phi> (f, g)))"
	+ using 0 1 2 3 E'.counit_is_iso D.isos_compose
	+ by (metis D.arrI D.cod_comp D.cod_inv D.seqI D.seqI')
	+ moreover have "\<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f, g)) =
	+ F \<epsilon>"
	+ proof -
	+ have "\<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C f)) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D \<Phi> (f, g)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f, g)) =
	+ (\<Psi> (trg\<^sub>C f) \<cdot>\<^sub>D D.inv (\<Psi> (trg\<^sub>C f))) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D (\<Phi> (f, g) \<cdot>\<^sub>D D.inv (\<Phi> (f, g)))"
	+ using D.comp_assoc by simp
	+ also have "... = F (trg\<^sub>C f) \<cdot>\<^sub>D F \<epsilon> \<cdot>\<^sub>D F (f \<star>\<^sub>C g)"
	+ using 0 2 3 D.comp_arr_inv D.comp_inv_arr D.inv_is_inverse D.iso_inv_iso
	+ by (simp add: C.VV.arr_char C.VV.ide_char assms(1) assms(2))
	+ also have "... = F \<epsilon>"
	+ using 0 `\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright>` D.comp_arr_dom D.comp_cod_arr by auto
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using assms reflects_iso by auto
	+ qed
	+ qed
	+ qed
	+
	+ lemma reflects_equivalence_map:
	+ assumes "C.ide f" and "D.equivalence_map (F f)"
	+ shows "C.equivalence_map f"
	+ proof -
	+ obtain g' \<phi> \<psi> where E': "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) g' \<phi> \<psi>"
	+ using assms D.equivalence_map_def by auto
	+ interpret E': equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> g' \<phi> \<psi>
	+ using E' by auto
	+ obtain g where g: "\<guillemotleft>g : trg\<^sub>C f \<rightarrow>\<^sub>C src\<^sub>C f\<guillemotright> \<and> C.ide g \<and> D.isomorphic (F g) g'"
	+ using assms E'.antipar locally_essentially_surjective [of "trg\<^sub>C f" "src\<^sub>C f" g']
	+ by auto
	+ obtain \<mu> where \<mu>: "\<guillemotleft>\<mu> : g' \<Rightarrow>\<^sub>D F g\<guillemotright> \<and> D.iso \<mu>"
	+ using g D.isomorphic_def D.isomorphic_symmetric by blast
	+ have E'': "equivalence_in_bicategory (\<cdot>\<^sub>D) (\<star>\<^sub>D) \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
	+ ((F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi>)
	+ (\<psi> \<cdot>\<^sub>D (D.inv (F f) \<star>\<^sub>D g') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<mu>))"
	+ using assms \<mu> E'.equivalence_in_bicategory_axioms D.ide_is_iso
	+ D.equivalence_respects_iso [of "F f" g' \<phi> \<psi> "F f" "F f" \<mu> "F g"]
	+ by auto
	+ interpret E'': equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> \<open>F g\<close>
	+ \<open>(F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi>\<close>
	+ \<open>\<psi> \<cdot>\<^sub>D (D.inv (F f) \<star>\<^sub>D g') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<mu>)\<close>
	+ using E'' by auto
	+ let ?\<eta>' = "\<Phi> (g, f) \<cdot>\<^sub>D (F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi> \<cdot>\<^sub>D D.inv (\<Psi> (src\<^sub>C f))"
	+ have \<eta>': "\<guillemotleft>?\<eta>' : F (src\<^sub>C f) \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C f)\<guillemotright>"
	+ proof (intro D.comp_in_homI)
	+ show "\<guillemotleft>D.inv (\<Psi> (src\<^sub>C f)) : F (src\<^sub>C f) \<Rightarrow>\<^sub>D src\<^sub>D (F f)\<guillemotright>"
	+ using assms \<Psi>_char by simp
	+ show "\<guillemotleft>\<phi> : src\<^sub>D (F f) \<Rightarrow>\<^sub>D g' \<star>\<^sub>D F f\<guillemotright>"
	+ using g E'.unit_in_hom(2) by simp
	+ show "\<guillemotleft>\<mu> \<star>\<^sub>D F f : g' \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F f\<guillemotright>"
	+ using assms g \<mu> E'.antipar E''.antipar by blast
	+ show "\<guillemotleft>F g \<star>\<^sub>D F f : F g \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F f\<guillemotright>"
	+ using assms g E''.antipar by auto
	+ show "\<guillemotleft>\<Phi> (g, f) : F g \<star>\<^sub>D F f \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C f)\<guillemotright>"
	+ using assms g \<Phi>_in_hom by auto
	+ qed
	+ have iso_\<eta>': "D.iso ?\<eta>'"
	+ proof -
	+ have "D.iso (\<Phi> (g, f))"
	+ using assms g \<Phi>_components_are_iso by auto
	+ thus ?thesis
	+ using assms g \<mu> E'.antipar E''.antipar \<Phi>_in_hom \<Psi>_char
	+ E'.unit_in_hom D.iso_inv_iso E'.unit_is_iso \<eta>'
	+ apply (intro D.isos_compose)
	+ apply simp_all
	+ apply (meson D.iso_hcomp D.hseqE D.seqE E''.unit_simps(1) components_are_iso)
	+ apply (meson D.arrI D.seqE)
	+ apply (meson D.arrI D.seqE)
	+ by (meson D.arrI D.seqE)
	+ qed
	+ let ?\<epsilon>' = "\<Psi> (src\<^sub>C g) \<cdot>\<^sub>D \<psi> \<cdot>\<^sub>D (D.inv (F f) \<star>\<^sub>D g') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<mu>) \<cdot>\<^sub>D D.inv (\<Phi> (f, g))"
	+ have \<epsilon>': "\<guillemotleft>?\<epsilon>' : F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
	+ proof (intro D.comp_in_homI)
	+ show "\<guillemotleft>D.inv (\<Phi> (f, g)) : F (f \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F g\<guillemotright>"
	+ using assms g \<Phi>_in_hom C.VV.ide_char C.VV.arr_char by auto
	+ show "\<guillemotleft>F f \<star>\<^sub>D D.inv \<mu> : F f \<star>\<^sub>D F g \<Rightarrow>\<^sub>D F f \<star>\<^sub>D g'\<guillemotright>"
	+ using assms g \<mu> E'.antipar E''.antipar D.ide_in_hom(2) by auto
	+ show "\<guillemotleft>D.inv (F f) \<star>\<^sub>D g' : F f \<star>\<^sub>D g' \<Rightarrow>\<^sub>D F f \<star>\<^sub>D g'\<guillemotright>"
	+ using assms E'.antipar E''.antipar D.ide_is_iso
	+ by (simp add: D.ide_in_hom(2))
	+ show "\<guillemotleft>\<psi> : F f \<star>\<^sub>D g' \<Rightarrow>\<^sub>D trg\<^sub>D (F f)\<guillemotright>"
	+ using E'.counit_in_hom by simp
	+ show "\<guillemotleft>\<Psi> (src\<^sub>C g) : trg\<^sub>D (F f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
	+ using assms g \<Psi>_char E'.antipar by auto
	+ qed
	+ have iso_\<epsilon>': "D.iso ?\<epsilon>'"
	+ proof -
	+ have "D.iso (\<Phi> (f, g))"
	+ using assms g C.VV.ide_char C.VV.arr_char by auto
	+ thus ?thesis
	+ using assms g \<mu> E'.antipar E''.antipar \<Phi>_in_hom \<Psi>_char
	+ E'.counit_in_hom D.iso_inv_iso E'.counit_is_iso \<epsilon>'
	+ by (metis C.ideD(1) C.obj_src D.arrI D.iso_hcomp D.hseq_char D.ide_is_iso
	+ D.isos_compose D.seqE E'.ide_right components_are_iso)
	+ qed
	+ obtain \<eta> where \<eta>: "\<guillemotleft>\<eta> : src\<^sub>C f \<Rightarrow>\<^sub>C g \<star>\<^sub>C f\<guillemotright> \<and> F \<eta> = ?\<eta>'"
	+ using assms g E'.antipar \<eta>' locally_full [of "src\<^sub>C f" "g \<star>\<^sub>C f" ?\<eta>']
	+ by (metis C.ide_hcomp C.ideD(1) C.in_hhomE C.src.preserves_ide C.hcomp_simps(1-2)
	+ C.src_trg C.trg_trg)
	+ have iso_\<eta>: "C.iso \<eta>"
	+ using \<eta> \<eta>' iso_\<eta>' reflects_iso by auto
	+ have 1: "\<exists>\<epsilon>. \<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright> \<and> F \<epsilon> = ?\<epsilon>'"
	+ proof -
	+ have "C.ide (f \<star>\<^sub>C g)"
	+ using assms g by auto
	+ moreover have "C.ide (src\<^sub>C g)"
	+ using assms g by simp
	+ moreover have "src\<^sub>C (f \<star>\<^sub>C g) = src\<^sub>C (src\<^sub>C g)"
	+ using assms g by auto
	+ moreover have "trg\<^sub>C (f \<star>\<^sub>C g) = trg\<^sub>C (src\<^sub>C g)"
	+ using assms g by auto
	+ ultimately show ?thesis
	+ using locally_full [of "f \<star>\<^sub>C g" "src\<^sub>C g" ?\<epsilon>']
	+ by (metis C.in_hhomE \<epsilon>' g)
	+ qed
	+ obtain \<epsilon> where \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star>\<^sub>C g \<Rightarrow>\<^sub>C src\<^sub>C g\<guillemotright> \<and> F \<epsilon> = ?\<epsilon>'"
	+ using 1 by blast
	+ have iso_\<epsilon>: "C.iso \<epsilon>"
	+ using \<epsilon> \<epsilon>' iso_\<epsilon>' reflects_iso by auto
	+ have "equivalence_in_bicategory (\<cdot>\<^sub>C) (\<star>\<^sub>C) \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C f g \<eta> \<epsilon>"
	+ using assms g \<eta> \<epsilon> iso_\<eta> iso_\<epsilon> by (unfold_locales, auto)
	+ thus ?thesis
	+ using C.equivalence_map_def by auto
	+ qed
	+
	+ lemma reflects_equivalent_objects:
	+ assumes "C.obj a" and "C.obj b" and "D.equivalent_objects (map\<^sub>0 a) (map\<^sub>0 b)"
	+ shows "C.equivalent_objects a b"
	+ proof -
	+ obtain f' where f': "\<guillemotleft>f' : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 b\<guillemotright> \<and> D.equivalence_map f'"
	+ using assms D.equivalent_objects_def D.equivalence_map_def by auto
	+ obtain f where f: "\<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright> \<and> C.ide f \<and> D.isomorphic (F f) f'"
	+ using assms f' locally_essentially_surjective [of a b f'] D.equivalence_map_is_ide
	+ by auto
	+ have "D.equivalence_map (F f)"
	+ using f f' D.equivalence_map_preserved_by_iso [of f' "F f"] D.isomorphic_symmetric
	+ by simp
	+ hence "C.equivalence_map f"
	+ using f f' reflects_equivalence_map [of f] by simp
	+ thus ?thesis
	+ using f C.equivalent_objects_def by auto
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ As previously stated, I have been trying to avoid, as part of the current project,
	+ a full development of pseudonatural transformations and equivalences of bicategories.
	+ I have chosen instead to define the notion of an equivalence pseudofunctor and to
	+ define two bicategories to be equivalent if there exists an equivalence pseudofunctor
	+ between them. However I cannot avoid needing to show that the relation of ``equivalence''
	+ so defined is at least a symmetric relation. To do that requires showing how
	+ to construct, given an equivalence pseudofunctor, an equivalence pseudofunctor going
	+ in the opposite direction. That is the purpose of the next section. A fuller development
	+ would define the notion ``equivalence of bicategories'' in terms of pseudofunctors and
	+ pseudonatural equivalences and would show that a pseudofunctor is an equivalence
	+ pseudofunctor if and only if it extends to an equivalence of bicategories.
	+ I am leaving such a development for future work.
	+ \<close>
	+
	+ locale converse_equivalence_pseudofunctor =
	+ C: bicategory V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C +
	+ D: bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D +
	+ F: equivalence_pseudofunctor V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F
	+ for V\<^sub>C :: "'c comp" (infixr "\<cdot>\<^sub>C" 55)
	+ and H\<^sub>C :: "'c comp" (infixr "\<star>\<^sub>C" 53)
	+ and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c" ("\<a>\<^sub>C[_, _, _]")
	+ and \<i>\<^sub>C :: "'c \<Rightarrow> 'c" ("\<i>\<^sub>C[_]")
	+ and src\<^sub>C :: "'c \<Rightarrow> 'c"
	+ and trg\<^sub>C :: "'c \<Rightarrow> 'c"
	+ and V\<^sub>D :: "'d comp" (infixr "\<cdot>\<^sub>D" 55)
	+ and H\<^sub>D :: "'d comp" (infixr "\<star>\<^sub>D" 53)
	+ and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd" ("\<a>\<^sub>D[_, _, _]")
	+ and \<i>\<^sub>D :: "'d \<Rightarrow> 'd" ("\<i>\<^sub>D[_]")
	+ and src\<^sub>D :: "'d \<Rightarrow> 'd"
	+ and trg\<^sub>D :: "'d \<Rightarrow> 'd"
	+ and F :: "'c \<Rightarrow> 'd"
	+ and \<Phi>\<^sub>F :: "'c * 'c \<Rightarrow> 'd"
	+ begin
	+
	+ notation C.isomorphic (infix "\<cong>\<^sub>C" 50)
	+ notation D.isomorphic (infix "\<cong>\<^sub>D" 50)
	+
	+ (*
	+ * TODO: export a neutral name for the defined pseudofunctor, such as "map" or "this".
	+ *)
	+
	+ text \<open>
	+ Specification of the object map of the converse pseudofunctor uses surjectivity
	+ on objects up to equivalence, and will in general involve a choice.
	+ \<close>
	+
	+ definition G\<^sub>0
	+ where "G\<^sub>0 a' \<equiv> SOME a. C.obj a \<and> D.equivalent_objects a' (F.map\<^sub>0 a)"
	+
	+ lemma G\<^sub>0_preserves_obj:
	+ assumes "D.obj a'"
	+ shows "C.obj (G\<^sub>0 a')"
	+ and "D.equivalent_objects a' (F.map\<^sub>0 (G\<^sub>0 a'))"
	+ using assms G\<^sub>0_def F.surjective_on_objects_up_to_equivalence [of a']
	+ someI_ex [of "\<lambda>a. C.obj a \<and> D.equivalent_objects a' (F.map\<^sub>0 a)"]
	+ D.equivalent_objects_symmetric
	+ by auto
	+
	+ text \<open>
	+ We obtain, for each object \<open>a'\<close> of \<open>D\<close>, the data for an equivalence between
	+ \<open>F.map\<^sub>0 (G\<^sub>0 a')\<close> and \<open>a'\<close>.
	+ \<close>
	+
	+ definition e
	+ where "e a' \<equiv> SOME e. \<guillemotleft>e : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright> \<and> D.equivalence_map e"
	+
	+ definition d
	+ where "d a' \<equiv>
	+ SOME d. \<exists>\<eta> \<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') d \<eta> \<epsilon>"
	+
	+ definition \<eta>
	+ where "\<eta> a' \<equiv>
	+ SOME \<eta>. \<exists>\<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') \<eta> \<epsilon>"
	+
	+ definition \<epsilon>
	+ where "\<epsilon> a' \<equiv>
	+ SOME \<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') (\<eta> a') \<epsilon>"
	+
	+ lemma G\<^sub>0_props:
	+ assumes "D.obj a'"
	+ shows "\<guillemotleft>e a' : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright>"
	+ and "\<guillemotleft>d a' : F.map\<^sub>0 (G\<^sub>0 a') \<rightarrow>\<^sub>D a'\<guillemotright>"
	+ and "D.ide (e a')" and "D.ide (d a')"
	+ and "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') (\<eta> a') (\<epsilon> a')"
	+ proof -
	+ have "C.obj (G\<^sub>0 a') \<and> D.equivalent_objects a' (F.map\<^sub>0 (G\<^sub>0 a'))"
	+ using assms G\<^sub>0_preserves_obj by simp
	+ hence 1: "\<exists>e d \<eta> \<epsilon>. \<guillemotleft>e : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright> \<and>
	+ equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D e d \<eta> \<epsilon>"
	+ using D.equivalent_objects_def D.equivalence_map_def by auto
	+ show ea': "\<guillemotleft>e a' : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright>"
	+ using 1 e_def D.equivalence_map_def
	+ someI_ex [of "\<lambda>e. \<guillemotleft>e : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright> \<and> D.equivalence_map e"]
	+ by simp
	+ have 2: "\<exists>d \<eta> \<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') d \<eta> \<epsilon>"
	+ using 1 e_def D.equivalence_map_def
	+ someI_ex [of "\<lambda>e. \<guillemotleft>e : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright> \<and> D.equivalence_map e"]
	+ by simp
	+ hence "\<exists>\<eta> \<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') \<eta> \<epsilon>"
	+ using d_def
	+ someI_ex
	+ [of "\<lambda>d. \<exists>\<eta> \<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') d \<eta> \<epsilon>"]
	+ by simp
	+ hence "\<exists>\<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') (\<eta> a') \<epsilon>"
	+ using \<eta>_def
	+ someI_ex
	+ [of "\<lambda>\<eta>. \<exists>\<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') \<eta> \<epsilon>"]
	+ by simp
	+ thus 3: "equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') (\<eta> a') (\<epsilon> a')"
	+ using \<epsilon>_def
	+ someI_ex
	+ [of "\<lambda>\<epsilon>. equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (e a') (d a') (\<eta> a') \<epsilon>"]
	+ by simp
	+ interpret e: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>e a'\<close> \<open>d a'\<close> \<open>\<eta> a'\<close> \<open>\<epsilon> a'\<close>
	+ using 3 by simp
	+ show "\<guillemotleft>d a' : F.map\<^sub>0 (G\<^sub>0 a') \<rightarrow>\<^sub>D a'\<guillemotright>"
	+ using ea' e.antipar(1) e.antipar(2) by auto
	+ show "D.ide (e a')"
	+ by simp
	+ show "D.ide (d a')"
	+ by simp
	+ qed
	+
	+ lemma e_in_hom [intro]:
	+ assumes "D.obj a'"
	+ shows "\<guillemotleft>e a' : a' \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 a')\<guillemotright>"
	+ using assms G\<^sub>0_props by auto
	+
	+ lemma e_simps [simp]:
	+ assumes "D.obj a'"
	+ shows "D.ide (e a')"
	+ and "src\<^sub>D (e a') = a'" and "trg\<^sub>D (e a') = F.map\<^sub>0 (G\<^sub>0 a')"
	+ and "D.dom (e a') = e a'" and "D.cod (e a') = e a'"
	+ using assms G\<^sub>0_props by auto
	+
	+ lemma d_in_hom [intro]:
	+ assumes "D.obj a'"
	+ shows "\<guillemotleft>d a' : F.map\<^sub>0 (G\<^sub>0 a') \<rightarrow>\<^sub>D a'\<guillemotright>"
	+ using assms G\<^sub>0_props by auto
	+
	+ lemma d_simps [simp]:
	+ assumes "D.obj a'"
	+ shows "D.ide (d a')"
	+ and "src\<^sub>D (d a') = F.map\<^sub>0 (G\<^sub>0 a')" and "trg\<^sub>D (d a') = a'"
	+ and "D.dom (d a') = d a'" and "D.cod (d a') = d a'"
	+ using assms G\<^sub>0_props by auto
	+
	+ text \<open>
	+ Next, we specify how the converse pseudofunctor behaves on identities (1-cells).
	+ This uses local essential surjectivity and also involves a choice.
	+ \<close>
	+
	+ definition G\<^sub>1
	+ where "G\<^sub>1 f' \<equiv> SOME f. C.ide f \<and> \<guillemotleft>f : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright> \<and>
	+ F f \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
	+
	+ lemma G\<^sub>1_props:
	+ assumes "D.ide f'"
	+ shows "C.ide (G\<^sub>1 f')"
	+ and "\<guillemotleft>G\<^sub>1 f' : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright>"
	+ and "F (G\<^sub>1 f') \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
	+ proof -
	+ interpret e_src: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (src\<^sub>D f')\<close> \<open>d (src\<^sub>D f')\<close> \<open>\<eta> (src\<^sub>D f')\<close> \<open>\<epsilon> (src\<^sub>D f')\<close>
	+ using assms G\<^sub>0_props by simp
	+ interpret e_trg: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (trg\<^sub>D f')\<close> \<open>d (trg\<^sub>D f')\<close> \<open>\<eta> (trg\<^sub>D f')\<close> \<open>\<epsilon> (trg\<^sub>D f')\<close>
	+ using assms G\<^sub>0_props by simp
	+
	+ have "\<exists>f. C.ide f \<and> \<guillemotleft>f : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright> \<and>
	+ F f \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
	+ using assms G\<^sub>0_props
	+ F.locally_essentially_surjective
	+ [of "G\<^sub>0 (src\<^sub>D f')" "G\<^sub>0 (trg\<^sub>D f')" "e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"]
	+ G\<^sub>0_preserves_obj D.equivalent_objects_def
	+ by auto
	+ hence 1: "C.ide (G\<^sub>1 f') \<and> \<guillemotleft>G\<^sub>1 f' : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright> \<and>
	+ F (G\<^sub>1 f') \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
	+ using G\<^sub>1_def someI_ex [of "\<lambda>f. C.ide f \<and> \<guillemotleft>f : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright> \<and>
	+ F f \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"]
	+ by simp
	+ show "C.ide (G\<^sub>1 f')"
	+ using 1 by simp
	+ show "\<guillemotleft>G\<^sub>1 f' : G\<^sub>0 (src\<^sub>D f') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D f')\<guillemotright>"
	+ using 1 by simp
	+ show "F (G\<^sub>1 f') \<cong>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
	+ using 1 by simp
	+ qed
	+
	+ text \<open>
	+ We need to choose a specific isomorphism between \<open>F (G\<^sub>1 f')\<close> and
	+ \<open>e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<close>.
	+ \<close>
	+
	+ definition \<phi>
	+ where "\<phi> f' \<equiv> SOME \<phi>. \<guillemotleft>\<phi> : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright> \<and> D.iso \<phi>"
	+
	+ lemma \<phi>_props:
	+ assumes "D.ide f'"
	+ shows "\<guillemotleft>\<phi> f' : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright>"
	+ and "D.iso (\<phi> f')"
	+ proof -
	+ have "\<exists>\<phi>. \<guillemotleft>\<phi> : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright> \<and> D.iso \<phi>"
	+ using assms G\<^sub>1_props by blast
	+ hence 1: "\<guillemotleft>\<phi> f' : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright> \<and> D.iso (\<phi> f')"
	+ using \<phi>_def
	+ someI_ex [of "\<lambda>\<phi>. \<guillemotleft>\<phi> : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright> \<and> D.iso \<phi>"]
	+ by simp
	+ show "\<guillemotleft>\<phi> f' : F (G\<^sub>1 f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright>"
	+ using 1 by simp
	+ show "D.iso (\<phi> f')"
	+ using 1 by simp
	+ qed
	+
	+ text \<open>
	+ The behavior of the converse pseudofunctor on arrows (2-cells) is now determined
	+ by local fullness. We have used indefinite choice in the definition here,
	+ but in fact the choice is unique due to faithfulness.
	+ \<close>
	+
	+ definition G
	+ where "G \<mu>' \<equiv> if D.arr \<mu>' then
	+ SOME \<mu>. \<guillemotleft>\<mu> : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright> \<and>
	+ F \<mu> = D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')
	+ else
	+ C.null"
	+
	+ lemma G_props:
	+ assumes "D.arr \<mu>'"
	+ shows "\<guillemotleft>G \<mu>' : G\<^sub>0 (src\<^sub>D \<mu>') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D \<mu>')\<guillemotright>"
	+ and "\<guillemotleft>G \<mu>' : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright>"
	+ and "F (G \<mu>') =
	+ D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
	+ proof -
	+ have "C.ide (G\<^sub>1 (D.dom \<mu>'))"
	+ using assms G\<^sub>1_props by simp
	+ moreover have "C.ide (G\<^sub>1 (D.cod \<mu>'))"
	+ using assms G\<^sub>1_props by simp
	+ moreover have "src\<^sub>C (G\<^sub>1 (D.dom \<mu>')) = src\<^sub>C (G\<^sub>1 (D.cod \<mu>'))"
	+ using assms G\<^sub>1_props
	+ by (metis C.in_hhomE D.ide_cod D.ide_dom D.src_cod D.src_dom)
	+ moreover have "trg\<^sub>C (G\<^sub>1 (D.dom \<mu>')) = trg\<^sub>C (G\<^sub>1 (D.cod \<mu>'))"
	+ using assms G\<^sub>1_props
	+ by (metis C.in_hhomE D.ide_cod D.ide_dom D.trg_cod D.trg_dom)
	+ moreover have
	+ "\<guillemotleft>D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>') :
	+ F (G\<^sub>1 (D.dom \<mu>')) \<Rightarrow>\<^sub>D F (G\<^sub>1 (D.cod \<mu>'))\<guillemotright>"
	+ proof (intro D.comp_in_homI)
	+ show "\<guillemotleft>\<phi> (D.dom \<mu>') :
	+ F (G\<^sub>1 (D.dom \<mu>')) \<Rightarrow>\<^sub>D
	+ e (trg\<^sub>D (D.dom \<mu>')) \<star>\<^sub>D D.dom \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.dom \<mu>'))\<guillemotright>"
	+ using assms \<phi>_props [of "D.dom \<mu>'"] by simp
	+ show "\<guillemotleft>e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>') :
	+ e (trg\<^sub>D (D.dom \<mu>')) \<star>\<^sub>D D.dom \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.dom \<mu>')) \<Rightarrow>\<^sub>D
	+ e (trg\<^sub>D (D.cod \<mu>')) \<star>\<^sub>D D.cod \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.cod \<mu>'))\<guillemotright>"
	+ using assms G\<^sub>0_props
	+ by (intro D.hcomp_in_vhom, auto)
	+ show "\<guillemotleft>D.inv (\<phi> (D.cod \<mu>')) :
	+ e (trg\<^sub>D (D.cod \<mu>')) \<star>\<^sub>D D.cod \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.cod \<mu>')) \<Rightarrow>\<^sub>D F (G\<^sub>1 (D.cod \<mu>'))\<guillemotright>"
	+ using assms \<phi>_props D.ide_cod D.inv_in_hom by presburger
	+ qed
	+ ultimately have
	+ "\<exists>\<mu>. \<guillemotleft>\<mu> : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright> \<and>
	+ F \<mu> = D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
	+ by (simp add: F.locally_full)
	+ hence 1: "\<guillemotleft>G \<mu>' : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright> \<and>
	+ F (G \<mu>') =
	+ D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
	+ using assms G_def
	+ someI_ex [of "\<lambda>\<mu>. \<guillemotleft>\<mu> : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright> \<and>
	+ F \<mu> = D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"]
	+ by simp
	+ show "\<guillemotleft>G \<mu>' : G\<^sub>1 (D.dom \<mu>') \<Rightarrow>\<^sub>C G\<^sub>1 (D.cod \<mu>')\<guillemotright>"
	+ using 1 by simp
	+ thus "\<guillemotleft>G \<mu>' : G\<^sub>0 (src\<^sub>D \<mu>') \<rightarrow>\<^sub>C G\<^sub>0 (trg\<^sub>D \<mu>')\<guillemotright>"
	+ using assms G\<^sub>1_props
	+ by (metis C.arrI C.ide_in_hom(2) C.in_hhom_def C.seqI' C.vseq_implies_hpar(1)
	+ C.vseq_implies_hpar(2) D.ide_dom D.src_dom D.trg_dom)
	+ show "F (G \<mu>') =
	+ D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
	+ using 1 by simp
	+ qed
	+
	+ lemma G_ide:
	+ assumes "D.ide f'"
	+ shows "G f' = G\<^sub>1 f'"
	+ proof -
	+ have "F (G f') =
	+ D.inv (\<phi> (D.cod f')) \<cdot>\<^sub>D (e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')) \<cdot>\<^sub>D \<phi> (D.dom f')"
	+ using assms G_props by simp
	+ also have "... = D.inv (\<phi> f') \<cdot>\<^sub>D \<phi> f'"
	+ using assms \<phi>_props [of f'] D.comp_cod_arr by auto
	+ also have "... = F (G\<^sub>1 f')"
	+ using assms \<phi>_props D.comp_inv_arr' by auto
	+ finally have "F (G f') = F (G\<^sub>1 f')" by simp
	+ thus ?thesis
	+ using assms G_props G\<^sub>1_props F.is_faithful
	+ by (metis C.ideD(3) C.in_homE D.ideD(1-3) F.locally_reflects_ide F.preserves_ide)
	+ qed
	+
	+ lemma \<phi>_in_hom [intro]:
	+ assumes "D.ide f'"
	+ shows "\<guillemotleft>\<phi> f' : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D f')) \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f'))\<guillemotright>"
	+ and "\<guillemotleft>\<phi> f' : F (G f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<phi> f' : F (G f') \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright>"
	+ using assms \<phi>_props G_ide by auto
	+ thus "\<guillemotleft>\<phi> f' : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D f')) \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f'))\<guillemotright>"
	+ using assms \<phi>_props D.hseqI' d_simps e_simps D.src_cod D.trg_cod
	+ apply (intro D.in_hhomI)
	+ apply auto[1]
	+ apply (metis D.arr_cod D.hseqI' D.ideD(1) D.in_homE D.obj_src D.hcomp_simps(1))
	+ by (metis D.arr_cod D.ideD(1) D.in_homE D.obj_trg D.hcomp_simps(2))
	+ qed
	+
	+ lemma \<phi>_simps [simp]:
	+ assumes "D.ide f'"
	+ shows "D.arr (\<phi> f')"
	+ and "src\<^sub>D (\<phi> f') = F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D f'))" and "trg\<^sub>D (\<phi> f') = F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f'))"
	+ and "D.dom (\<phi> f') = F (G f')" and "D.cod (\<phi> f') = e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')"
	+ using assms \<phi>_in_hom by auto
	+
	+ interpretation "functor" V\<^sub>D V\<^sub>C G
	+ proof
	+ show "\<And>\<mu>'. \<not> D.arr \<mu>' \<Longrightarrow> G \<mu>' = C.null"
	+ using G_def by simp
	+ show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.arr (G \<mu>')"
	+ using G_props by auto
	+ show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.dom (G \<mu>') = G (D.dom \<mu>')"
	+ proof -
	+ fix \<mu>'
	+ assume \<mu>': "D.arr \<mu>'"
	+ have "C.dom (G \<mu>') = G\<^sub>1 (D.dom \<mu>')"
	+ using \<mu>' G_props by auto
	+ also have "... = G (D.dom \<mu>')"
	+ proof -
	+ have "F (G (D.dom \<mu>')) = F (G\<^sub>1 (D.dom \<mu>'))"
	+ using \<mu>' G_props [of "D.dom \<mu>'"] \<phi>_props [of "D.dom \<mu>'"] D.comp_cod_arr
	+ D.comp_inv_arr'
	+ by auto
	+ moreover have "C.par (G\<^sub>1 (D.dom \<mu>')) (G (D.dom \<mu>'))"
	+ using \<mu>' G\<^sub>1_props G_props [of "D.dom \<mu>'"] by auto
	+ ultimately show ?thesis
	+ using F.is_faithful [of "G\<^sub>1 (D.dom \<mu>')" "G (D.dom \<mu>')"] by auto
	+ qed
	+ finally show "C.dom (G \<mu>') = G (D.dom \<mu>')" by simp
	+ qed
	+ show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.cod (G \<mu>') = G (D.cod \<mu>')"
	+ proof -
	+ fix \<mu>'
	+ assume \<mu>': "D.arr \<mu>'"
	+ have "C.cod (G \<mu>') = G\<^sub>1 (D.cod \<mu>')"
	+ using \<mu>' G_props [of \<mu>'] by auto
	+ also have "... = G (D.cod \<mu>')"
	+ proof -
	+ have "F (G (D.cod \<mu>')) = F (G\<^sub>1 (D.cod \<mu>'))"
	+ using \<mu>' G_props [of "D.cod \<mu>'"] \<phi>_props [of "D.cod \<mu>'"] D.comp_cod_arr
	+ D.comp_inv_arr'
	+ by auto
	+ moreover have "C.par (G (D.cod \<mu>')) (G\<^sub>1 (D.cod \<mu>'))"
	+ using \<mu>' G\<^sub>1_props G_props [of "D.cod \<mu>'"] by auto
	+ ultimately show ?thesis
	+ using F.is_faithful [of "G (D.cod \<mu>')" "G\<^sub>1 (D.cod \<mu>')"] by simp
	+ qed
	+ finally show "C.cod (G \<mu>') = G (D.cod \<mu>')" by simp
	+ qed
	+ show "\<And>\<mu> \<nu>. D.seq \<mu> \<nu> \<Longrightarrow> G (\<mu> \<cdot>\<^sub>D \<nu>) = G \<mu> \<cdot>\<^sub>C G \<nu>"
	+ proof -
	+ fix \<mu> \<nu>
	+ assume \<mu>\<nu>: "D.seq \<mu> \<nu>"
	+ have \<mu>: "\<guillemotleft>\<mu> : src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>) \<rightarrow>\<^sub>D trg\<^sub>D \<mu>\<guillemotright>"
	+ using \<mu>\<nu> D.vseq_implies_hpar
	+ by (intro D.in_hhomI, auto)
	+ have \<nu>: "\<guillemotleft>\<nu> : src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>) \<rightarrow>\<^sub>D trg\<^sub>D \<nu>\<guillemotright>"
	+ using \<mu>\<nu> D.vseq_implies_hpar
	+ by (intro D.in_hhomI, auto)
	+ have "F (G (\<mu> \<cdot>\<^sub>D \<nu>)) =
	+ D.inv (\<phi> (D.cod (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)) \<star>\<^sub>D \<mu> \<cdot>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D
	+ \<phi> (D.dom (\<mu> \<cdot>\<^sub>D \<nu>))"
	+ using \<mu>\<nu> G_props by simp
	+ also have "... =
	+ D.inv (\<phi> (D.cod (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)) \<star>\<^sub>D (\<mu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D (\<nu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)))) \<cdot>\<^sub>D
	+ \<phi> (D.dom (\<mu> \<cdot>\<^sub>D \<nu>))"
	+ using \<mu>\<nu> D.whisker_right D.obj_src G\<^sub>0_props(4) by metis
	+ also have "... = D.inv (\<phi> (D.cod (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)))) \<cdot>\<^sub>D
	+ \<phi> (D.dom (\<mu> \<cdot>\<^sub>D \<nu>))"
	+ proof -
	+ have "D.seq (\<mu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>))) (\<nu> \<star>\<^sub>D d (src\<^sub>D (\<mu> \<cdot>\<^sub>D \<nu>)))"
	+ using \<mu> \<nu> \<mu>\<nu> D.obj_src G\<^sub>0_props(4)
	+ apply (intro D.seqI D.hseqI, auto)
	+ using D.hseqI' by fastforce
	+ thus ?thesis
	+ using \<mu>\<nu> D.obj_src D.obj_trg G\<^sub>0_props(3) D.whisker_left by metis
	+ qed
	+ also have "... = D.inv (\<phi> (D.cod \<mu>)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<nu>) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
	+ \<phi> (D.dom \<nu>)"
	+ using \<mu>\<nu> D.vseq_implies_hpar(1) D.vseq_implies_hpar(2) D.comp_assoc by auto
	+ also have "... = D.inv (\<phi> (D.cod \<mu>)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D
	+ (\<phi> (D.dom \<mu>) \<cdot>\<^sub>D D.inv (\<phi> (D.cod \<nu>))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<nu>) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
	+ \<phi> (D.dom \<nu>)"
	+ proof -
	+ have "\<phi> (D.dom \<mu>) \<cdot>\<^sub>D D.inv (\<phi> (D.cod \<nu>)) =
	+ D.cod ((e (trg\<^sub>D \<nu>) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D \<phi> (D.dom \<nu>))"
	+ using \<mu> \<nu> G\<^sub>0_props(3-4) D.obj_src D.obj_trg D.hseqI' \<mu>\<nu> \<phi>_props
	+ D.comp_arr_inv' D.ide_cod
	+ by auto
	+ thus ?thesis
	+ using \<mu>\<nu> \<phi>_props D.comp_cod_arr
	+ by (metis D.seqE \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.arr (G \<mu>')\<close> calculation F.preserves_arr)
	+ qed
	+ also have "... =
	+ (D.inv (\<phi> (D.cod \<mu>)) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>)) \<cdot>\<^sub>D
	+ (D.inv (\<phi> (D.cod \<nu>)) \<cdot>\<^sub>D (e (trg\<^sub>D \<nu>) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D \<phi> (D.dom \<nu>))"
	+ using D.comp_assoc by simp
	+ also have "... = F (G \<mu>) \<cdot>\<^sub>D F (G \<nu>)"
	+ using \<mu>\<nu> G_props by auto
	+ also have "... = F (G \<mu> \<cdot>\<^sub>C G \<nu>)"
	+ using \<mu>\<nu> G_props D.seqE \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.arr (G \<mu>')\<close>
	+ \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.cod (G \<mu>') = G (D.cod \<mu>')\<close>
	+ \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.dom (G \<mu>') = G (D.dom \<mu>')\<close>
	+ by auto
	+ finally have "F (G (\<mu> \<cdot>\<^sub>D \<nu>)) = F (G \<mu> \<cdot>\<^sub>C G \<nu>)"
	+ by simp
	+ thus "G (\<mu> \<cdot>\<^sub>D \<nu>) = G \<mu> \<cdot>\<^sub>C G \<nu>"
	+ using \<mu>\<nu> G_props F.is_faithful [of "G (\<mu> \<cdot>\<^sub>D \<nu>)" "G \<mu> \<cdot>\<^sub>C G \<nu>"]
	+ (*
	+ * TODO: Here supposedly weak_arrow_of_homs_def is not used, but the proof does not
	+ * succeed without it.
	+ *)
	+ by (metis D.seqE \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.arr (G \<mu>')\<close>
	+ \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.cod (G \<mu>') = G (D.cod \<mu>')\<close>
	+ \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> C.dom (G \<mu>') = G (D.dom \<mu>')\<close>
	+ C.dom_comp D.dom_comp C.cod_comp D.cod_comp F.preserves_reflects_arr
	+ weak_arrow_of_homs_def)
	+ qed
	+ qed
	+
	+ interpretation weak_arrow_of_homs V\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C src\<^sub>C trg\<^sub>C G
	+ proof
	+ fix \<mu>'
	+ assume \<mu>': "D.arr \<mu>'"
	+ show "G (src\<^sub>D \<mu>') \<cong>\<^sub>C src\<^sub>C (G \<mu>')"
	+ proof -
	+ interpret e_src: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (src\<^sub>D \<mu>')\<close> \<open>d (src\<^sub>D \<mu>')\<close> \<open>\<eta> (src\<^sub>D \<mu>')\<close> \<open>\<epsilon> (src\<^sub>D \<mu>')\<close>
	+ using \<mu>' G\<^sub>0_props by simp
	+ have 1: "F (G (src\<^sub>D \<mu>')) \<cong>\<^sub>D F (src\<^sub>C (G \<mu>'))"
	+ proof -
	+ have "F (G\<^sub>1 (src\<^sub>D \<mu>')) \<cong>\<^sub>D e (src\<^sub>D \<mu>') \<star>\<^sub>D src\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')"
	+ using \<mu>' G\<^sub>1_props [of "src\<^sub>D \<mu>'"] by simp
	+ also have "D.isomorphic ... (F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D \<mu>')))"
	+ proof -
	+ have "\<guillemotleft>\<epsilon> (src\<^sub>D \<mu>') \<cdot>\<^sub>D (e (src\<^sub>D \<mu>') \<star>\<^sub>D \<l>\<^sub>D[d (src\<^sub>D \<mu>')]) :
	+ e (src\<^sub>D \<mu>') \<star>\<^sub>D src\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>') \<Rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D \<mu>'))\<guillemotright>"
	+ using \<mu>' G\<^sub>0_props e_src.counit_in_hom by fastforce
	+ moreover have "D.iso (\<epsilon> (src\<^sub>D \<mu>') \<cdot>\<^sub>D (e (src\<^sub>D \<mu>') \<star>\<^sub>D \<l>\<^sub>D[d (src\<^sub>D \<mu>')]))"
	+ using \<mu>' G\<^sub>0_props D.isos_compose D.arrI calculation by auto
	+ ultimately show ?thesis
	+ using D.isomorphic_def by blast
	+ qed
	+ also have "... \<cong>\<^sub>D F (src\<^sub>C (G \<mu>'))"
	+ using \<mu>' G\<^sub>0_props G_props [of \<mu>'] F.weakly_preserves_objects G\<^sub>0_preserves_obj(1)
	+ by auto
	+ finally have "F (G\<^sub>1 (src\<^sub>D \<mu>')) \<cong>\<^sub>D F (src\<^sub>C (G \<mu>'))"
	+ by blast
	+ moreover have "F (G (src\<^sub>D \<mu>')) = F (G\<^sub>1 (src\<^sub>D \<mu>'))"
	+ using \<mu>' G_props [of "src\<^sub>D \<mu>'"] D.comp_cod_arr D.comp_inv_arr' by auto
	+ ultimately show ?thesis by argo
	+ qed
	+ obtain \<phi>' where \<phi>': "\<guillemotleft>\<phi>' : F (G (src\<^sub>D \<mu>')) \<Rightarrow>\<^sub>D F (src\<^sub>C (G \<mu>'))\<guillemotright> \<and> D.iso \<phi>'"
	+ using 1 D.isomorphic_def by auto
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : G (src\<^sub>D \<mu>') \<Rightarrow>\<^sub>C src\<^sub>C (G \<mu>')\<guillemotright> \<and> F \<phi> = \<phi>'"
	+ using \<mu>' \<phi>' F.locally_full [of "G (src\<^sub>D \<mu>')" "src\<^sub>C (G \<mu>')" \<phi>'] C.in_hhom_def G_props(1)
	+ by auto
	+ have "C.iso \<phi>"
	+ using \<phi> \<phi>' F.reflects_iso by auto
	+ thus ?thesis
	+ using \<phi> C.isomorphic_def by auto
	+ qed
	+ show "G (trg\<^sub>D \<mu>') \<cong>\<^sub>C trg\<^sub>C (G \<mu>')"
	+ proof -
	+ interpret e_trg: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (trg\<^sub>D \<mu>')\<close> \<open>d (trg\<^sub>D \<mu>')\<close> \<open>\<eta> (trg\<^sub>D \<mu>')\<close> \<open>\<epsilon> (trg\<^sub>D \<mu>')\<close>
	+ using \<mu>' G\<^sub>0_props by simp
	+ have 1: "F (G (trg\<^sub>D \<mu>')) \<cong>\<^sub>D F (trg\<^sub>C (G \<mu>'))"
	+ proof -
	+ have "F (G\<^sub>1 (trg\<^sub>D \<mu>')) \<cong>\<^sub>D e (trg\<^sub>D \<mu>') \<star>\<^sub>D trg\<^sub>D \<mu>' \<star>\<^sub>D d (trg\<^sub>D \<mu>')"
	+ using \<mu>' G\<^sub>1_props [of "trg\<^sub>D \<mu>'"] by simp
	+ also have "... \<cong>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D \<mu>'))"
	+ proof -
	+ have "\<guillemotleft>\<epsilon> (trg\<^sub>D \<mu>') \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<l>\<^sub>D[d (trg\<^sub>D \<mu>')]) :
	+ e (trg\<^sub>D \<mu>') \<star>\<^sub>D trg\<^sub>D \<mu>' \<star>\<^sub>D d (trg\<^sub>D \<mu>') \<Rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D \<mu>'))\<guillemotright>"
	+ using \<mu>' G\<^sub>0_props e_trg.counit_in_hom by fastforce
	+ moreover have "D.iso (\<epsilon> (trg\<^sub>D \<mu>') \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<l>\<^sub>D[d (trg\<^sub>D \<mu>')]))"
	+ using \<mu>' G\<^sub>0_props D.isos_compose D.arrI calculation by simp
	+ ultimately show ?thesis
	+ using D.isomorphic_def by blast
	+ qed
	+ also have "... \<cong>\<^sub>D F (trg\<^sub>C (G \<mu>'))"
	+ using \<mu>' G\<^sub>0_props G_props [of \<mu>'] F.weakly_preserves_objects G\<^sub>0_preserves_obj(1)
	+ by auto
	+ finally have "F (G\<^sub>1 (trg\<^sub>D \<mu>')) \<cong>\<^sub>D F (trg\<^sub>C (G \<mu>'))"
	+ by blast
	+ moreover have "F (G (trg\<^sub>D \<mu>')) = F (G\<^sub>1 (trg\<^sub>D \<mu>'))"
	+ using \<mu>' G_props [of "trg\<^sub>D \<mu>'"] D.comp_cod_arr D.comp_inv_arr' by auto
	+ ultimately show ?thesis by argo
	+ qed
	+ obtain \<phi>' where \<phi>': "\<guillemotleft>\<phi>' : F (G (trg\<^sub>D \<mu>')) \<Rightarrow>\<^sub>D F (trg\<^sub>C (G \<mu>'))\<guillemotright> \<and> D.iso \<phi>'"
	+ using 1 D.isomorphic_def by auto
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : G (trg\<^sub>D \<mu>') \<Rightarrow>\<^sub>C trg\<^sub>C (G \<mu>')\<guillemotright> \<and> F \<phi> = \<phi>'"
	+ using \<mu>' \<phi>' F.locally_full [of "G (trg\<^sub>D \<mu>')" "trg\<^sub>C (G \<mu>')" \<phi>'] C.in_hhom_def G_props(1)
	+ by auto
	+ have "C.iso \<phi>"
	+ using \<phi> \<phi>' F.reflects_iso by auto
	+ thus ?thesis
	+ using \<phi> C.isomorphic_def by auto
	+ qed
	+ qed
	+
	+ lemma map\<^sub>0_eq_G\<^sub>0 [simp]:
	+ assumes "D.obj a'"
	+ shows "map\<^sub>0 a' = G\<^sub>0 a'"
	+ using assms map\<^sub>0_def C.in_hhom_def D.obj_def G_props(1) by metis
	+
	+ text \<open>
	+ We will need a naturality property of \<open>\<phi>\<close>, which amounts to the fact that the \<open>\<phi> f'\<close>
	+ are the components of a natural transformation from the functor \<open>F \<circ> G\<close> to the
	+ functor that transports \<open>\<mu>'\<close> to \<open>e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')\<close>.
	+ \<close>
	+
	+ interpretation FG: composite_functor V\<^sub>D V\<^sub>C V\<^sub>D G F ..
	+
	+ interpretation FG': "functor" V\<^sub>D V\<^sub>D \<open>\<lambda>\<mu>'. e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')\<close>
	+ proof
	+ show "\<And>\<mu>'. \<not> D.arr \<mu>' \<Longrightarrow> e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>') = D.null"
	+ using D.hseq_char' by auto
	+ show 1: "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> D.hseq (e (trg\<^sub>D \<mu>')) (\<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>'))"
	+ by (metis D.hseqI' D.in_hhomE D.obj_src D.obj_trg D.hcomp_simps(2) G\<^sub>0_props(1-2))
	+ show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> D.dom (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) =
	+ e (trg\<^sub>D (D.dom \<mu>')) \<star>\<^sub>D D.dom \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.dom \<mu>'))"
	+ using G\<^sub>0_props(3-4) \<open>\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> D.hseq (e (trg\<^sub>D \<mu>')) (\<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>'))\<close>
	+ by force
	+ show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow> D.cod (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) =
	+ e (trg\<^sub>D (D.cod \<mu>')) \<star>\<^sub>D D.cod \<mu>' \<star>\<^sub>D d (src\<^sub>D (D.cod \<mu>'))"
	+ using 1 G\<^sub>0_props(3-4) by force
	+ show "\<And>\<mu>' \<nu>'. D.seq \<mu>' \<nu>' \<Longrightarrow>
	+ e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D \<mu>' \<cdot>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) =
	+ (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<nu>') \<star>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D \<nu>'))"
	+ proof -
	+ fix \<mu>' \<nu>'
	+ assume \<mu>'\<nu>': "D.seq \<mu>' \<nu>'"
	+ have \<mu>': "\<guillemotleft>\<mu>' : src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>') \<rightarrow>\<^sub>D trg\<^sub>D \<mu>'\<guillemotright>"
	+ using \<mu>'\<nu>' D.vseq_implies_hpar by (intro D.in_hhomI, auto)
	+ have \<nu>': "\<guillemotleft>\<nu>' : src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>') \<rightarrow>\<^sub>D trg\<^sub>D \<nu>'\<guillemotright>"
	+ using \<mu>'\<nu>' D.vseq_implies_hpar by (intro D.in_hhomI, auto)
	+ show "e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D \<mu>' \<cdot>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) =
	+ (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<nu>') \<star>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D \<nu>'))"
	+ proof -
	+ have "e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D \<mu>' \<cdot>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) =
	+ e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D (\<mu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) \<cdot>\<^sub>D (\<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
	+ using \<mu>'\<nu>' D.whisker_right D.obj_src G\<^sub>0_props(4) by metis
	+ also have "... = (e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) \<star>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
	+ proof -
	+ have "D.seq (\<mu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) (\<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
	+ proof (intro D.seqI D.hseqI)
	+ show "\<guillemotleft>d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) \<rightarrow>\<^sub>D src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')\<guillemotright>"
	+ using \<mu>'\<nu>' D.obj_src by blast
	+ show "\<guillemotleft>d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')) : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) \<rightarrow>\<^sub>D src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')\<guillemotright>"
	+ by fact
	+ show "\<guillemotleft>\<mu>' : src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>') \<rightarrow>\<^sub>D trg\<^sub>D \<mu>'\<guillemotright>"
	+ using \<mu>' by simp
	+ show "\<guillemotleft>\<nu>' : src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>') \<rightarrow>\<^sub>D trg\<^sub>D \<nu>'\<guillemotright>"
	+ using \<nu>' by simp
	+ show "D.dom (\<mu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) = D.cod (\<nu>' \<star>\<^sub>D d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
	+ proof -
	+ have "D.hseq \<mu>' (d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>'))) \<and> D.hseq \<nu>' (d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
	+ using \<mu>' \<nu>' by blast
	+ moreover have "D.ide (d (src\<^sub>D (\<mu>' \<cdot>\<^sub>D \<nu>')))"
	+ using \<mu>'\<nu>' G\<^sub>0_props(4) D.obj_src by blast
	+ ultimately show ?thesis
	+ using \<mu>'\<nu>' by auto
	+ qed
	+ qed
	+ thus ?thesis
	+ using \<mu>'\<nu>' D.obj_src D.obj_trg G\<^sub>0_props(3) D.whisker_left by metis
	+ qed
	+ also have "... =
	+ (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<nu>') \<star>\<^sub>D \<nu>' \<star>\<^sub>D d (src\<^sub>D \<nu>'))"
	+ using \<mu>'\<nu>' D.src_vcomp D.trg_vcomp D.vseq_implies_hpar by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+
	+ interpretation \<phi>: transformation_by_components V\<^sub>D V\<^sub>D FG.map
	+ \<open>\<lambda>\<mu>'. e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')\<close> \<phi>
	+ proof
	+ show "\<And>f'. D.ide f' \<Longrightarrow> \<guillemotleft>\<phi> f' : FG.map f' \<Rightarrow>\<^sub>D e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')\<guillemotright>"
	+ using \<phi>_props G_ide by simp
	+ show "\<And>\<mu>'. D.arr \<mu>' \<Longrightarrow>
	+ \<phi> (D.cod \<mu>') \<cdot>\<^sub>D FG.map \<mu>' =
	+ (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
	+ proof -
	+ fix \<mu>'
	+ assume \<mu>': "D.arr \<mu>'"
	+ show "\<phi> (D.cod \<mu>') \<cdot>\<^sub>D FG.map \<mu>' = (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"
	+ proof -
	+ have "D.inv (\<phi> (D.cod \<mu>')) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>') =
	+ F (G \<mu>')"
	+ using \<mu>' G_props(3) by simp
	+ thus ?thesis
	+ using \<mu>' \<phi>_props D.iso_inv_iso D.inv_inv
	+ D.invert_side_of_triangle(1)
	+ [of "F (G \<mu>')" "D.inv (\<phi> (D.cod \<mu>'))"
	+ "(e (trg\<^sub>D \<mu>') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>')) \<cdot>\<^sub>D \<phi> (D.dom \<mu>')"]
	+ by auto
	+ qed
	+ qed
	+ qed
	+
	+ interpretation GG: "functor" D.VV.comp C.VV.comp FF
	+ using functor_FF by simp
	+ interpretation GoH\<^sub>D: composite_functor D.VV.comp V\<^sub>D V\<^sub>C
	+ \<open>\<lambda>\<mu>\<nu>. H\<^sub>D (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> G
	+ ..
	+ interpretation H\<^sub>DoGG: composite_functor D.VV.comp C.VV.comp V\<^sub>C FF
	+ \<open>\<lambda>\<mu>\<nu>. H\<^sub>C (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
	+ ..
	+
	+ text \<open>
	+ Now we need to define the composition isomorphisms \<open>\<Phi> (f', g')\<close> for each composable pair
	+ of 1-cells \<open>(f', g')\<close>. These should be 2-cells \<open>\<guillemotleft>\<Phi> (f', g') : G f' \<star>\<^sub>D G g' \<Rightarrow>\<^sub>D G (f' \<star>\<^sub>D g')\<guillemotright>\<close>.
	+ The way we obtain these is to define what the \<open>F\<close>-images \<open>F (\<Phi> (f', g'))\<close> have to be,
	+ then use local fullness and faithfulness to obtain the \<open>\<Phi> (f', g')\<close>.
	+ To prove naturality and coherence we first show that corresponding results hold for
	+ \<open>F\<close>-images and then apply faithfulness.
	+
	+ The \<open>F\<close>-images \<open>F (\<Phi> (f', g'))\<close> are 2-cells
	+ \<open>\<guillemotleft>F (\<Phi> (f', g')) : F (G f' \<star>\<^sub>D G g') \<Rightarrow>\<^sub>D F (G (f' \<star>\<^sub>D g'))\<guillemotright>\<close>.
	+ These are defined as the composition of a chain of 2-cells:
	+ \[\begin{array}{l}
	+ \<open>F (G f' \<star>\<^sub>C G g')\<close>\\
	+ \qquad \<open>\<Rightarrow>\<close> \<open>F (G f') \<star>\<^sub>D F (G g')\<close>\\
	+ \qquad \<open>\<Rightarrow>\<close> \<open>(e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f')) \<star>\<^sub>D e (trg\<^sub>D g') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g')\<close>\\
	+ \qquad \<open>\<Rightarrow>\<close> \<open>e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D (d (src\<^sub>D f') \<star>\<^sub>D e (trg\<^sub>D g')) \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g')\<close>\\
	+ \qquad \<open>\<Rightarrow>\<close> \<open>e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g')\<close>\\
	+ \qquad \<open>\<Rightarrow>\<close> \<open>e (trg\<^sub>D f') \<star>\<^sub>D (f' \<star>\<^sub>D g') \<star>\<^sub>D d (src\<^sub>D g')\<close>\\
	+ \qquad \<open>\<Rightarrow>\<close> \<open>F (G (f' \<star>\<^sub>D g'))\<close>.
	+ \end{array}\]
	+ This results in a rather large expression, which is very nasty to work with if we try
	+ to expand everything out.
	+ Instead, we express it in terms of simpler chunks obtained by translating arrows,
	+ composition, and unitors along the mapping that takes \<open>\<mu>\<close> to \<open>e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)\<close>.
	+ Since this mapping is an endo-biequivalence of \<open>D\<close> (though we don't establish this,
	+ \emph{per se}), it preserves equations that hold in \<open>D\<close> and we can work with the \<open>F\<close>-images
	+ of these equations to help establish the naturality and coherence results we need.
	+ \<close>
	+
	+ abbreviation (input) SRC
	+ where "SRC \<mu> \<equiv> d (src\<^sub>D \<mu>) \<star>\<^sub>D e (src\<^sub>D \<mu>)"
	+
	+ abbreviation (input) TRG
	+ where "TRG \<mu> \<equiv> d (trg\<^sub>D \<mu>) \<star>\<^sub>D e (trg\<^sub>D \<mu>)"
	+
	+ abbreviation (input) XLT
	+ where "XLT \<mu> \<equiv> e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)"
	+
	+ definition LUNIT
	+ where "LUNIT f \<equiv> \<l>\<^sub>D[f] \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D f)) \<star>\<^sub>D f)"
	+
	+ definition RUNIT
	+ where "RUNIT f \<equiv> \<r>\<^sub>D[f] \<cdot>\<^sub>D (f \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D f)))"
	+
	+ text \<open>
	+ Here we prove a series of results that would be automatic if we had some notion of
	+ ``bicategory \<open>D\<close> with \<open>SRC\<close> and \<open>TRG\<close> as alternative source and target''.
	+ Perhaps this idea can be developed in future work and used to simplify the overall
	+ development. For the current project, it is the end result (obtaining the converse
	+ equivalence pseudofunctor) that I am primarily interested in.
	+ \<close>
	+
	+ lemma LUNIT_in_hom [intro]:
	+ assumes "D.ide f"
	+ shows "\<guillemotleft>LUNIT f : src\<^sub>D f \<rightarrow>\<^sub>D trg\<^sub>D f\<guillemotright>"
	+ and "\<guillemotleft>LUNIT f : TRG f \<star>\<^sub>D f \<Rightarrow>\<^sub>D f\<guillemotright>"
	+ proof -
	+ interpret e_trg_f: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (trg\<^sub>D f)\<close> \<open>d (trg\<^sub>D f)\<close> \<open>\<eta> (trg\<^sub>D f)\<close> \<open>\<epsilon> (trg\<^sub>D f)\<close>
	+ using assms G\<^sub>0_props [of "trg\<^sub>D f"] by simp
	+ show "\<guillemotleft>LUNIT f : src\<^sub>D f \<rightarrow>\<^sub>D trg\<^sub>D f\<guillemotright>"
	+ unfolding LUNIT_def
	+ using assms e_trg_f.unit_is_iso D.hseqI' by auto
	+ show "\<guillemotleft>LUNIT f : TRG f \<star>\<^sub>D f \<Rightarrow>\<^sub>D f\<guillemotright>"
	+ unfolding LUNIT_def
	+ using assms e_trg_f.unit_is_iso D.hseqI' by auto
	+ qed
	+
	+ lemma LUNIT_simps [simp]:
	+ assumes "D.ide f"
	+ shows "D.arr (LUNIT f)"
	+ and "src\<^sub>D (LUNIT f) = src\<^sub>D f" and "trg\<^sub>D (LUNIT f) = trg\<^sub>D f"
	+ and "D.dom (LUNIT f) = TRG f \<star>\<^sub>D f"
	+ and "D.cod (LUNIT f) = f"
	+ using assms LUNIT_in_hom by auto
	+
	+ lemma RUNIT_in_hom [intro]:
	+ assumes "D.ide f"
	+ shows "\<guillemotleft>RUNIT f : src\<^sub>D f \<rightarrow>\<^sub>D trg\<^sub>D f\<guillemotright>"
	+ and "\<guillemotleft>RUNIT f : f \<star>\<^sub>D SRC f \<Rightarrow>\<^sub>D f\<guillemotright>"
	+ proof -
	+ interpret e_src_f: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (src\<^sub>D f)\<close> \<open>d (src\<^sub>D f)\<close> \<open>\<eta> (src\<^sub>D f)\<close> \<open>\<epsilon> (src\<^sub>D f)\<close>
	+ using assms G\<^sub>0_props [of "src\<^sub>D f"] by simp
	+ show "\<guillemotleft>RUNIT f : src\<^sub>D f \<rightarrow>\<^sub>D trg\<^sub>D f\<guillemotright>"
	+ unfolding RUNIT_def
	+ using assms e_src_f.unit_is_iso D.hseqI' by auto
	+ show "\<guillemotleft>RUNIT f : f \<star>\<^sub>D SRC f \<Rightarrow>\<^sub>D f\<guillemotright>"
	+ unfolding RUNIT_def
	+ using assms e_src_f.unit_is_iso D.hseqI' by auto
	+ qed
	+
	+ lemma RUNIT_simps [simp]:
	+ assumes "D.ide f"
	+ shows "D.arr (RUNIT f)"
	+ and "src\<^sub>D (RUNIT f) = src\<^sub>D f" and "trg\<^sub>D (RUNIT f) = trg\<^sub>D f"
	+ and "D.dom (RUNIT f) = f \<star>\<^sub>D SRC f"
	+ and "D.cod (RUNIT f) = f"
	+ using assms RUNIT_in_hom by auto
	+
	+ lemma iso_LUNIT:
	+ assumes "D.ide f"
	+ shows "D.iso (LUNIT f)"
	+ proof -
	+ interpret e_trg_f: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (trg\<^sub>D f)\<close> \<open>d (trg\<^sub>D f)\<close> \<open>\<eta> (trg\<^sub>D f)\<close> \<open>\<epsilon> (trg\<^sub>D f)\<close>
	+ using assms G\<^sub>0_props [of "trg\<^sub>D f"] by simp
	+ show ?thesis
	+ using assms e_trg_f.unit_is_iso D.iso_inv_iso D.iso_lunit LUNIT_def LUNIT_simps(1)
	+ by auto
	+ qed
	+
	+ lemma iso_RUNIT:
	+ assumes "D.ide f"
	+ shows "D.iso (RUNIT f)"
	+ proof -
	+ interpret e_src_f: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (src\<^sub>D f)\<close> \<open>d (src\<^sub>D f)\<close> \<open>\<eta> (src\<^sub>D f)\<close> \<open>\<epsilon> (src\<^sub>D f)\<close>
	+ using assms G\<^sub>0_props [of "src\<^sub>D f"] by simp
	+ show ?thesis
	+ using assms e_src_f.unit_is_iso D.iso_inv_iso D.iso_runit RUNIT_def RUNIT_simps(1)
	+ by auto
	+ qed
	+
	+ lemma LUNIT_naturality:
	+ assumes "D.arr \<mu>"
	+ shows "\<mu> \<cdot>\<^sub>D LUNIT (D.dom \<mu>) = LUNIT (D.cod \<mu>) \<cdot>\<^sub>D (TRG \<mu> \<star>\<^sub>D \<mu>)"
	+ proof -
	+ interpret e_trg_\<mu>: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (trg\<^sub>D \<mu>)\<close> \<open>d (trg\<^sub>D \<mu>)\<close> \<open>\<eta> (trg\<^sub>D \<mu>)\<close> \<open>\<epsilon> (trg\<^sub>D \<mu>)\<close>
	+ using assms G\<^sub>0_props [of "trg\<^sub>D \<mu>"] by simp
	+ show ?thesis
	+ proof -
	+ have "\<mu> \<cdot>\<^sub>D LUNIT (D.dom \<mu>) =
	+ (\<mu> \<cdot>\<^sub>D \<l>\<^sub>D[D.dom \<mu>]) \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D \<mu>)) \<star>\<^sub>D D.dom \<mu>)"
	+ unfolding LUNIT_def
	+ using assms D.comp_assoc by simp
	+ also have "... = \<l>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (trg\<^sub>D \<mu> \<star>\<^sub>D \<mu>) \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D \<mu>)) \<star>\<^sub>D D.dom \<mu>)"
	+ using assms D.lunit_naturality [of \<mu>] D.comp_assoc by simp
	+ also have "... = \<l>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D \<mu>)) \<star>\<^sub>D \<mu>)"
	+ using assms D.interchange [of "trg\<^sub>D \<mu>" "D.inv (\<eta> (trg\<^sub>D \<mu>))" \<mu> "D.dom \<mu>"]
	+ e_trg_\<mu>.unit_is_iso D.comp_arr_dom D.comp_cod_arr by simp
	+ also have "... = \<l>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D \<mu>)) \<star>\<^sub>D D.cod \<mu>) \<cdot>\<^sub>D (TRG \<mu> \<star>\<^sub>D \<mu>)"
	+ using assms D.interchange [of "D.inv (\<eta> (trg\<^sub>D \<mu>))" "TRG \<mu>" "D.cod \<mu>" \<mu>]
	+ e_trg_\<mu>.unit_is_iso D.comp_arr_dom D.comp_cod_arr by simp
	+ also have "... = LUNIT (D.cod \<mu>) \<cdot>\<^sub>D (TRG \<mu> \<star>\<^sub>D \<mu>)"
	+ unfolding LUNIT_def
	+ using assms D.comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma RUNIT_naturality:
	+ assumes "D.arr \<mu>"
	+ shows "\<mu> \<cdot>\<^sub>D RUNIT (D.dom \<mu>) = RUNIT (D.cod \<mu>) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D SRC \<mu>)"
	+ proof -
	+ interpret e_src_\<mu>: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (src\<^sub>D \<mu>)\<close> \<open>d (src\<^sub>D \<mu>)\<close> \<open>\<eta> (src\<^sub>D \<mu>)\<close> \<open>\<epsilon> (src\<^sub>D \<mu>)\<close>
	+ using assms G\<^sub>0_props [of "src\<^sub>D \<mu>"] by simp
	+ show ?thesis
	+ proof -
	+ have "\<mu> \<cdot>\<^sub>D RUNIT (D.dom \<mu>) =
	+ (\<mu> \<cdot>\<^sub>D \<r>\<^sub>D[D.dom \<mu>]) \<cdot>\<^sub>D (D.dom \<mu> \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D \<mu>)))"
	+ unfolding RUNIT_def
	+ using assms D.comp_assoc by simp
	+ also have "... = \<r>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D src\<^sub>D \<mu>) \<cdot>\<^sub>D (D.dom \<mu> \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D \<mu>)))"
	+ using assms D.runit_naturality [of \<mu>] D.comp_assoc by simp
	+ also have "... = \<r>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D \<mu>)))"
	+ using assms D.interchange [of \<mu> "D.dom \<mu>" "src\<^sub>D \<mu>" "D.inv (\<eta> (src\<^sub>D \<mu>))"]
	+ e_src_\<mu>.unit_is_iso D.comp_arr_dom D.comp_cod_arr by simp
	+ also have "... = \<r>\<^sub>D[D.cod \<mu>] \<cdot>\<^sub>D (D.cod \<mu> \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D \<mu>))) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D SRC \<mu>)"
	+ using assms D.interchange [of "D.cod \<mu>" \<mu> "D.inv (\<eta> (src\<^sub>D \<mu>))" "SRC \<mu>"]
	+ e_src_\<mu>.unit_is_iso D.comp_arr_dom D.comp_cod_arr
	+ by simp
	+ also have "... = RUNIT (D.cod \<mu>) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D SRC \<mu>)"
	+ unfolding RUNIT_def
	+ using assms D.comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma LUNIT_hcomp:
	+ assumes "D.ide f" and "D.ide g" and "src\<^sub>D f = trg\<^sub>D g"
	+ shows "LUNIT (f \<star>\<^sub>D g) \<cdot>\<^sub>D \<a>\<^sub>D[d (trg\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D f), f, g] = LUNIT f \<star>\<^sub>D g"
	+ proof -
	+ interpret e_trg_f: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (trg\<^sub>D f)\<close> \<open>d (trg\<^sub>D f)\<close> \<open>\<eta> (trg\<^sub>D f)\<close> \<open>\<epsilon> (trg\<^sub>D f)\<close>
	+ using assms G\<^sub>0_props [of "trg\<^sub>D f"] by simp
	+ have "LUNIT (f \<star>\<^sub>D g) \<cdot>\<^sub>D \<a>\<^sub>D[TRG f, f, g] =
	+ \<l>\<^sub>D[f \<star>\<^sub>D g] \<cdot>\<^sub>D (D.inv (\<eta> (trg\<^sub>D f)) \<star>\<^sub>D f \<star>\<^sub>D g) \<cdot>\<^sub>D \<a>\<^sub>D[TRG f, f, g]"
	+ unfolding LUNIT_def
	+ using assms D.comp_assoc by simp
	+ also have "... = (\<l>\<^sub>D[f \<star>\<^sub>D g] \<cdot>\<^sub>D \<a>\<^sub>D[trg\<^sub>D f, f, g]) \<cdot>\<^sub>D ((D.inv (\<eta> (trg\<^sub>D f)) \<star>\<^sub>D f) \<star>\<^sub>D g)"
	+ using assms D.assoc_naturality [of "D.inv (\<eta> (trg\<^sub>D f))" f g] e_trg_f.unit_is_iso
	+ D.comp_assoc
	+ by simp
	+ also have "... = (\<l>\<^sub>D[f] \<star>\<^sub>D g) \<cdot>\<^sub>D ((D.inv (\<eta> (trg\<^sub>D f)) \<star>\<^sub>D f) \<star>\<^sub>D g)"
	+ using assms D.lunit_hcomp [of f g] by simp
	+ also have "... = LUNIT f \<star>\<^sub>D g"
	+ using assms LUNIT_def LUNIT_simps(1) D.whisker_right [of g] by auto
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma RUNIT_hcomp:
	+ assumes "D.ide f" and "D.ide g" and "src\<^sub>D f = trg\<^sub>D g"
	+ shows "RUNIT (f \<star>\<^sub>D g) = (f \<star>\<^sub>D RUNIT g) \<cdot>\<^sub>D \<a>\<^sub>D[f, g, SRC g]"
	+ proof -
	+ interpret e_src_g: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (src\<^sub>D g)\<close> \<open>d (src\<^sub>D g)\<close> \<open>\<eta> (src\<^sub>D g)\<close> \<open>\<epsilon> (src\<^sub>D g)\<close>
	+ using assms G\<^sub>0_props [of "src\<^sub>D g"] by simp
	+ have "(f \<star>\<^sub>D RUNIT g) \<cdot>\<^sub>D \<a>\<^sub>D[f, g, SRC g] =
	+ (f \<star>\<^sub>D \<r>\<^sub>D[g]) \<cdot>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D g))) \<cdot>\<^sub>D \<a>\<^sub>D[f, g, SRC g]"
	+ unfolding RUNIT_def
	+ using assms D.whisker_left [of f "\<r>\<^sub>D[g]" "g \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D g))"] e_src_g.unit_is_iso
	+ D.hseqI' D.comp_assoc
	+ by simp
	+ also have "... = ((f \<star>\<^sub>D \<r>\<^sub>D[g]) \<cdot>\<^sub>D \<a>\<^sub>D[f, g, src\<^sub>D g]) \<cdot>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D g)))"
	+ using assms D.assoc_naturality [of f g "D.inv (\<eta> (src\<^sub>D g))"] e_src_g.unit_is_iso
	+ D.comp_assoc
	+ by simp
	+ also have "... = \<r>\<^sub>D[f \<star>\<^sub>D g] \<cdot>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D D.inv (\<eta> (src\<^sub>D g)))"
	+ using assms D.runit_hcomp [of f g] by simp
	+ also have "... = RUNIT (f \<star>\<^sub>D g)"
	+ using assms RUNIT_def by simp
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma TRIANGLE:
	+ assumes "D.ide f" and "D.ide g" and "src\<^sub>D f = trg\<^sub>D g"
	+ shows "(f \<star>\<^sub>D LUNIT g) \<cdot>\<^sub>D \<a>\<^sub>D[f, SRC f, g] = RUNIT f \<star>\<^sub>D g"
	+ proof -
	+ interpret e_trg_g: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (trg\<^sub>D g)\<close> \<open>d (trg\<^sub>D g)\<close> \<open>\<eta> (trg\<^sub>D g)\<close> \<open>\<epsilon> (trg\<^sub>D g)\<close>
	+ using assms G\<^sub>0_props [of "trg\<^sub>D g"] by simp
	+ show ?thesis
	+ proof -
	+ have "(f \<star>\<^sub>D LUNIT g) \<cdot>\<^sub>D \<a>\<^sub>D[f, SRC f, g] =
	+ (f \<star>\<^sub>D \<l>\<^sub>D[g]) \<cdot>\<^sub>D (f \<star>\<^sub>D D.inv (\<eta> (trg\<^sub>D g)) \<star>\<^sub>D g) \<cdot>\<^sub>D \<a>\<^sub>D[f, SRC f, g]"
	+ using assms D.whisker_left [of f "\<l>\<^sub>D[g]" "D.inv (\<eta> (trg\<^sub>D g)) \<star>\<^sub>D g"] e_trg_g.unit_is_iso
	+ LUNIT_def LUNIT_simps(1) D.comp_assoc
	+ by auto
	+ also have "... = ((f \<star>\<^sub>D \<l>\<^sub>D[g]) \<cdot>\<^sub>D \<a>\<^sub>D[f, src\<^sub>D f, g]) \<cdot>\<^sub>D ((f \<star>\<^sub>D D.inv (\<eta> (trg\<^sub>D g))) \<star>\<^sub>D g)"
	+ using assms D.assoc_naturality [of f "D.inv (\<eta> (trg\<^sub>D g))" g] e_trg_g.unit_is_iso
	+ D.comp_assoc
	+ by auto
	+ also have "... = (\<r>\<^sub>D[f] \<star>\<^sub>D g) \<cdot>\<^sub>D ((f \<star>\<^sub>D D.inv (\<eta> (trg\<^sub>D g))) \<star>\<^sub>D g)"
	+ using assms D.triangle by simp
	+ also have "... = RUNIT f \<star>\<^sub>D g"
	+ using assms D.whisker_right [of g "\<r>\<^sub>D[f]" "D.inv (\<eta> (trg\<^sub>D g))"] e_trg_g.unit_is_iso
	+ RUNIT_def RUNIT_simps D.whisker_right
	+ by metis
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ definition CMP
	+ where "CMP f g \<equiv> (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g)"
	+
	+ text \<open>
	+ The 2-cell \<open>CMP f g\<close> has the right type to be a component of the compositor of a pseudofunctor
	+ whose underlying mapping is \<open>XLT\<close>. This pseudofunctor ought to be an endo-biequivalence
	+ of \<open>D\<close>, though we don't go so far as to show that.
	+ \<close>
	+
	+ lemma CMP_in_hom [intro]:
	+ assumes "D.ide f" and "D.ide g" and "src\<^sub>D f = trg\<^sub>D g"
	+ shows "\<guillemotleft>CMP f g : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D g)) \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f))\<guillemotright>"
	+ and "\<guillemotleft>CMP f g : XLT f \<star>\<^sub>D XLT g \<Rightarrow>\<^sub>D XLT (f \<star>\<^sub>D g)\<guillemotright>"
	+ proof -
	+ show 1: "\<guillemotleft>CMP f g : XLT f \<star>\<^sub>D XLT g \<Rightarrow>\<^sub>D XLT (f \<star>\<^sub>D g)\<guillemotright>"
	+ apply (unfold CMP_def, intro D.comp_in_homI)
	+ using assms by fastforce+
	+ thus "\<guillemotleft>CMP f g : F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D g)) \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f))\<guillemotright>"
	+ using assms D.src_cod [of "CMP f g"] D.trg_cod [of "CMP f g"] D.hseqI'
	+ by fastforce
	+ qed
	+
	+ lemma CMP_simps [simp]:
	+ assumes "D.ide f" and "D.ide g" and "src\<^sub>D f = trg\<^sub>D g"
	+ shows "D.arr (CMP f g)"
	+ and "src\<^sub>D (CMP f g) = F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D g))"
	+ and "trg\<^sub>D (CMP f g) = F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f))"
	+ and "D.dom (CMP f g) = XLT f \<star>\<^sub>D XLT g"
	+ and "D.cod (CMP f g) = XLT (f \<star>\<^sub>D g)"
	+ using assms CMP_in_hom [of f g] by auto
	+
	+ text \<open>
	+ The \<open>CMP f g\<close> also satisfy the naturality conditions required of compositors.
	+ \<close>
	+
	+ lemma CMP_naturality:
	+ assumes "D.arr \<mu>" and "D.arr \<nu>" and "src\<^sub>D \<mu> = trg\<^sub>D \<nu>"
	+ shows "CMP (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D (XLT \<mu> \<star>\<^sub>D XLT \<nu>) =
	+ XLT (\<mu> \<star>\<^sub>D \<nu>) \<cdot>\<^sub>D CMP (D.dom \<mu>) (D.dom \<nu>)"
	+ proof -
	+ have "CMP (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D (XLT \<mu> \<star>\<^sub>D XLT \<nu>) =
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.cod \<nu>)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu>, d (src\<^sub>D \<mu>), XLT (D.cod \<nu>)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.cod \<nu>)) \<cdot>\<^sub>D
	+ (XLT \<mu> \<star>\<^sub>D XLT \<nu>)"
	+ unfolding CMP_def using assms D.comp_assoc by simp
	+ also have
	+ "... = (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.cod \<nu>)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu>, d (src\<^sub>D \<mu>), XLT (D.cod \<nu>)] \<cdot>\<^sub>D
	+ (((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<star>\<^sub>D XLT \<nu>)) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
	+ proof -
	+ have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.cod \<nu>)) \<cdot>\<^sub>D
	+ (XLT \<mu> \<star>\<^sub>D XLT \<nu>) =
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>)] \<cdot>\<^sub>D XLT \<mu> \<star>\<^sub>D XLT (D.cod \<nu>) \<cdot>\<^sub>D XLT \<nu>"
	+ using assms G\<^sub>0_props
	+ D.interchange
	+ [of "\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>)]" "XLT \<mu>" "XLT (D.cod \<nu>)" "XLT \<nu>"]
	+ by fastforce
	+ also have
	+ "... = ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D
	+ XLT (D.cod \<nu>) \<cdot>\<^sub>D XLT \<nu>"
	+ using assms G\<^sub>0_props D.assoc'_naturality [of "e (trg\<^sub>D \<mu>)" \<mu> "d (src\<^sub>D \<mu>)"] by simp
	+ also have
	+ "... = ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D
	+ XLT \<nu> \<cdot>\<^sub>D XLT (D.dom \<nu>)"
	+ using assms G\<^sub>0_props D.comp_arr_dom D.comp_cod_arr D.src_cod D.src_dom
	+ D.trg_cod D.trg_dom FG'.naturality
	+ by presburger
	+ also have "... = (((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
	+ proof -
	+ have "D.seq ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)]"
	+ using assms G\<^sub>0_props D.hseqI' by auto
	+ moreover have "D.seq (XLT \<nu>) (XLT (D.dom \<nu>))"
	+ using assms G\<^sub>0_props D.hseqI' by auto
	+ moreover have "src\<^sub>D ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) = trg\<^sub>D (XLT \<nu>)"
	+ using assms G\<^sub>0_props by (simp add: D.hseqI')
	+ ultimately show ?thesis
	+ using assms G\<^sub>0_props
	+ D.interchange
	+ [of "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)" "\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)]"
	+ "XLT \<nu>" "XLT (D.dom \<nu>)"]
	+ by simp
	+ qed
	+ finally have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.cod \<nu>)) \<cdot>\<^sub>D
	+ (XLT \<mu> \<star>\<^sub>D XLT \<nu>) =
	+ (((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.cod \<nu>)] \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
	+ proof -
	+ have "\<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu>, d (src\<^sub>D \<mu>), XLT (D.cod \<nu>)] \<cdot>\<^sub>D
	+ (((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<star>\<^sub>D XLT \<nu>) =
	+ ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)]"
	+ using assms D.assoc_naturality [of "e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>" "d (src\<^sub>D \<mu>)" "XLT \<nu>"]
	+ by (simp add: D.hseqI')
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.dom \<nu>)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
	+ proof -
	+ have "\<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.cod \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.cod \<nu>)] \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>) \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>) =
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.dom \<nu>)]"
	+ using assms D.hseqI' D.assoc_naturality [of "e (trg\<^sub>D \<mu>)" \<mu> "d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>"]
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D SRC \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.dom \<nu>)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
	+ proof -
	+ have
	+ "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>) =
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)])"
	+ proof -
	+ have
	+ "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>) =
	+ e (trg\<^sub>D \<mu>) \<star>\<^sub>D
	+ (D.cod \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (\<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>)"
	+ using assms D.hseqI' G\<^sub>0_props D.whisker_left by simp
	+ also have "... = e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)] \<cdot>\<^sub>D
	+ (d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>)"
	+ using assms D.hseqI' D.comp_cod_arr
	+ D.interchange
	+ [of "D.cod \<mu>" \<mu> "\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]"
	+ "d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT \<nu>"]
	+ by simp
	+ also have "... = e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D (TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]"
	+ using assms D.hseqI' G\<^sub>0_props
	+ D.assoc'_naturality [of "d (src\<^sub>D \<mu>)" "e (trg\<^sub>D \<nu>)" "\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)"]
	+ by simp
	+ also have "... = e (trg\<^sub>D \<mu>) \<star>\<^sub>D (\<mu> \<star>\<^sub>D TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
	+ (D.dom \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)])"
	+ using assms D.hseqI' G\<^sub>0_props D.comp_arr_dom
	+ D.interchange
	+ [of \<mu> "D.dom \<mu>" "TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)"
	+ "\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]"]
	+ by simp
	+ also have
	+ "... = (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)])"
	+ using assms D.hseqI' G\<^sub>0_props D.whisker_left by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.dom \<nu>)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
	+ proof -
	+ have "((e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) =
	+ e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D
	+ LUNIT (D.cod (\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) \<cdot>\<^sub>D
	+ ((d (src\<^sub>D \<mu>) \<star>\<^sub>D e (trg\<^sub>D \<nu>)) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))"
	+ using assms D.hseqI' D.comp_arr_dom D.comp_cod_arr D.whisker_left
	+ D.interchange [of "D.cod \<mu>" \<mu> "LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))"
	+ "(d (src\<^sub>D \<mu>) \<star>\<^sub>D e (trg\<^sub>D \<nu>)) \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)"]
	+ by fastforce
	+ also have "... =
	+ e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D (\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))"
	+ using assms D.hseqI' LUNIT_naturality [of "\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)"] by simp
	+ also have "... = (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)))"
	+ using assms D.hseqI' D.comp_arr_dom D.comp_cod_arr D.whisker_left
	+ D.interchange [of \<mu> "D.dom \<mu>" "\<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)" "LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))"]
	+ by simp
	+ finally have
	+ "((e (trg\<^sub>D (D.cod \<mu>)) \<star>\<^sub>D D.cod \<mu> \<star>\<^sub>D LUNIT (D.cod \<nu> \<star>\<^sub>D d (src\<^sub>D (D.cod \<nu>)))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D TRG \<nu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) =
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)))"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ XLT (\<mu> \<star>\<^sub>D \<nu>) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.dom \<mu>, D.dom \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D LUNIT (D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu> \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D \<mu>), e (trg\<^sub>D \<nu>), D.dom \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>) \<star>\<^sub>D XLT (D.dom \<nu>)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D \<mu>) \<star>\<^sub>D D.dom \<mu>, d (src\<^sub>D \<mu>), XLT (D.dom \<nu>)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D \<mu>), D.dom \<mu>, d (src\<^sub>D \<mu>)] \<star>\<^sub>D XLT (D.dom \<nu>))"
	+ proof -
	+ have "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) =
	+ XLT (\<mu> \<star>\<^sub>D \<nu>) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.dom \<mu>, D.dom \<nu>, d (src\<^sub>D \<nu>)])"
	+ proof -
	+ have "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>)) =
	+ e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)] \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D \<nu> \<star>\<^sub>D d (src\<^sub>D \<nu>))"
	+ using assms D.hseqI'
	+ D.whisker_left [of "e (trg\<^sub>D \<mu>)" "\<a>\<^sub>D\<^sup>-\<^sup>1[D.cod \<mu>, D.cod \<nu>, d (src\<^sub>D \<nu>)]"]
	+ by simp
	+ also have "... = e (trg\<^sub>D \<mu>) \<star>\<^sub>D ((\<mu> \<star>\<^sub>D \<nu>) \<star>\<^sub>D d (src\<^sub>D \<nu>)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[D.dom \<mu>, D.dom \<nu>, d (src\<^sub>D \<nu>)]"
	+ using assms D.hseqI' D.assoc'_naturality [of \<mu> \<nu> "d (src\<^sub>D \<nu>)"] by simp
	+ also have "... = XLT (\<mu> \<star>\<^sub>D \<nu>) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[D.dom \<mu>, D.dom \<nu>, d (src\<^sub>D \<nu>)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = XLT (\<mu> \<star>\<^sub>D \<nu>) \<cdot>\<^sub>D CMP (D.dom \<mu>) (D.dom \<nu>)"
	+ unfolding CMP_def using assms D.comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+
	+ interpretation E: self_evaluation_map V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ abbreviation (input) SRCt ("\<^bold>S\<^bold>R\<^bold>C")
	+ where "\<^bold>S\<^bold>R\<^bold>C \<mu> \<equiv> \<^bold>\<langle>d (src\<^sub>D \<mu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>e (src\<^sub>D \<mu>)\<^bold>\<rangle>"
	+
	+ abbreviation (input) TRGt ("\<^bold>T\<^bold>R\<^bold>G")
	+ where "\<^bold>T\<^bold>R\<^bold>G \<mu> \<equiv> \<^bold>\<langle>d (trg\<^sub>D \<mu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>e (trg\<^sub>D \<mu>)\<^bold>\<rangle>"
	+
	+ abbreviation (input) XLTt ("\<^bold>X\<^bold>L\<^bold>T")
	+ where "\<^bold>X\<^bold>L\<^bold>T \<mu> \<equiv> \<^bold>\<langle>e (trg\<^sub>D \<mu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<mu>\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D \<mu>)\<^bold>\<rangle>"
	+
	+ text \<open>
	+ The \<open>CMP f g\<close> satisfy the coherence conditions with respect to associativity that are
	+ required of compositors.
	+ \<close>
	+
	+ (* TODO: This is a nasty proof that I would like to shorten somehow. *)
	+
	+ lemma CMP_coherence:
	+ assumes "D.ide f" and "D.ide g" and "D.ide h" and "src\<^sub>D f = trg\<^sub>D g" and "src\<^sub>D g = trg\<^sub>D h"
	+ shows "XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D (CMP f g \<star>\<^sub>D XLT h) =
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ text \<open>
	+ The overall strategy of the proof is to expand the definition of \<open>CMP\<close> on the
	+ left and right-hand sides, then permute the occurrences of \<open>LUNIT\<close> and
	+ \<open>RUNIT\<close> to the left ends of both the left-hand side and right-hand side of the
	+ equation to be proved, so that the initial portions of these expressions become
	+ identical and the remaining parts to the right consist only of canonical isomorphisms.
	+ Then the Coherence Theorem is applied to prove syntactically (and automatically) that the
	+ canonical parts are equal, which implies equality of the complete expressions.
	+ The rest is just grinding through the calculations.
	+ \<close>
	+ have "XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D (CMP f g \<star>\<^sub>D XLT h) =
	+ XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g)
	+ \<star>\<^sub>D XLT h)"
	+ unfolding CMP_def using assms D.comp_assoc by simp
	+ also have
	+ "... =
	+ XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g)
	+ \<star>\<^sub>D XLT h) =
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ using assms D.hseqI' D.whisker_right by simp (* 15 sec *)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D (LUNIT h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]"
	+ using assms LUNIT_hcomp [of h "d (src\<^sub>D h)"] D.hseqI' D.invert_side_of_triangle
	+ by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
	+ using assms D.whisker_left D.hseqI' by simp
	+ finally have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)] \<cdot>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.whisker_left D.hseqI' by simp
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
	+ (((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]"
	+ using assms D.assoc'_naturality [of "f \<star>\<^sub>D g" "LUNIT h" "d (src\<^sub>D h)"] by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ using assms D.whisker_left D.hseqI' by simp
	+ finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by simp
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)"
	+ using assms D.hseqI' D.assoc_naturality [of f g "LUNIT h"] by simp
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by simp
	+ finally have
	+ "XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h))"
	+ by simp
	+ thus ?thesis using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h"
	+ using assms TRIANGLE [of f "g \<star>\<^sub>D d (src\<^sub>D g)"] D.invert_side_of_triangle D.hseqI'
	+ by simp
	+ also have "... = ((e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h)"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by simp
	+ finally have "((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h) =
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)])
	+ \<star>\<^sub>D XLT h)"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D TRG g, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)] \<cdot>\<^sub>D (RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g))) \<star>\<^sub>D XLT h"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D ((RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D TRG g, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h"
	+ using assms D.assoc'_naturality [of "RUNIT f" g "d (src\<^sub>D g)"] by simp
	+ also have "... = ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D TRG g, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h)"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by simp
	+ finally have "((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) =
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D TRG g, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h)"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) =
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by simp
	+ also have "... = ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h"
	+ using assms D.hseqI' D.assoc'_naturality [of "e (trg\<^sub>D f)" "RUNIT f \<star>\<^sub>D g" "d (src\<^sub>D g)"]
	+ by simp
	+ also have "... = (((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h)"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by simp
	+ finally have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) =
	+ (((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h)"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g)) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g)) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g)) \<star>\<^sub>D XLT h) =
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]"
	+ using assms D.hseqI'
	+ D.assoc_naturality [of "e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)" "d (src\<^sub>D g)" "XLT h"]
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "\<a>\<^sub>D[e (trg\<^sub>D f), f \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g)) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]"
	+ using assms D.hseqI'
	+ D.assoc_naturality [of "e (trg\<^sub>D f)" "RUNIT f \<star>\<^sub>D g" "d (src\<^sub>D g) \<star>\<^sub>D XLT h"]
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)])) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)] \<cdot>\<^sub>D (d (src\<^sub>D g) \<star>\<^sub>D XLT h)"
	+ using assms D.hseqI' D.comp_cod_arr D.whisker_left [of "e (trg\<^sub>D f)"]
	+ D.interchange [of "f \<star>\<^sub>D g" "RUNIT f \<star>\<^sub>D g"]
	+ by simp
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]"
	+ using assms D.hseqI' D.comp_arr_dom by simp
	+ finally have "((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D XLT h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]"
	+ using assms D.hseqI' D.comp_arr_dom D.comp_cod_arr D.whisker_left
	+ D.interchange [of "f \<star>\<^sub>D g" "RUNIT f \<star>\<^sub>D g"
	+ "\<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]"
	+ "\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]"]
	+ by simp (* 10 sec *)
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.comp_arr_dom D.whisker_left
	+ D.interchange [of "RUNIT f \<star>\<^sub>D g" "(f \<star>\<^sub>D SRC f) \<star>\<^sub>D g"
	+ "\<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]"
	+ "\<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]"]
	+ by simp
	+ finally have
	+ "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D
	+ (\<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]"
	+ using assms D.hseqI' D.whisker_left by simp
	+ also have
	+ "... = e (trg\<^sub>D f) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[f, g, ((d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]"
	+ proof -
	+ have "(\<a>\<^sub>D\<^sup>-\<^sup>1[f, g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)]) =
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, g, ((d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]"
	+ using assms D.pentagon' D.comp_assoc by simp
	+ moreover have "D.inv (\<a>\<^sub>D\<^sup>-\<^sup>1[f, g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) =
	+ \<a>\<^sub>D[f, g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)"
	+ using assms D.hseqI' D.iso_inv_iso by simp
	+ ultimately show ?thesis
	+ using assms D.hseqI' D.iso_inv_iso D.comp_assoc
	+ D.invert_opposite_sides_of_square
	+ [of "\<a>\<^sub>D\<^sup>-\<^sup>1[f, g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)"
	+ "\<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ "\<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)]"
	+ "\<a>\<^sub>D\<^sup>-\<^sup>1[f, g, ((d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]"]
	+ by simp (* 10 sec *)
	+ qed
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, TRG h \<star>\<^sub>D h] \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, (d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D
	+ \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ ((RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
	+ (RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]"
	+ using assms D.hseqI'
	+ D.assoc_naturality [of "RUNIT f" g "\<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]"]
	+ by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (RUNIT f \<star>\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h), h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h), h, d (src\<^sub>D h)] =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of "RUNIT f" "f \<star>\<^sub>D SRC f"
	+ "g \<star>\<^sub>D ((TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
	+ "g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]"]
	+ by simp (* 20 sec *)
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D
	+ (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' TRIANGLE [of f "g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
	+ by simp
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D
	+ \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left D.comp_assoc by simp
	+ finally have
	+ "e (trg\<^sub>D f) \<star>\<^sub>D RUNIT f \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)] =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D
	+ \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D g), g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]"
	+ using assms D.hseqI' LUNIT_hcomp [of g "(TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
	+ D.invert_side_of_triangle
	+ by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ (LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left by simp
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ ((LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]"
	+ using assms D.hseqI'
	+ D.assoc'_naturality [of "LUNIT g" "TRG h \<star>\<^sub>D h" "d (src\<^sub>D h)"]
	+ by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D SRC g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ (f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left by simp
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
	+ ((f \<star>\<^sub>D LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]"
	+ using assms D.hseqI'
	+ D.assoc'_naturality [of f "LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h" "d (src\<^sub>D h)"]
	+ by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)"
	+ using assms D.hseqI' D.whisker_left D.whisker_right D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of g "LUNIT g" "LUNIT h" "(d (trg\<^sub>D h) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h"]
	+ by simp (* 10 sec *)
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ finally have
	+ L: "XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D (CMP f g \<star>\<^sub>D XLT h) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D
	+ \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+ by simp
	+
	+ have "CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D \<a>\<^sub>D[XLT f, XLT g, XLT h] =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT ((g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D
	+ (e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ unfolding CMP_def using assms D.comp_assoc by simp
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT ((g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "XLT f \<star>\<^sub>D
	+ (e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) =
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h)"
	+ using assms D.hseqI' D.whisker_left by auto (* 15 sec *)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT ((g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ (LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]"
	+ using assms D.hseqI' LUNIT_hcomp [of "g \<star>\<^sub>D h" "d (src\<^sub>D h)"]
	+ D.invert_side_of_triangle
	+ by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT ((g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left by simp
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
	+ ((f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]"
	+ using assms D.hseqI' D.assoc'_naturality [of f "LUNIT (g \<star>\<^sub>D h)" "d (src\<^sub>D h)"]
	+ LUNIT_in_hom [of "g \<star>\<^sub>D h"]
	+ by auto
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ ((XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h)) =
	+ XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D
	+ (RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h, h \<star>\<^sub>D d (src\<^sub>D h)]"
	+ using assms D.hseqI' TRIANGLE [of g "h \<star>\<^sub>D d (src\<^sub>D h)"] D.invert_side_of_triangle
	+ by simp
	+ also have "... = (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h, h \<star>\<^sub>D d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D LUNIT (h \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, TRG h, h \<star>\<^sub>D d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)) =
	+ XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)] \<cdot>\<^sub>D (RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left by simp
	+ also have "... = XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D
	+ ((RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]"
	+ using assms D.hseqI' D.assoc'_naturality [of "RUNIT g" h "d (src\<^sub>D h)"] by auto
	+ also have "... = (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "(XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D RUNIT g \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f)) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D
	+ (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"
	+ using assms D.hseqI' D.comp_arr_dom D.comp_cod_arr
	+ D.interchange
	+ [of "\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)]" "XLT f"
	+ "XLT (g \<star>\<^sub>D h)" "e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
	+ by simp
	+ also have "... = (((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f)) \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.comp_arr_dom D.comp_cod_arr
	+ D.interchange
	+ [of "(e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f)" "\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)]"
	+ "e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"
	+ "e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
	+ by simp (* 15 sec *)
	+ finally have "(\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f)) \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D
	+ (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have
	+ "\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f)) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D
	+ d (src\<^sub>D h)) =
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)]"
	+ using assms D.hseqI'
	+ D.assoc_naturality
	+ [of "e (trg\<^sub>D f) \<star>\<^sub>D f" "d (src\<^sub>D f)" "e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (d (trg\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D g)) \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h), h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have
	+ "\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT (g \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f) \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D
	+ d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)]"
	+ using assms D.hseqI'
	+ D.assoc_naturality
	+ [of "e (trg\<^sub>D f)" f "d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
	+ ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have
	+ "(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D
	+ d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ (d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left by simp
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]"
	+ using assms D.hseqI'
	+ D.assoc'_naturality [of "d (src\<^sub>D f)" "e (trg\<^sub>D g)" "(RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)"]
	+ by auto
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have
	+ "(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), (g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
	+ ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left by simp
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ ((TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]"
	+ using assms D.hseqI'
	+ D.assoc'_naturality [of "TRG g" "RUNIT g \<star>\<^sub>D h" "d (src\<^sub>D h)"]
	+ by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "(e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
	+ ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)] \<cdot>\<^sub>D
	+ (f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left by simp
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
	+ ((f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]"
	+ using assms D.hseqI'
	+ D.assoc'_naturality
	+ [of f "(d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g)) \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)" "d (src\<^sub>D h)"]
	+ by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ using assms D.hseqI' D.whisker_left by simp
	+ finally have "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D g \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D (TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)])"
	+ using assms by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D \<a>\<^sub>D[g, d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h), h]) \<star>\<^sub>D
	+ d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D(g \<star>\<^sub>D LUNIT h) \<cdot>\<^sub>D \<a>\<^sub>D[g, SRC g, h]) \<star>\<^sub>D d (src\<^sub>D h)"
	+ using assms D.hseqI' TRIANGLE [of g h] by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D \<a>\<^sub>D[g, TRG h, h]) \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by simp
	+ finally have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D (RUNIT g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D \<a>\<^sub>D[g, TRG h, h]) \<star>\<^sub>D d (src\<^sub>D h))"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D \<a>\<^sub>D[g, SRC g, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
	+ ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D (LUNIT g \<star>\<^sub>D h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h)"
	+ using assms D.hseqI' LUNIT_hcomp [of g h] D.invert_side_of_triangle by simp
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by simp
	+ finally have "e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT (g \<star>\<^sub>D h)) \<star>\<^sub>D d (src\<^sub>D h) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h))"
	+ by simp
	+ thus ?thesis
	+ using assms D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = ((e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D (TRG g \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D \<a>\<^sub>D[g, SRC g, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
	+ ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have
	+ "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h] \<cdot>\<^sub>D (TRG g \<star>\<^sub>D g \<star>\<^sub>D LUNIT h)) \<star>\<^sub>D d (src\<^sub>D h)"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by auto
	+ also have "... = e (trg\<^sub>D f) \<star>\<^sub>D
	+ (f \<star>\<^sub>D ((TRG g \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, SRC g \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h)"
	+ using assms D.hseqI' D.assoc'_naturality [of "TRG g" g "LUNIT h"] by auto
	+ also have "... = (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D (TRG g \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h))"
	+ using assms D.hseqI' D.whisker_left D.whisker_right by auto
	+ finally have "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D (TRG g \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h))"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D TRG g \<star>\<^sub>D \<a>\<^sub>D[g, d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h), h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D d (src\<^sub>D g) \<star>\<^sub>D e (trg\<^sub>D h)) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ proof -
	+ have "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D (TRG g \<star>\<^sub>D g) \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) =
	+ e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)"
	+ using assms D.hseqI' D.whisker_left D.whisker_right D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of "LUNIT g" "TRG g \<star>\<^sub>D g" h "LUNIT h"]
	+ by simp (* 15 sec *)
	+ thus ?thesis
	+ using assms by simp
	+ qed
	+ finally have
	+ R: "CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D \<a>\<^sub>D[XLT f, XLT g, XLT h] =
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D LUNIT g \<star>\<^sub>D LUNIT h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D \<a>\<^sub>D[g, TRG h, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g),
	+ ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+ using assms by simp
	+
	+ text \<open>
	+ The portions of the expressions on the right-hand sides of assertions \<open>L\<close> and \<open>R\<close>
	+ that are not identical only involve canonical isomorphisms, and thus they can be proved
	+ equal automatically by the simplifier, once we have expressed them in the formal
	+ language of \<open>D\<close>.
	+ \<close>
	+
	+ let ?LHS =
	+ "(e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, (TRG g \<star>\<^sub>D g) \<star>\<^sub>D TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g \<star>\<^sub>D g, TRG h \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D
	+ \<a>\<^sub>D[f, d (src\<^sub>D f) \<star>\<^sub>D e (trg\<^sub>D g), g \<star>\<^sub>D (TRG h \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG h, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D[f \<star>\<^sub>D SRC f, g, TRG h \<star>\<^sub>D h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D ((f \<star>\<^sub>D SRC f) \<star>\<^sub>D g) \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g) \<star>\<^sub>D XLT h] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), (f \<star>\<^sub>D SRC f) \<star>\<^sub>D g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f \<star>\<^sub>D SRC f, g, d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, SRC f, g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), g \<star>\<^sub>D d (src\<^sub>D g)]) \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT g] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D XLT g) \<star>\<^sub>D XLT h)"
	+
	+ let ?LHSt =
	+ "(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>T\<^bold>R\<^bold>G g \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>T\<^bold>R\<^bold>G g \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>T\<^bold>R\<^bold>G g, \<^bold>\<langle>g\<^bold>\<rangle>, (\<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> (\<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>T\<^bold>R\<^bold>G h, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>e (trg\<^sub>D h)\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>, \<^bold>X\<^bold>L\<^bold>T h\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
	+ ((\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
	+ ((\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>S\<^bold>R\<^bold>C f, \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
	+ ((\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
	+ (\<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T g\<^bold>] \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
	+ (\<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>, \<^bold>X\<^bold>L\<^bold>T g\<^bold>] \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
	+ ((\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T g) \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h)"
	+
	+ let ?RHS =
	+ "(e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, g, TRG h \<star>\<^sub>D h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D (f \<star>\<^sub>D SRC f \<star>\<^sub>D \<a>\<^sub>D[g, TRG h, h]) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[f, TRG g \<star>\<^sub>D (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[TRG g, (g \<star>\<^sub>D SRC g) \<star>\<^sub>D h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D f) \<star>\<^sub>D f \<star>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D f), e (trg\<^sub>D g), ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f), f, d (src\<^sub>D f) \<star>\<^sub>D XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D f) \<star>\<^sub>D f, d (src\<^sub>D f), XLT ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h)] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D f), f, d (src\<^sub>D f)] \<star>\<^sub>D
	+ e (trg\<^sub>D g) \<star>\<^sub>D ((g \<star>\<^sub>D SRC g) \<star>\<^sub>D h) \<star>\<^sub>D d (src\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g \<star>\<^sub>D SRC g, h, d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[g, SRC g, h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D e (trg\<^sub>D g) \<star>\<^sub>D g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (src\<^sub>D g), e (trg\<^sub>D h), h \<star>\<^sub>D d (src\<^sub>D h)]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g), g, d (src\<^sub>D g) \<star>\<^sub>D XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D[e (trg\<^sub>D g) \<star>\<^sub>D g, d (src\<^sub>D g), XLT h]) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D g), g, d (src\<^sub>D g)] \<star>\<^sub>D XLT h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[XLT f, XLT g, XLT h]"
	+
	+ let ?RHSt =
	+ "(\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>T\<^bold>R\<^bold>G g, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>T\<^bold>R\<^bold>G h \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>) \<^bold>\<cdot>
	+ (\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C f \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>T\<^bold>R\<^bold>G h, \<^bold>\<langle>h\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>) \<^bold>\<cdot>
	+ (\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>T\<^bold>R\<^bold>G g \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>T\<^bold>R\<^bold>G g, (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle>, ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>,
	+ \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>)\<^bold>] \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>,
	+ (\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>)\<^bold>] \<^bold>\<cdot>
	+ (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>e (trg\<^sub>D f)\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D f)\<^bold>\<rangle>\<^bold>] \<^bold>\<star>
	+ \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> ((\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>) \<^bold>\<cdot>
	+ (\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>S\<^bold>R\<^bold>C g, \<^bold>\<langle>h\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>S\<^bold>R\<^bold>C g, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>e (trg\<^sub>D h)\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>d (src\<^sub>D h)\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>, \<^bold>X\<^bold>L\<^bold>T h\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>X\<^bold>L\<^bold>T f \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>e (trg\<^sub>D g)\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>d (src\<^sub>D g)\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>X\<^bold>L\<^bold>T h) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>X\<^bold>L\<^bold>T f, \<^bold>X\<^bold>L\<^bold>T g, \<^bold>X\<^bold>L\<^bold>T h\<^bold>]"
	+
	+ have E: "?LHS = ?RHS"
	+ proof -
	+ have "?LHS = \<lbrace>?LHSt\<rbrace>"
	+ using assms D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
	+ D.VV.ide_char D.VV.arr_char
	+ by simp
	+ also have "... = \<lbrace>?RHSt\<rbrace>"
	+ using assms by (intro E.eval_eqI, auto)
	+ also have "... = ?RHS"
	+ using assms D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
	+ D.VV.ide_char D.VV.arr_char
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ show ?thesis
	+ using L R E by argo
	+ qed
	+
	+ text \<open>
	+ The component of the compositor at \<open>(f', g')\<close> is a 2-cell
	+ \[
	+ \<open>\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright>\<close>
	+ \]
	+ having the property \<open>F (\<Phi>\<^sub>0 (f', g')) = F\<Phi>\<^sub>0 f' g'\<close>, where
	+ \[
	+ \<open>F\<Phi>\<^sub>0 f' g' =
	+ D.inv (\<phi> (f' \<star>\<^sub>D g')) \<cdot>\<^sub>D CMP f' g' \<cdot>\<^sub>D (\<phi> f' \<star>\<^sub>D \<phi> g') \<cdot>\<^sub>D D.inv (\<Phi> (G f', G g'))\<close>.
	+ \]
	+ It is unique due to the faithfulness of \<open>F\<close>.
	+ \<close>
	+
	+ abbreviation (input) F\<Phi>\<^sub>0
	+ where "F\<Phi>\<^sub>0 f' g' \<equiv>
	+ D.inv (\<phi> (f' \<star>\<^sub>D g')) \<cdot>\<^sub>D CMP f' g' \<cdot>\<^sub>D (\<phi> f' \<star>\<^sub>D \<phi> g') \<cdot>\<^sub>D D.inv (\<Phi>\<^sub>F (G f', G g'))"
	+
	+ definition \<Phi>\<^sub>0
	+ where "\<Phi>\<^sub>0 \<equiv> \<lambda>(f', g'). THE \<mu>. \<guillemotleft>\<mu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<mu> = F\<Phi>\<^sub>0 f' g'"
	+
	+ lemma \<Phi>\<^sub>0_props:
	+ assumes "D.ide f'" and "D.ide g'" and "src\<^sub>D f' = trg\<^sub>D g'"
	+ shows "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright>"
	+ and "F (\<Phi>\<^sub>0 (f', g')) = F\<Phi>\<^sub>0 f' g'"
	+ proof -
	+ have *: "\<exists>!\<mu>. \<guillemotleft>\<mu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<mu> = F\<Phi>\<^sub>0 f' g'"
	+ proof -
	+ have "\<guillemotleft>F\<Phi>\<^sub>0 f' g' : F (G f' \<star>\<^sub>C G g') \<Rightarrow>\<^sub>D F (G (f' \<star>\<^sub>D g'))\<guillemotright>"
	+ proof (intro D.comp_in_homI)
	+ show "\<guillemotleft>D.inv (\<Phi>\<^sub>F (G f', G g')) : F (G f' \<star>\<^sub>C G g') \<Rightarrow>\<^sub>D F (G f') \<star>\<^sub>D F (G g')\<guillemotright>"
	+ using assms F.\<Phi>_in_hom G_props by auto
	+ show "\<guillemotleft>\<phi> f' \<star>\<^sub>D \<phi> g' : F (G f') \<star>\<^sub>D F (G g') \<Rightarrow>\<^sub>D XLT f' \<star>\<^sub>D XLT g'\<guillemotright>"
	+ using assms G_ide G\<^sub>1_props \<phi>_props C.in_hhom_def
	+ by (intro D.hcomp_in_vhom, auto)
	+ show "\<guillemotleft>CMP f' g' : XLT f' \<star>\<^sub>D XLT g' \<Rightarrow>\<^sub>D XLT (f' \<star>\<^sub>D g')\<guillemotright>"
	+ using assms CMP_in_hom [of f' g'] by simp
	+ show "\<guillemotleft>D.inv (\<phi> (f' \<star>\<^sub>D g')) : XLT (f' \<star>\<^sub>D g') \<Rightarrow>\<^sub>D F (G (f' \<star>\<^sub>D g'))\<guillemotright>"
	+ using assms G_props [of "f' \<star>\<^sub>D g'"] \<phi>_props D.comp_cod_arr D.comp_inv_arr'
	+ by auto
	+ qed
	+ hence "\<exists>\<mu>. \<guillemotleft>\<mu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<mu> = F\<Phi>\<^sub>0 f' g'"
	+ using assms F.locally_full [of "G f' \<star>\<^sub>C G g'" "G (f' \<star>\<^sub>D g')" "F\<Phi>\<^sub>0 f' g'"]
	+ C.ide_hcomp C.ideD(1) C.hcomp_simps(1-2) D.ide_hcomp
	+ D.ideD(1) D.hcomp_simps(1-2) preserves_ide preserves_src preserves_trg
	+ by presburger
	+ moreover have "\<And>\<mu> \<nu>. \<guillemotleft>\<mu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<mu> = F\<Phi>\<^sub>0 f' g' \<and>
	+ \<guillemotleft>\<nu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<nu> = F\<Phi>\<^sub>0 f' g'
	+ \<Longrightarrow> \<mu> = \<nu>"
	+ using assms F.is_faithful C.in_homE by metis
	+ ultimately show ?thesis by auto
	+ qed
	+ have 1: "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F (\<Phi>\<^sub>0 (f', g')) = F\<Phi>\<^sub>0 f' g'"
	+ using * \<Phi>\<^sub>0_def
	+ the1_equality [of "\<lambda>\<mu>. \<guillemotleft>\<mu> : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright> \<and> F \<mu> = F\<Phi>\<^sub>0 f' g'"]
	+ by auto
	+ show "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright>"
	+ using 1 by simp
	+ show "F (\<Phi>\<^sub>0 (f', g')) = F\<Phi>\<^sub>0 f' g'"
	+ using 1 by simp
	+ qed
	+
	+ lemma \<Phi>\<^sub>0_in_hom [intro]:
	+ assumes "D.ide f'" and "D.ide g'" and "src\<^sub>D f' = trg\<^sub>D g'"
	+ shows "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : src\<^sub>C (G g') \<rightarrow>\<^sub>C trg\<^sub>C (G f')\<guillemotright>"
	+ and "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : G f' \<star>\<^sub>C G g' \<Rightarrow>\<^sub>C G (f' \<star>\<^sub>D g')\<guillemotright>"
	+ using assms \<Phi>\<^sub>0_props by simp
	+ thus "\<guillemotleft>\<Phi>\<^sub>0 (f', g') : src\<^sub>C (G g') \<rightarrow>\<^sub>C trg\<^sub>C (G f')\<guillemotright>"
	+ using assms C.src_dom C.trg_dom by fastforce
	+ qed
	+
	+ lemma \<Phi>\<^sub>0_simps [simp]:
	+ assumes "D.ide f'" and "D.ide g'" and "src\<^sub>D f' = trg\<^sub>D g'"
	+ shows "C.arr (\<Phi>\<^sub>0 (f', g'))"
	+ and "src\<^sub>C (\<Phi>\<^sub>0 (f', g')) = src\<^sub>C (G g')" and "trg\<^sub>C (\<Phi>\<^sub>0 (f', g')) = trg\<^sub>C (G f')"
	+ and "C.dom (\<Phi>\<^sub>0 (f', g')) = G f' \<star>\<^sub>C G g'" and "C.cod (\<Phi>\<^sub>0 (f', g')) = G (f' \<star>\<^sub>D g')"
	+ using assms \<Phi>\<^sub>0_in_hom
	+ apply auto
	+ by blast+
	+
	+ lemma F\<Phi>\<^sub>0_naturality:
	+ assumes "D.arr \<mu>" and "D.arr \<nu>" and "src\<^sub>D \<mu> = trg\<^sub>D \<nu>"
	+ shows "F\<Phi>\<^sub>0 (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D F (G \<mu> \<star>\<^sub>C G \<nu>) =
	+ F (GoH\<^sub>D.map (\<mu>, \<nu>)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (D.dom \<mu>) (D.dom \<nu>)"
	+ proof -
	+ have "F\<Phi>\<^sub>0 (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D F (G \<mu> \<star>\<^sub>C G \<nu>) =
	+ D.inv (\<phi> (D.cod \<mu> \<star>\<^sub>D D.cod \<nu>)) \<cdot>\<^sub>D CMP (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D
	+ ((\<phi> (D.cod \<mu>) \<star>\<^sub>D \<phi> (D.cod \<nu>)) \<cdot>\<^sub>D (F (G \<mu>) \<star>\<^sub>D F (G \<nu>))) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>)))"
	+ proof -
	+ have "D.inv (\<Phi>\<^sub>F (G (D.cod \<mu>), G (D.cod \<nu>))) \<cdot>\<^sub>D F (G \<mu> \<star>\<^sub>C G \<nu>) =
	+ (F (G \<mu>) \<star>\<^sub>D F (G \<nu>)) \<cdot>\<^sub>D D.inv (\<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>)))"
	+ proof -
	+ have "\<Phi>\<^sub>F (G (D.cod \<mu>), G (D.cod \<nu>)) \<cdot>\<^sub>D (F (G \<mu>) \<star>\<^sub>D F (G \<nu>)) =
	+ F (G \<mu> \<star>\<^sub>C G \<nu>) \<cdot>\<^sub>D \<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>))"
	+ using assms C.VV.arr_char F.\<Phi>.naturality [of "(G \<mu>, G \<nu>)"] F.FF_def by simp
	+ moreover have "D.seq (\<Phi>\<^sub>F (G (D.cod \<mu>), G (D.cod \<nu>))) (F (G \<mu>) \<star>\<^sub>D F (G \<nu>))"
	+ using assms C.hseqI' D.hseqI' F.preserves_hcomp C.VV.arr_char F.FF_def
	+ by (intro D.seqI D.hseqI, auto)
	+ ultimately show ?thesis
	+ using assms F.\<Phi>_components_are_iso D.invert_opposite_sides_of_square by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = D.inv (\<phi> (D.cod \<mu> \<star>\<^sub>D D.cod \<nu>)) \<cdot>\<^sub>D
	+ (CMP (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D
	+ (XLT \<mu> \<star>\<^sub>D XLT \<nu>)) \<cdot>\<^sub>D
	+ (\<phi> (D.dom \<mu>) \<star>\<^sub>D \<phi> (D.dom \<nu>)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>)))"
	+ proof -
	+ have "(\<phi> (D.cod \<mu>) \<star>\<^sub>D \<phi> (D.cod \<nu>)) \<cdot>\<^sub>D (F (G \<mu>) \<star>\<^sub>D F (G \<nu>)) =
	+ (XLT \<mu> \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D (\<phi> (D.dom \<mu>) \<star>\<^sub>D \<phi> (D.dom \<nu>))"
	+ proof -
	+ have "(\<phi> (D.cod \<mu>) \<star>\<^sub>D \<phi> (D.cod \<nu>)) \<cdot>\<^sub>D (F (G \<mu>) \<star>\<^sub>D F (G \<nu>)) =
	+ \<phi> (D.cod \<mu>) \<cdot>\<^sub>D F (G \<mu>) \<star>\<^sub>D \<phi> (D.cod \<nu>) \<cdot>\<^sub>D F (G \<nu>)"
	+ using assms D.interchange by simp
	+ also have "... = (XLT \<mu> \<cdot>\<^sub>D \<phi> (D.dom \<mu>)) \<star>\<^sub>D (XLT \<nu> \<cdot>\<^sub>D \<phi> (D.dom \<nu>))"
	+ using assms \<phi>.map_def \<phi>.naturality [of \<mu>] \<phi>.naturality [of \<nu>] by fastforce
	+ also have "... = (XLT \<mu> \<star>\<^sub>D XLT \<nu>) \<cdot>\<^sub>D (\<phi> (D.dom \<mu>) \<star>\<^sub>D \<phi> (D.dom \<nu>))"
	+ using assms D.interchange D.hseqI' by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (D.inv (\<phi> (D.cod \<mu> \<star>\<^sub>D D.cod \<nu>)) \<cdot>\<^sub>D
	+ XLT (\<mu> \<star>\<^sub>D \<nu>)) \<cdot>\<^sub>D
	+ CMP (D.dom \<mu>) (D.dom \<nu>) \<cdot>\<^sub>D
	+ (\<phi> (D.dom \<mu>) \<star>\<^sub>D \<phi> (D.dom \<nu>)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>)))"
	+ using assms CMP_naturality D.comp_assoc by simp
	+ also have "... = F (G (\<mu> \<star>\<^sub>D \<nu>)) \<cdot>\<^sub>D D.inv (\<phi> (D.dom \<mu> \<star>\<^sub>D D.dom \<nu>)) \<cdot>\<^sub>D
	+ CMP (D.dom \<mu>) (D.dom \<nu>) \<cdot>\<^sub>D
	+ (\<phi> (D.dom \<mu>) \<star>\<^sub>D \<phi> (D.dom \<nu>)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G (D.dom \<mu>), G (D.dom \<nu>)))"
	+ proof -
	+ have "D.inv (\<phi> (D.cod \<mu> \<star>\<^sub>D D.cod \<nu>)) \<cdot>\<^sub>D XLT (\<mu> \<star>\<^sub>D \<nu>) =
	+ F (G (\<mu> \<star>\<^sub>D \<nu>)) \<cdot>\<^sub>D D.inv (\<phi> (D.dom \<mu> \<star>\<^sub>D D.dom \<nu>))"
	+ using assms D.hseqI' \<phi>.naturality [of "\<mu> \<star>\<^sub>D \<nu>"] \<phi>_props(2)
	+ D.invert_opposite_sides_of_square
	+ [of "\<phi> (D.cod \<mu> \<star>\<^sub>D D.cod \<nu>)" "F (G (\<mu> \<star>\<^sub>D \<nu>))" "XLT (\<mu> \<star>\<^sub>D \<nu>)"
	+ "\<phi> (D.dom \<mu> \<star>\<^sub>D D.dom \<nu>)"]
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = F (GoH\<^sub>D.map (\<mu>, \<nu>)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (D.dom \<mu>) (D.dom \<nu>)"
	+ using assms D.comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+
	+ interpretation \<Phi>: transformation_by_components D.VV.comp V\<^sub>C
	+ H\<^sub>DoGG.map GoH\<^sub>D.map \<Phi>\<^sub>0
	+ proof
	+ show 1: "\<And>a. D.VV.ide a \<Longrightarrow> \<guillemotleft>\<Phi>\<^sub>0 a : H\<^sub>DoGG.map a \<Rightarrow>\<^sub>C GoH\<^sub>D.map a\<guillemotright>"
	+ using D.VV.ide_char D.VV.arr_char \<Phi>\<^sub>0_props FF_def by auto
	+ show "\<And>\<mu>\<nu>. D.VV.arr \<mu>\<nu> \<Longrightarrow>
	+ \<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C H\<^sub>DoGG.map \<mu>\<nu> = GoH\<^sub>D.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>0 (D.VV.dom \<mu>\<nu>)"
	+ proof -
	+ fix \<mu>\<nu>
	+ assume \<mu>\<nu>: "D.VV.arr \<mu>\<nu>"
	+ define \<mu> where "\<mu> = fst \<mu>\<nu>"
	+ define \<nu> where "\<nu> = snd \<mu>\<nu>"
	+ have \<mu>: "D.arr \<mu>"
	+ using \<mu>_def \<mu>\<nu> D.VV.arr_char by simp
	+ have \<nu>: "D.arr \<nu>"
	+ using \<nu>_def \<mu>\<nu> D.VV.arr_char by simp
	+ have \<mu>\<nu>: "src\<^sub>D \<mu> = trg\<^sub>D \<nu>"
	+ using \<mu>_def \<nu>_def \<mu>\<nu> D.VV.arr_char by simp
	+ have "F (\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C H\<^sub>DoGG.map \<mu>\<nu>) =
	+ F (\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>)) \<cdot>\<^sub>D F (H\<^sub>DoGG.map \<mu>\<nu>)"
	+ using 1 \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> \<Phi>\<^sub>0_props D.VV.arr_char C.hseqI' FF_def by simp
	+ also have "... = F\<Phi>\<^sub>0 (D.cod \<mu>) (D.cod \<nu>) \<cdot>\<^sub>D F (G \<mu> \<star>\<^sub>C G \<nu>)"
	+ using \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> \<Phi>\<^sub>0_props D.VV.cod_char FF_def by auto
	+ also have "... = F (GoH\<^sub>D.map \<mu>\<nu>) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (D.dom \<mu>) (D.dom \<nu>)"
	+ using \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> F\<Phi>\<^sub>0_naturality by simp
	+ also have "... = F (GoH\<^sub>D.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>0 (D.VV.dom \<mu>\<nu>))"
	+ using \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> \<Phi>\<^sub>0_props D.VV.dom_char by auto
	+ finally have "F (\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C H\<^sub>DoGG.map \<mu>\<nu>) =
	+ F (GoH\<^sub>D.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>0 (D.VV.dom \<mu>\<nu>))"
	+ by simp
	+ moreover have "C.par (\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C H\<^sub>DoGG.map \<mu>\<nu>)
	+ (GoH\<^sub>D.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>0 (D.VV.dom \<mu>\<nu>))"
	+ using \<mu>_def \<nu>_def \<mu> \<nu> \<mu>\<nu> C.hseqI'
	+ \<Phi>\<^sub>0_props D.VV.arr_char D.VV.dom_char D.VV.cod_char D.VV.ide_char FF_def
	+ by auto
	+ ultimately show "\<Phi>\<^sub>0 (D.VV.cod \<mu>\<nu>) \<cdot>\<^sub>C H\<^sub>DoGG.map \<mu>\<nu> =
	+ GoH\<^sub>D.map \<mu>\<nu> \<cdot>\<^sub>C \<Phi>\<^sub>0 (D.VV.dom \<mu>\<nu>)"
	+ using F.is_faithful by blast
	+ qed
	+ qed
	+
	+ abbreviation \<Phi>
	+ where "\<Phi> \<equiv> \<Phi>.map"
	+
	+ lemma \<Phi>_in_hom [intro]:
	+ assumes "D.arr \<mu>'" and "D.arr \<nu>'" and "src\<^sub>D \<mu>' = trg\<^sub>D \<nu>'"
	+ shows "\<guillemotleft>\<Phi> (\<mu>', \<nu>') : src\<^sub>C (G (D.dom \<nu>')) \<rightarrow>\<^sub>C trg\<^sub>C (G (D.cod \<mu>'))\<guillemotright>"
	+ and "\<guillemotleft>\<Phi> (\<mu>', \<nu>') : G (D.dom \<mu>') \<star>\<^sub>C G (D.dom \<nu>') \<Rightarrow>\<^sub>C G (D.cod \<mu>' \<star>\<^sub>D D.cod \<nu>')\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<Phi> (\<mu>', \<nu>') : G (D.dom \<mu>') \<star>\<^sub>C G (D.dom \<nu>') \<Rightarrow>\<^sub>C G (D.cod \<mu>' \<star>\<^sub>D D.cod \<nu>')\<guillemotright>"
	+ using assms D.VV.arr_char D.VV.dom_char D.VV.cod_char \<Phi>.map_def FF_def
	+ apply auto
	+ apply (intro C.comp_in_homI, auto)
	+ by (intro C.hcomp_in_vhom, auto)
	+ thus "\<guillemotleft>\<Phi> (\<mu>', \<nu>') : src\<^sub>C (G (D.dom \<nu>')) \<rightarrow>\<^sub>C trg\<^sub>C (G (D.cod \<mu>'))\<guillemotright>"
	+ apply (intro C.in_hhomI)
	+ apply auto
	+ apply (metis (no_types, lifting) C.arr_dom C.in_homE C.hcomp_simps(1)
	+ C.src_dom [of "\<Phi> (\<mu>', \<nu>')"])
	+ by (metis (no_types, lifting) C.in_homE C.trg_cod D.arr_cod D.hseqI'
	+ D.src_cod D.trg_cod D.trg_hcomp' assms(1-3) preserves_trg)
	+ qed
	+
	+ lemma \<Phi>_simps [simp]:
	+ assumes "D.arr \<mu>'" and "D.arr \<nu>'" and "src\<^sub>D \<mu>' = trg\<^sub>D \<nu>'"
	+ shows "C.arr (\<Phi> (\<mu>', \<nu>'))"
	+ and "src\<^sub>C (\<Phi> (\<mu>', \<nu>')) = src\<^sub>C (G (D.dom \<nu>'))" and "trg\<^sub>C (\<Phi> (\<mu>', \<nu>')) = trg\<^sub>C (G (D.cod \<mu>'))"
	+ and "C.dom (\<Phi> (\<mu>', \<nu>')) = G (D.dom \<mu>') \<star>\<^sub>C G (D.dom \<nu>')"
	+ and "C.cod (\<Phi> (\<mu>', \<nu>')) = G (D.cod \<mu>' \<star>\<^sub>D D.cod \<nu>')"
	+ using assms \<Phi>_in_hom
	+ apply auto
	+ by blast+
	+
	+ interpretation \<Phi>: natural_isomorphism D.VV.comp V\<^sub>C H\<^sub>DoGG.map GoH\<^sub>D.map \<Phi>
	+ proof
	+ fix fg
	+ assume fg: "D.VV.ide fg"
	+ let ?f = "fst fg"
	+ let ?g = "snd fg"
	+ have f: "D.ide ?f"
	+ using fg D.VV.ide_char by simp
	+ have g: "D.ide ?g"
	+ using fg D.VV.ide_char by simp
	+ have fg: "src\<^sub>D ?f = trg\<^sub>D ?g"
	+ using fg D.VV.ide_char D.VV.arr_char by simp
	+ interpret e_trg_g: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (trg\<^sub>D ?g)\<close> \<open>d (trg\<^sub>D ?g)\<close> \<open>\<eta> (trg\<^sub>D ?g)\<close> \<open>\<epsilon> (trg\<^sub>D ?g)\<close>
	+ using g G\<^sub>0_props by simp
	+ have "D.iso (F (\<Phi> fg))"
	+ proof -
	+ have "F (\<Phi> fg) =
	+ D.inv (\<phi> (?f \<star>\<^sub>D ?g)) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D ?f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[?f, ?g, d (src\<^sub>D ?g)]) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D ?f) \<star>\<^sub>D ?f \<star>\<^sub>D LUNIT (?g \<star>\<^sub>D d (src\<^sub>D ?g))) \<cdot>\<^sub>D
	+ (e (trg\<^sub>D ?f) \<star>\<^sub>D ?f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[d (trg\<^sub>D ?g), e (trg\<^sub>D ?g), ?g \<star>\<^sub>D d (src\<^sub>D ?g)]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D ?f), ?f, d (trg\<^sub>D ?g) \<star>\<^sub>D XLT ?g] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[e (trg\<^sub>D ?f) \<star>\<^sub>D ?f, d (trg\<^sub>D ?g), XLT ?g] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[e (trg\<^sub>D ?f), ?f, d (trg\<^sub>D ?g)] \<star>\<^sub>D XLT ?g) \<cdot>\<^sub>D
	+ (\<phi> ?f \<star>\<^sub>D \<phi> ?g) \<cdot>\<^sub>D D.inv (\<Phi>\<^sub>F (G ?f, G ?g))"
	+ using CMP_def f g fg \<Phi>\<^sub>0_props [of ?f ?g] D.VV.ide_char D.VV.arr_char D.comp_assoc
	+ by simp
	+ moreover have "D.iso ..."
	+ using f g fg D.VV.arr_char D.iso_inv_iso F.\<Phi>_components_are_iso \<phi>_props D.hseqI'
	+ e_trg_g.unit_is_iso iso_LUNIT
	+ apply (intro D.isos_compose) by simp_all (* 17 subgoals, 40 sec. *)
	+ ultimately show ?thesis by simp
	+ qed
	+ thus "C.iso (\<Phi> fg)"
	+ using F.reflects_iso by blast
	+ qed
	+
	+ interpretation G: pseudofunctor V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C G \<Phi>
	+ proof
	+ fix f g h
	+ assume f: "D.ide f"
	+ assume g: "D.ide g"
	+ assume h: "D.ide h"
	+ assume fg: "src\<^sub>D f = trg\<^sub>D g"
	+ assume gh: "src\<^sub>D g = trg\<^sub>D h"
	+ show "G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h) =
	+ \<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h]"
	+ proof -
	+ have 1: "\<guillemotleft>\<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h) :
	+ (G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G ((f \<star>\<^sub>D g) \<star>\<^sub>D h)\<guillemotright>"
	+ proof (intro C.comp_in_homI)
	+ show "\<guillemotleft>\<Phi> (f, g) \<star>\<^sub>C G h : (G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g) \<star>\<^sub>C G h\<guillemotright>"
	+ using f g h fg gh D.VV.arr_char D.VV.ide_char
	+ by (intro C.hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<Phi> (f \<star>\<^sub>D g, h) : G (f \<star>\<^sub>D g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G ((f \<star>\<^sub>D g) \<star>\<^sub>D h)\<guillemotright>"
	+ using f g h fg gh D.VV.arr_char D.VV.ide_char \<Phi>\<^sub>0_props(1) by simp
	+ qed
	+ have LHS: "\<guillemotleft>G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h) :
	+ (G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>\<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h) :
	+ (G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G ((f \<star>\<^sub>D g) \<star>\<^sub>D h)\<guillemotright>"
	+ using 1 by simp
	+ show "\<guillemotleft>G \<a>\<^sub>D[f, g, h] : G ((f \<star>\<^sub>D g) \<star>\<^sub>D h) \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
	+ using f g h fg gh D.VVV.arr_char D.VV.arr_char D.VVV.ide_char D.VV.ide_char
	+ G_ide G_props(2)
	+ apply (intro C.in_homI)
	+ by simp_all
	+ qed
	+ have 2: "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) :
	+ G f \<star>\<^sub>C G g \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
	+ proof (intro C.comp_in_homI)
	+ show "\<guillemotleft>G f \<star>\<^sub>C \<Phi> (g, h) : G f \<star>\<^sub>C G g \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G f \<star>\<^sub>C G (g \<star>\<^sub>D h)\<guillemotright>"
	+ using f g h fg gh D.VV.arr_char D.VV.ide_char
	+ by (intro C.hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>D h) : G f \<star>\<^sub>C G (g \<star>\<^sub>D h) \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
	+ using f g h fg gh D.VV.arr_char D.VV.ide_char by auto
	+ qed
	+ have RHS: "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h] :
	+ (G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
	+ proof -
	+ have "\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h] =
	+ (\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h))) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h]"
	+ using C.comp_assoc by simp
	+ moreover
	+ have "\<guillemotleft>(\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h))) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h] :
	+ (G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) :
	+ G f \<star>\<^sub>C G g \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G (f \<star>\<^sub>D g \<star>\<^sub>D h)\<guillemotright>"
	+ using 2 by simp
	+ show "\<guillemotleft>\<a>\<^sub>C[G f, G g, G h] : (G f \<star>\<^sub>C G g) \<star>\<^sub>C G h \<Rightarrow>\<^sub>C G f \<star>\<^sub>C G g \<star>\<^sub>C G h\<guillemotright>"
	+ using f g h fg gh D.VVV.arr_char D.VV.arr_char D.VVV.ide_char D.VV.ide_char
	+ apply (intro C.in_homI) by auto
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ have "F (G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h)) =
	+ F (\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h])"
	+ proof -
	+ have "F (G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h)) =
	+ F (G \<a>\<^sub>D[f, g, h]) \<cdot>\<^sub>D F (\<Phi> (f \<star>\<^sub>D g, h)) \<cdot>\<^sub>D F (\<Phi> (f, g) \<star>\<^sub>C G h)"
	+ using f g h fg gh 1 D.VVV.arr_char D.VV.arr_char D.VVV.ide_char D.VV.ide_char
	+ by (metis (no_types, lifting) C.arrI F.preserves_comp LHS)
	+ also have "... = (D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ \<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D F (\<Phi> (f \<star>\<^sub>D g, h)) \<cdot>\<^sub>D F (\<Phi> (f, g) \<star>\<^sub>C G h)"
	+ using f g h fg gh G_props [of "\<a>\<^sub>D[f, g, h]"] by fastforce
	+ also have "... = (D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ \<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (f \<star>\<^sub>D g) h \<cdot>\<^sub>D F (\<Phi> (f, g) \<star>\<^sub>C G h)"
	+ using f g h fg gh \<Phi>.map_simp_ide [of "(f \<star>\<^sub>D g, h)"] \<Phi>\<^sub>0_props [of "f \<star>\<^sub>D g" h]
	+ D.VV.arr_char D.VV.cod_char D.VV.ide_char FF_def
	+ by auto
	+ also have "... = (D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ \<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (C.cod (\<Phi>.map (f, g)), G h) \<cdot>\<^sub>D
	+ (F (\<Phi>.map (f, g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (C.dom (\<Phi>.map (f, g)), G h))"
	+ proof -
	+ have "src\<^sub>C (G\<^sub>1 g) = trg\<^sub>C (G\<^sub>1 h)"
	+ using g h gh G\<^sub>1_props(2) G\<^sub>1_props(2) [of h] by fastforce
	+ hence "C.hseq (\<Phi> (f, g)) (G h)"
	+ using f g h fg gh G_props(2) G_ide
	+ apply (intro C.hseqI, auto)
	+ using g h gh G\<^sub>1_props [of h] by blast
	+ thus ?thesis
	+ using f g h fg gh F.preserves_hcomp [of "\<Phi> (f, g)" "G h"] by auto
	+ qed
	+ also have "... = (D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ \<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h) \<cdot>\<^sub>D
	+ (F (\<Phi>.map (f, g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ using f g h fg gh \<Phi>\<^sub>0_in_hom [of f g] \<Phi>.map_def D.VV.arr_char FF_def by simp
	+ also have "... = (D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ \<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D F\<Phi>\<^sub>0 (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h) \<cdot>\<^sub>D
	+ (F\<Phi>\<^sub>0 f g \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ using f g h fg gh \<Phi>.map_simp_ide \<Phi>\<^sub>0_props [of f g] D.VV.arr_char D.VV.ide_char
	+ D.VV.cod_char FF_def
	+ by auto
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ \<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h) \<cdot>\<^sub>D
	+ D.inv (\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
	+ (\<phi> (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h)) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h) \<cdot>\<^sub>D
	+ (D.inv (\<phi> (f \<star>\<^sub>D g)) \<cdot>\<^sub>D
	+ CMP f g \<cdot>\<^sub>D (\<phi> f \<star>\<^sub>D \<phi> g) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G g))
	+ \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ using D.comp_assoc by simp
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ ((\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h) \<cdot>\<^sub>D
	+ D.inv (\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ CMP (f \<star>\<^sub>D g) h) \<cdot>\<^sub>D
	+ (((\<phi> (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
	+ ((D.inv (\<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h)) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h)) \<cdot>\<^sub>D
	+ (D.inv (\<phi> (f \<star>\<^sub>D g)) \<star>\<^sub>D F (G h)))) \<cdot>\<^sub>D
	+ (CMP f g \<star>\<^sub>D F (G h))) \<cdot>\<^sub>D
	+ ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ proof -
	+ have "D.inv (\<phi> (f \<star>\<^sub>D g)) \<cdot>\<^sub>D CMP f g \<cdot>\<^sub>D (\<phi> f \<star>\<^sub>D \<phi> g) \<cdot>\<^sub>D D.inv (\<Phi>\<^sub>F (G f, G g))
	+ \<star>\<^sub>D F (G h) =
	+ (D.inv (\<phi> (f \<star>\<^sub>D g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ (CMP f g \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h))"
	+ using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
	+ D.whisker_right
	+ by auto
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
	+ ((XLT (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
	+ (CMP f g \<star>\<^sub>D F (G h))) \<cdot>\<^sub>D
	+ ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ proof -
	+ have "(\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h) \<cdot>\<^sub>D D.inv (\<phi> ((f \<star>\<^sub>D g) \<star>\<^sub>D h))) \<cdot>\<^sub>D CMP (f \<star>\<^sub>D g) h =
	+ CMP (f \<star>\<^sub>D g) h"
	+ using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
	+ D.comp_arr_inv' D.comp_cod_arr
	+ by simp
	+ moreover have "(\<phi> (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
	+ ((D.inv (\<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h)) \<cdot>\<^sub>D \<Phi>\<^sub>F (G (f \<star>\<^sub>D g), G h)) \<cdot>\<^sub>D
	+ (D.inv (\<phi> (f \<star>\<^sub>D g)) \<star>\<^sub>D F (G h))) =
	+ XLT (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h"
	+ using f g h fg gh F.\<Phi>_in_hom [of "G (f \<star>\<^sub>D g)" "G h"]
	+ F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
	+ D.comp_arr_inv' D.comp_inv_arr' D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of "\<phi> (f \<star>\<^sub>D g)" "D.inv (\<phi> (f \<star>\<^sub>D g))" "\<phi> h" "F (G h)"]
	+ by simp
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D
	+ ((CMP f g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D F (G h))) \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ proof -
	+ have "(XLT (f \<star>\<^sub>D g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D (CMP f g \<star>\<^sub>D F (G h)) = CMP f g \<star>\<^sub>D \<phi> h"
	+ using f g h fg gh D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of "XLT (f \<star>\<^sub>D g)" "CMP f g" "\<phi> h" "F (G h)"]
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (XLT \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>D
	+ CMP (f \<star>\<^sub>D g) h \<cdot>\<^sub>D (CMP f g \<star>\<^sub>D XLT h)) \<cdot>\<^sub>D
	+ ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ proof -
	+ have "(CMP f g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D F (G h)) =
	+ (CMP f g \<star>\<^sub>D XLT h) \<cdot>\<^sub>D ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D \<phi> h)"
	+ using f g h fg gh D.comp_arr_dom D.comp_cod_arr D.hseqI'
	+ D.interchange [of "CMP f g" "\<phi> f \<star>\<^sub>D \<phi> g" "\<phi> h" "F (G h)"]
	+ D.interchange [of "CMP f g" "\<phi> f \<star>\<^sub>D \<phi> g" "XLT h" "\<phi> h"]
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[XLT f, XLT g, XLT h] \<cdot>\<^sub>D
	+ ((\<phi> f \<star>\<^sub>D \<phi> g) \<star>\<^sub>D \<phi> h)) \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ using f g h fg gh CMP_coherence [of f g h] D.comp_assoc by simp
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D
	+ (\<phi> f \<star>\<^sub>D \<phi> g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h)))"
	+ using f g h fg gh D.assoc_naturality [of "\<phi> f" "\<phi> g" "\<phi> h"] D.comp_assoc
	+ by simp
	+ finally have
	+ A: "F (G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h)) =
	+ D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D
	+ (\<phi> f \<star>\<^sub>D \<phi> g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h)))"
	+ by simp
	+
	+ have "F (\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h]) =
	+ F (\<Phi> (f, g \<star>\<^sub>D h)) \<cdot>\<^sub>D F (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>D F \<a>\<^sub>C[G f, G g, G h]"
	+ using f g h fg gh 1 D.VVV.arr_char D.VV.arr_char D.VVV.ide_char D.VV.ide_char
	+ by (metis (no_types, lifting) C.arrI C.seqE F.preserves_comp RHS)
	+ also have "... = F\<Phi>\<^sub>0 f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
	+ F (G f \<star>\<^sub>C \<Phi>\<^sub>0 (g, h)) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ using f g h fg gh \<Phi>\<^sub>0_props D.VV.arr_char D.VV.cod_char D.VV.ide_char
	+ F.preserves_assoc(1)
	+ by simp
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
	+ (\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ F (G f \<star>\<^sub>C \<Phi>\<^sub>0 (g, h)) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ using f g h fg gh D.VV.arr_char D.VV.ide_char D.comp_assoc by simp
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
	+ (\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D F (\<Phi>\<^sub>0 (g, h))) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h))) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ using f g h fg gh F.preserves_hcomp D.comp_assoc
	+ by (simp add: C.hseqI')
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
	+ (\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D
	+ D.inv (\<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h))) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ using f g h fg gh \<Phi>\<^sub>0_props by simp
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
	+ ((\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h))) \<cdot>\<^sub>D
	+ ((F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)]) \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ proof -
	+ have "F (G f) \<star>\<^sub>D
	+ D.inv (\<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h)) =
	+ (F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h)))"
	+ using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
	+ D.whisker_left
	+ by (simp add: D.comp_assoc)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
	+ (\<phi> f \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ proof -
	+ have "(\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)) =
	+ \<phi> f \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)"
	+ proof -
	+ have "(\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)) =
	+ ((\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ ((D.inv (\<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G (g \<star>\<^sub>D h))) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h))))) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h))"
	+ using D.comp_assoc by simp
	+ also have "... = ((\<phi> f \<star>\<^sub>D \<phi> (g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D D.inv (\<phi> (g \<star>\<^sub>D h)))) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h))"
	+ using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
	+ D.comp_arr_inv' D.comp_inv_arr' D.comp_cod_arr
	+ by simp
	+ also have "... = (\<phi> f \<star>\<^sub>D XLT (g \<star>\<^sub>D h)) \<cdot>\<^sub>D (F (G f) \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h))"
	+ using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
	+ D.comp_arr_inv' D.comp_inv_arr' D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of "\<phi> f" "F (G f)" "\<phi> (g \<star>\<^sub>D h)" "D.inv (\<phi> (g \<star>\<^sub>D h))"]
	+ by simp
	+ also have "... = \<phi> f \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)"
	+ using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
	+ D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of "\<phi> f" "F (G f)" "XLT (g \<star>\<^sub>D h)" "CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)"]
	+ by simp (* 15 sec *)
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "(F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)] =
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)]"
	+ proof -
	+ have "(F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)] =
	+ ((F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
	+ ((D.inv (\<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
	+ \<Phi>\<^sub>F (G f, G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)]"
	+ using D.comp_assoc by simp
	+ also have "... = ((F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
	+ ((F (G f) \<star>\<^sub>D F (G g \<star>\<^sub>C G h)) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h)))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)]"
	+ using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
	+ D.comp_arr_inv' D.comp_inv_arr' D.comp_arr_dom D.comp_cod_arr
	+ by fastforce
	+ also have "... = ((F (G f) \<star>\<^sub>D D.inv (\<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
	+ (F (G f) \<star>\<^sub>D \<Phi>\<^sub>F (G g, G h))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)]"
	+ proof -
	+ have "D.seq (F (G g \<star>\<^sub>C G h)) (\<Phi>\<^sub>F (G g, G h))"
	+ using f g h fg gh
	+ apply (intro D.seqI) by auto
	+ thus ?thesis
	+ using f g h fg gh F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI' D.comp_cod_arr
	+ by auto
	+ qed
	+ also have "... = \<a>\<^sub>D[F (G f), F (G g), F (G h)]"
	+ using f g h fg gh F.\<Phi>_in_hom F.\<Phi>_components_are_iso \<phi>_props(2) D.hseqI'
	+ D.comp_arr_inv' D.comp_inv_arr' D.comp_arr_dom D.comp_cod_arr
	+ D.whisker_left [of "F (G f)" "D.inv (\<Phi>\<^sub>F (G g, G h))" "\<Phi>\<^sub>F (G g, G h)"]
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D
	+ (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D
	+ (\<phi> f \<star>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ proof -
	+ have "\<phi> f \<star>\<^sub>D CMP g h \<cdot>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h) =
	+ (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D (\<phi> f \<star>\<^sub>D (\<phi> g \<star>\<^sub>D \<phi> h))"
	+ using f g h fg gh D.hseqI' D.comp_cod_arr
	+ D.interchange [of "XLT f" "\<phi> f" "CMP g h" "\<phi> g \<star>\<^sub>D \<phi> h"]
	+ by auto
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ finally have
	+ B: "F (\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h]) =
	+ D.inv (\<phi> (f \<star>\<^sub>D g \<star>\<^sub>D h)) \<cdot>\<^sub>D
	+ CMP f (g \<star>\<^sub>D h) \<cdot>\<^sub>D (XLT f \<star>\<^sub>D CMP g h) \<cdot>\<^sub>D
	+ (\<phi> f \<star>\<^sub>D \<phi> g \<star>\<^sub>D \<phi> h) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F (G f), F (G g), F (G h)] \<cdot>\<^sub>D
	+ (D.inv (\<Phi>\<^sub>F (G f, G g)) \<star>\<^sub>D F (G h)) \<cdot>\<^sub>D
	+ D.inv (\<Phi>\<^sub>F (G f \<star>\<^sub>C G g, G h))"
	+ by simp
	+ show ?thesis using A B by argo
	+ qed
	+ moreover have "C.par (G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h))
	+ (\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h])"
	+ using LHS RHS by (metis (no_types, lifting) C.in_homE)
	+ ultimately show ?thesis
	+ using F.is_faithful [of "G \<a>\<^sub>D[f, g, h] \<cdot>\<^sub>C \<Phi> (f \<star>\<^sub>D g, h) \<cdot>\<^sub>C (\<Phi> (f, g) \<star>\<^sub>C G h)"
	+ "\<Phi> (f, g \<star>\<^sub>D h) \<cdot>\<^sub>C (G f \<star>\<^sub>C \<Phi> (g, h)) \<cdot>\<^sub>C \<a>\<^sub>C[G f, G g, G h]"]
	+ by simp
	+ qed
	+ qed
	+
	+ interpretation "faithful_functor" V\<^sub>D V\<^sub>C G
	+ proof
	+ fix \<mu> \<mu>'
	+ assume par: "D.par \<mu> \<mu>'"
	+ assume eq: "G \<mu> = G \<mu>'"
	+ have \<mu>: "\<guillemotleft>\<mu> : src\<^sub>D \<mu> \<rightarrow>\<^sub>D src\<^sub>D (e (trg\<^sub>D \<mu>))\<guillemotright>"
	+ using par by simp
	+ hence \<mu>': "\<guillemotleft>\<mu>' : src\<^sub>D \<mu> \<rightarrow>\<^sub>D src\<^sub>D (e (trg\<^sub>D \<mu>))\<guillemotright>"
	+ using par by (metis D.in_hhom_def D.src_dom D.trg_dom)
	+ interpret e_src: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (src\<^sub>D \<mu>)\<close> \<open>d (src\<^sub>D \<mu>)\<close> \<open>\<eta> (src\<^sub>D \<mu>)\<close> \<open>\<epsilon> (src\<^sub>D \<mu>)\<close>
	+ using \<mu> G\<^sub>0_props by auto
	+ interpret e_trg: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e (trg\<^sub>D \<mu>)\<close> \<open>d (trg\<^sub>D \<mu>)\<close> \<open>\<eta> (trg\<^sub>D \<mu>)\<close> \<open>\<epsilon> (trg\<^sub>D \<mu>)\<close>
	+ using \<mu> G\<^sub>0_props by auto
	+ have d_src: "D.equivalence_map (d (src\<^sub>D \<mu>))"
	+ using e_src.equivalence_in_bicategory_axioms D.equivalence_map_def
	+ D.equivalence_pair_symmetric D.equivalence_pair_def
	+ by blast
	+ have e_trg: "D.equivalence_map (e (trg\<^sub>D \<mu>))"
	+ using e_trg.equivalence_in_bicategory_axioms D.equivalence_map_def by blast
	+ show "\<mu> = \<mu>'"
	+ proof -
	+ have "F (G \<mu>) = F (G \<mu>')"
	+ using eq by simp
	+ hence 1: "D.inv (\<phi> (D.cod \<mu>)) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>) =
	+ D.inv (\<phi> (D.cod \<mu>)) \<cdot>\<^sub>D (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>)"
	+ using par G_props [of \<mu>] G_props [of \<mu>']
	+ by (metis D.src_dom D.trg_dom)
	+ have 2: "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>) =
	+ (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>)"
	+ proof -
	+ have "D.iso (D.inv (\<phi> (D.cod \<mu>)))"
	+ using par \<phi>_props D.iso_inv_iso by simp
	+ moreover have "D.seq (D.inv (\<phi> (D.cod \<mu>)))
	+ ((e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>))"
	+ proof -
	+ have "D.arr (F (G \<mu>))"
	+ using par by simp
	+ thus ?thesis
	+ using 1 par calculation G_props [of \<mu>] G_props [of \<mu>'] by argo
	+ qed
	+ ultimately show ?thesis
	+ using 1 par \<phi>_props D.comp_arr_dom D.comp_arr_inv' D.comp_assoc D.comp_cod_arr
	+ D.ide_char G_props(2) G_props(3)
	+ D.iso_is_section D.section_is_mono D.iso_inv_iso
	+ D.monoE
	+ [of "D.inv (\<phi> (D.cod \<mu>))" "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>)"
	+ "(e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)) \<cdot>\<^sub>D \<phi> (D.dom \<mu>)"]
	+ by metis
	+ qed
	+ have "e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) = e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)"
	+ proof -
	+ have "D.seq (e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)) (\<phi> (D.dom \<mu>))"
	+ using par by fastforce
	+ (*
	+ * TODO: epiE and monoE don't need both seq hypotheses.
	+ * Also, they are not stated in the form of elimination rules.
	+ *)
	+ thus ?thesis
	+ using 2 par \<phi>_props D.iso_is_retraction D.retraction_is_epi
	+ D.epiE [of "\<phi> (D.dom \<mu>)" "e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)"
	+ "e (trg\<^sub>D \<mu>) \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)"]
	+ by auto
	+ qed
	+ hence "\<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>) = \<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)"
	+ using \<mu> \<mu>' e_trg par
	+ D.equivalence_cancel_left [of "e (trg\<^sub>D \<mu>)" "\<mu> \<star>\<^sub>D d (src\<^sub>D \<mu>)" "\<mu>' \<star>\<^sub>D d (src\<^sub>D \<mu>)"]
	+ by (metis D.hcomp_simps(3-4) D.hseqE FG'.preserves_arr)
	+ thus ?thesis
	+ using \<mu> \<mu>' D.equivalence_cancel_right d_src
	+ by (metis D.obj_src d_simps(3) par)
	+ qed
	+ qed
	+
	+ interpretation G: equivalence_pseudofunctor
	+ V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C G \<Phi>
	+ proof
	+ show "\<And>a. C.obj a \<Longrightarrow> \<exists>a'. D.obj a' \<and> C.equivalent_objects (map\<^sub>0 a') a"
	+ proof
	+ fix a
	+ assume a: "C.obj a"
	+ have "D.obj (F.map\<^sub>0 a)"
	+ using a by simp
	+ moreover have "C.equivalent_objects (map\<^sub>0 (F.map\<^sub>0 a)) a"
	+ using a G\<^sub>0_props [of "F.map\<^sub>0 a"] C.equivalent_objects_symmetric
	+ F.reflects_equivalent_objects G\<^sub>0_preserves_obj(2) map\<^sub>0_simps(1)
	+ by auto
	+ ultimately show "D.obj (F.map\<^sub>0 a) \<and> C.equivalent_objects (map\<^sub>0 (F.map\<^sub>0 a)) a"
	+ by blast
	+ qed
	+ show "\<And>a b g. \<lbrakk> D.obj a; D.obj b; \<guillemotleft>g : map\<^sub>0 a \<rightarrow>\<^sub>C map\<^sub>0 b\<guillemotright>; C.ide g \<rbrakk>
	+ \<Longrightarrow> \<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.ide f \<and> C.isomorphic (G f) g"
	+ proof -
	+ fix a b g
	+ assume a: "D.obj a"
	+ assume b: "D.obj b"
	+ assume g_in_hhom: "\<guillemotleft>g : map\<^sub>0 a \<rightarrow>\<^sub>C map\<^sub>0 b\<guillemotright>"
	+ assume ide_g: "C.ide g"
	+ interpret e\<^sub>a: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e a\<close> \<open>d a\<close> \<open>\<eta> a\<close> \<open>\<epsilon> a\<close>
	+ using a G\<^sub>0_props by auto
	+ interpret e\<^sub>b: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e b\<close> \<open>d b\<close> \<open>\<eta> b\<close> \<open>\<epsilon> b\<close>
	+ using b G\<^sub>0_props by auto
	+ interpret e\<^sub>ae\<^sub>b: two_equivalences_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e a\<close> \<open>d a\<close> \<open>\<eta> a\<close> \<open>\<epsilon> a\<close> \<open>e b\<close> \<open>d b\<close> \<open>\<eta> b\<close> \<open>\<epsilon> b\<close>
	+ ..
	+ have Fg: "\<guillemotleft>F g : F.map\<^sub>0 (map\<^sub>0 a) \<rightarrow>\<^sub>D F.map\<^sub>0 (map\<^sub>0 b)\<guillemotright>"
	+ using a b g_in_hhom by auto
	+ let ?f = "d b \<star>\<^sub>D F g \<star>\<^sub>D e a"
	+ have f: "\<guillemotleft>?f: a \<rightarrow>\<^sub>D b\<guillemotright>"
	+ using a b g_in_hhom ide_g by auto
	+ have 2: "D.isomorphic (F (G ?f)) (F g)"
	+ proof -
	+ have "D.isomorphic (F (G ?f)) (e b \<star>\<^sub>D ?f \<star>\<^sub>D d a)"
	+ using a b ide_g g_in_hhom f G\<^sub>0_props G\<^sub>1_props [of ?f] G_props
	+ by (metis D.ide_hcomp D.hseqE D.in_hhomE F.preserves_ide G_ide)
	+ also have "D.isomorphic ... (F g)"
	+ using ide_g e\<^sub>ae\<^sub>b.\<psi>_in_hom [of "F g"] e\<^sub>ae\<^sub>b.\<psi>_components_are_iso [of "F g"]
	+ D.isomorphic_symmetric D.isomorphic_def
	+ by (metis D.hseqE D.ide_char D.ide_in_hom(1) D.in_hhomE D.hcomp_simps(2)
	+ F.preserves_ide e\<^sub>b.antipar(2) f)
	+ finally show ?thesis by simp
	+ qed
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : F (G ?f) \<Rightarrow>\<^sub>D F g\<guillemotright> \<and> D.iso \<phi>"
	+ using 2 by auto
	+ have "C.isomorphic (G ?f) g"
	+ using \<phi> F.reflects_iso
	+ by (metis C.arrI C.isomorphic_def D.ide_hcomp D.hseqE F.locally_full
	+ F.preserves_ide d_simps(1) e_simps(1) f g_in_hhom horizontal_homs.in_hhomE
	+ ide_g preserves_ide preserves_src preserves_trg weak_arrow_of_homs_axioms
	+ weak_arrow_of_homs_def)
	+ thus "\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.ide f \<and> C.isomorphic (G f) g"
	+ using f
	+ by (meson D.ide_hcomp D.hseqE D.in_hhomE F.preserves_ide d_simps(1) e_simps(1)
	+ ide_g)
	+ qed
	+ show "\<And>f' g' \<mu>. \<lbrakk> D.ide f'; D.ide g'; src\<^sub>D f' = src\<^sub>D g'; trg\<^sub>D f' = trg\<^sub>D g';
	+ \<guillemotleft>\<mu> : G f' \<Rightarrow>\<^sub>C G g'\<guillemotright> \<rbrakk> \<Longrightarrow> \<exists>\<mu>'. \<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and> G \<mu>' = \<mu>"
	+ proof -
	+ fix f' g' \<mu>
	+ assume f': "D.ide f'"
	+ assume g': "D.ide g'"
	+ assume \<mu>: "\<guillemotleft>\<mu> : G f' \<Rightarrow>\<^sub>C G g'\<guillemotright>"
	+ assume src_eq: "src\<^sub>D f' = src\<^sub>D g'"
	+ assume trg_eq: "trg\<^sub>D f' = trg\<^sub>D g'"
	+ let ?a' = "src\<^sub>D f'"
	+ let ?b' = "trg\<^sub>D f'"
	+ text \<open>
	+ Given \<open>\<guillemotleft>\<mu> : G f' \<Rightarrow>\<^sub>C G g'\<guillemotright>\<close>, the 2-cell \<open>F \<mu>\<close> is in \<open>hom\<^sub>D (F (G f')) (F (G g'))\<close>.
	+ We have equivalence maps \<open>\<guillemotleft>e\<^sub>a : a' \<rightarrow>\<^sub>D F\<^sub>0 (G\<^sub>0 a')\<guillemotright>\<close>
	+ and \<open>\<guillemotleft>e\<^sub>b : b' \<rightarrow>\<^sub>D F\<^sub>0 (G\<^sub>0 b')\<guillemotright>\<close> and \<open>d\<^sub>a\<close> and \<open>d\<^sub>b\<close> in the opposite directions.
	+ We have shown that the functor from \<open>hom\<^sub>D f' g'\<close> to \<open>hom\<^sub>D (F (G f')) (F (G g'))\<close>
	+ that takes \<open>\<mu>'\<close> to \<open>e b' \<star>\<^sub>D \<mu>' \<star>\<^sub>D d a'\<close> is an equivalence functor, as is also
	+ the functor from \<open>hom\<^sub>D (F (G f')) (F (G g'))\<close> to \<open>hom f' g'\<close> that takes
	+ \<open>\<nu>'\<close> to \<open>d b' \<star>\<^sub>D \<nu>' \<star>\<^sub>D e a'\<close>.
	+
	+ Now, \<open>G\<close> is defined on a 2-cell \<open>\<guillemotleft>\<mu>' : f' \<Rightarrow> g'\<guillemotright>\<close> by the condition:
	+ \[
	+ \<open>\<guillemotleft>G \<mu>' : G f' \<Rightarrow>\<^sub>C G g'\<guillemotright> \<and> F (G \<mu>') = D.inv (\<phi> g') \<cdot>\<^sub>D (e b' \<star>\<^sub>D \<mu>' \<star>\<^sub>D d a') \<cdot>\<^sub>D \<phi> f'\<close>.
	+ \]
	+ To show that \<open>G\<close> is locally full, what we need is, given \<open>\<guillemotleft>\<mu> : G f' \<Rightarrow>\<^sub>C G g'\<guillemotright>\<close>,
	+ to obtain a 2-cell \<open>\<mu>'\<close> in \<open>hom\<^sub>D f' g'\<close> that satisfies: \<open>F (G \<mu>') = F \<mu>\<close>;
	+ that is: \<open>D.inv (\<phi> g') \<cdot>\<^sub>D (e b' \<star>\<^sub>D \<mu>' \<star>\<^sub>D d a') \<cdot>\<^sub>D \<phi> f' = F \<mu>\<close>.
	+ This then implies \<open>G \<mu>' = \<mu>\<close> by the faithfulness of F.
	+ \<close>
	+ interpret e\<^sub>a: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e ?a'\<close> \<open>d ?a'\<close> \<open>\<eta> ?a'\<close> \<open>\<epsilon> ?a'\<close>
	+ using f' G\<^sub>0_props by auto
	+ interpret d\<^sub>a: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>d ?a'\<close> \<open>e ?a'\<close> \<open>D.inv (\<epsilon> ?a')\<close> \<open>D.inv (\<eta> ?a')\<close>
	+ using e\<^sub>a.dual_equivalence by simp
	+ interpret e\<^sub>b: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>e ?b'\<close> \<open>d ?b'\<close> \<open>\<eta> ?b'\<close> \<open>\<epsilon> ?b'\<close>
	+ using f' G\<^sub>0_props by auto
	+ interpret d\<^sub>b: equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>d ?b'\<close> \<open>e ?b'\<close> \<open>D.inv (\<epsilon> ?b')\<close> \<open>D.inv (\<eta> ?b')\<close>
	+ using e\<^sub>b.dual_equivalence by simp
	+ interpret d\<^sub>ad\<^sub>b: two_equivalences_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>d ?a'\<close> \<open>e ?a'\<close> \<open>D.inv (\<epsilon> ?a')\<close> \<open>D.inv (\<eta> ?a')\<close>
	+ \<open>d ?b'\<close> \<open>e ?b'\<close> \<open>D.inv (\<epsilon> ?b')\<close> \<open>D.inv (\<eta> ?b')\<close>
	+ ..
	+ interpret hom_a_b: subcategory V\<^sub>D \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : ?a' \<rightarrow>\<^sub>D ?b'\<guillemotright>\<close>
	+ using D.hhom_is_subcategory by simp
	+ interpret hom_FGa_FGb: subcategory V\<^sub>D
	+ \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : F.map\<^sub>0 (G\<^sub>0 ?a') \<rightarrow>\<^sub>D F.map\<^sub>0 (G\<^sub>0 ?b')\<guillemotright>\<close>
	+ using D.hhom_is_subcategory by simp
	+ interpret d: equivalence_of_categories hom_a_b.comp hom_FGa_FGb.comp
	+ d\<^sub>ad\<^sub>b.F d\<^sub>ad\<^sub>b.G d\<^sub>ad\<^sub>b.\<phi> d\<^sub>ad\<^sub>b.\<psi>
	+ using f' d\<^sub>ad\<^sub>b.induces_equivalence_of_hom_categories by simp
	+
	+ have F\<mu>_in_hom: "\<guillemotleft>F \<mu> : F (G f') \<Rightarrow>\<^sub>D F (G g')\<guillemotright>"
	+ using \<mu> by auto
	+ have F\<mu>_in_hhom: "D.in_hhom (F \<mu>) (F.map\<^sub>0 (G\<^sub>0 (src\<^sub>D f'))) (F.map\<^sub>0 (G\<^sub>0 (trg\<^sub>D f')))"
	+ using f' F\<mu>_in_hom D.src_dom [of "F \<mu>"] D.trg_dom [of "F \<mu>"] by fastforce
	+ have "hom_FGa_FGb.in_hom (F \<mu>) (F (G f')) (F (G g'))"
	+ using F\<mu>_in_hom F\<mu>_in_hhom hom_FGa_FGb.in_hom_char hom_FGa_FGb.arr_char
	+ hom_FGa_FGb.cod_closed hom_FGa_FGb.dom_closed
	+ by (metis D.in_homE)
	+ have \<phi>g': "\<guillemotleft>\<phi> g' : F (G g') \<Rightarrow>\<^sub>D e (trg\<^sub>D g') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g')\<guillemotright>"
	+ using g' \<phi>_props [of g'] by blast
	+ have inv_\<phi>f': "\<guillemotleft>D.inv (\<phi> f') : e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f') \<Rightarrow>\<^sub>D F (G f')\<guillemotright>"
	+ using f' \<phi>_props [of f'] G_props by auto
	+
	+ have 1: "\<guillemotleft>\<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f') :
	+ e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f') \<Rightarrow>\<^sub>D e (trg\<^sub>D g') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g')\<guillemotright>"
	+ using F\<mu>_in_hom \<phi>g' inv_\<phi>f' G_ide f' g' by auto
	+ have 2: "hom_FGa_FGb.in_hom (\<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f'))
	+ (e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f'))
	+ (e (trg\<^sub>D g') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D g'))"
	+ proof -
	+ have "hom_FGa_FGb.arr (\<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f'))"
	+ using 1 D.vseq_implies_hpar hom_FGa_FGb.arr_char
	+ by (simp add: D.arrI g' src_eq trg_eq)
	+ thus ?thesis
	+ using 1 hom_FGa_FGb.dom_char hom_FGa_FGb.cod_char
	+ by (metis D.in_homE hom_FGa_FGb.in_homI)
	+ qed
	+ obtain \<mu>' where \<mu>': "hom_a_b.in_hom \<mu>' f' g' \<and> d\<^sub>ad\<^sub>b.G \<mu>' = \<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f')"
	+ using 1 2 f' g' src_eq trg_eq d.is_full [of g' f' "\<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f')"]
	+ hom_a_b.ide_char hom_a_b.arr_char
	+ by auto
	+ have 3: "\<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and> F (G \<mu>') = F \<mu>"
	+ proof -
	+ have 4: "\<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and>
	+ e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f') = \<phi> g' \<cdot>\<^sub>D F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f')"
	+ using \<mu>' f' g' hom_a_b.arr_char hom_a_b.in_hom_char by auto
	+ have "\<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and>
	+ D.inv (\<phi> g') \<cdot>\<^sub>D (e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f')) = F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f')"
	+ proof -
	+ have "D.hseq (e (trg\<^sub>D f')) (\<mu>' \<star>\<^sub>D d (src\<^sub>D f'))"
	+ using f' g' \<mu>'
	+ apply (intro D.hseqI, auto)
	+ by force
	+ thus ?thesis
	+ using 4 g' \<phi>_props(2)
	+ D.invert_side_of_triangle(1)
	+ [of "e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f')" "\<phi> g'" "F \<mu> \<cdot>\<^sub>D D.inv (\<phi> f')"]
	+ by metis
	+ qed
	+ moreover have "D.seq (D.inv (\<phi> g')) (e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f'))"
	+ proof
	+ show "D.in_hom (e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f'))
	+ (e (trg\<^sub>D f') \<star>\<^sub>D f' \<star>\<^sub>D d (src\<^sub>D f'))
	+ (e (trg\<^sub>D f') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D f'))"
	+ using 4 f' g' \<mu>' d_simps e_simps
	+ by (intro D.hcomp_in_vhom, auto)
	+ show "D.in_hom (D.inv (\<phi> g')) (e (trg\<^sub>D f') \<star>\<^sub>D g' \<star>\<^sub>D d (src\<^sub>D f')) (F (G\<^sub>1 g'))"
	+ using 4 g' \<mu>' \<phi>_props [of g'] D.vconn_implies_hpar by simp
	+ qed
	+ ultimately have "\<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and>
	+ D.inv (\<phi> g') \<cdot>\<^sub>D (e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f')) \<cdot>\<^sub>D \<phi> f' = F \<mu>"
	+ using f' \<phi>_props(2) D.iso_inv_iso D.inv_inv D.invert_side_of_triangle(2)
	+ D.comp_assoc
	+ by metis
	+ moreover have "D.inv (\<phi> g') \<cdot>\<^sub>D (e (trg\<^sub>D f') \<star>\<^sub>D \<mu>' \<star>\<^sub>D d (src\<^sub>D f')) \<cdot>\<^sub>D \<phi> f' = F (G \<mu>')"
	+ using 4 G_props(3) by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ hence "G \<mu>' = \<mu>"
	+ using f' g' \<mu> \<mu>' F.is_faithful
	+ by (metis C.in_homE D.in_homE G_ide G_props(2))
	+ thus "\<exists>\<mu>'. \<guillemotleft>\<mu>' : f' \<Rightarrow>\<^sub>D g'\<guillemotright> \<and> G \<mu>' = \<mu>"
	+ using 3 by auto
	+ qed
	+ qed
	+
	+ proposition is_equivalence_pseudofunctor:
	+ shows "equivalence_pseudofunctor V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C G \<Phi>"
	+ ..
	+
	+ end
	+
	+ sublocale converse_equivalence_pseudofunctor \<subseteq>
	+ equivalence_pseudofunctor V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C G \<Phi>
	+ using is_equivalence_pseudofunctor by simp
	+
	+ definition equivalent_bicategories
	+ where "equivalent_bicategories V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C \<equiv>
	+ \<exists>F \<Phi>. equivalence_pseudofunctor
	+ V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C F \<Phi>"
	+
	+ lemma equivalent_bicategories_symmetric:
	+ assumes "equivalent_bicategories V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D"
	+ shows "equivalent_bicategories V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C"
	+ proof -
	+ obtain F \<Phi>\<^sub>F where F: "equivalence_pseudofunctor
	+ V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F"
	+ using assms equivalent_bicategories_def by blast
	+ interpret F: equivalence_pseudofunctor
	+ V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F
	+ using F by simp
	+ interpret G: converse_equivalence_pseudofunctor
	+ V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F
	+ ..
	+ show ?thesis
	+ using G.is_equivalence_pseudofunctor equivalent_bicategories_def by blast
	+ qed
	+
	+ text \<open>
	+ A gross omission here is that I don't show that equivalence pseudofunctors compose,
	+ and consequently that ``\<open>equivalent_bicategories\<close>'' is a transitive relation.
	+ I have been trying to avoid this as part of the current project; proving only as much
	+ as necessary about pseudofunctors and equivalence pseudofunctors to give confidence
	+ that the definitions have been correctly stated. This will have to be rectified in
	+ future work.
	+ \<close>
	+
	+end
	diff --git a/thys/Bicategory/ROOT b/thys/Bicategory/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/ROOT
	@@ -0,0 +1,10 @@
	+chapter AFP
	+
	+session Bicategory (AFP slow) = MonoidalCategory +
	+ options [timeout = 10800, names_unique = false]
	+ theories
	+ BicategoryOfSpans
	+ document_files
	+ "root.bib"
	+ "root.tex"
	+ "triangle_right_implies_left.png"
	diff --git a/thys/Bicategory/SpanBicategory.thy b/thys/Bicategory/SpanBicategory.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/SpanBicategory.thy
	@@ -0,0 +1,5549 @@
	+(* Title: SpanBicategory
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Span Bicategories"
	+
	+text \<open>
	+ In this section we construct the bicategory \<open>Span(C)\<close>, where \<open>C\<close> is a category with pullbacks.
	+ The $0$-cells of \<open>Span(C)\<close> are the objects of \<open>C\<close>, the $1$-cells of \<open>Span(C)\<close> are pairs
	+ \<open>(f\<^sub>0, f\<^sub>1)\<close> of arrows of \<open>C\<close> having a common domain, and the $2$-cells of \<open>Span(C)\<close>
	+ are ``arrows of spans''. An arrow of spans from \<open>(f\<^sub>0, f\<^sub>1)\<close> to \<open>(g\<^sub>0, g\<^sub>1)\<close> is
	+ an arrow \<open>\<guillemotleft>u: dom f\<^sub>0 \<rightarrow> dom g\<^sub>0\<guillemotright>\<close> of \<open>C\<close>, such that \<open>g\<^sub>0 \<cdot> u = f\<^sub>0\<close> and \<open>g\<^sub>1 \<cdot> u = f\<^sub>1\<close>.
	+
	+ In the present development, a \emph{span} is formalized as a structure \<open>\<lparr>Leg0 = f\<^sub>0, Leg1 = f\<^sub>1\<rparr>\<close>,
	+ where \<open>f\<^sub>0\<close> and \<open>f\<^sub>1\<close> are arrows of \<open>C\<close> with a common domain, which we call the \emph{apex} of
	+ the span.
	+ An \emph{arrow of spans} is formalized as a structure \<open>\<lparr>Chn = u, Dom = S, Cod = T\<rparr>\<close>,
	+ where \<open>S\<close> and \<open>T\<close> are spans, and \<open>\<guillemotleft>u : S.apex \<rightarrow> T.apex\<guillemotright>\<close> satisfies \<open>Leg0 T \<cdot> u = Leg0 S\<close>
	+ and \<open>Leg1 T \<cdot> u = Leg1 S\<close>. We refer to the arrow \<open>u\<close> as the \emph{chine} of the arrow of spans.
	+
	+ Arrows of spans inherit a composition from that of \<open>C\<close>; this is ``vertical composition''.
	+ Spans may be composed via pullback in \<open>C\<close>; this ``horizontal composition'' extends to
	+ arrows of spans, so that it is functorial with respect to vertical composition.
	+ These two compositions determine a bicategory, as we shall show.
	+\<close>
	+
	+theory SpanBicategory
	+imports Bicategory CategoryWithPullbacks InternalAdjunction Category3.FreeCategory
	+begin
	+
	+subsection "Spans"
	+
	+ record 'a span_data =
	+ Leg0 :: 'a
	+ Leg1 :: 'a
	+
	+ locale span_in_category =
	+ C: category +
	+ fixes S :: "'a span_data" (structure)
	+ assumes is_span: "C.span (Leg0 S) (Leg1 S)"
	+ begin
	+
	+ abbreviation leg0
	+ where "leg0 \<equiv> Leg0 S"
	+
	+ abbreviation leg1
	+ where "leg1 \<equiv> Leg1 S"
	+
	+ abbreviation src
	+ where "src \<equiv> C.cod leg0"
	+
	+ abbreviation trg
	+ where "trg \<equiv> C.cod leg1"
	+
	+ definition apex
	+ where "apex \<equiv> C.dom leg0"
	+
	+ lemma ide_apex [simp]:
	+ shows "C.ide apex"
	+ using is_span apex_def by simp
	+
	+ lemma leg_in_hom [intro]:
	+ shows "\<guillemotleft>leg0 : apex \<rightarrow> src\<guillemotright>"
	+ and "\<guillemotleft>leg1 : apex \<rightarrow> trg\<guillemotright>"
	+ using is_span apex_def by auto
	+
	+ lemma leg_simps [simp]:
	+ shows "C.arr leg0" and "C.dom leg0 = apex"
	+ and "C.arr leg1" and "C.dom leg1 = apex"
	+ using leg_in_hom by auto
	+
	+ end
	+
	+ record 'a arrow_of_spans_data =
	+ Chn :: 'a
	+ Dom :: "'a span_data"
	+ Cod :: "'a span_data"
	+
	+ locale arrow_of_spans =
	+ C: category C +
	+ dom: span_in_category C \<open>Dom \<mu>\<close> +
	+ cod: span_in_category C \<open>Cod \<mu>\<close>
	+ for C :: "'a comp" (infixr "\<cdot>" 55)
	+ and \<mu> :: "'a arrow_of_spans_data" (structure) +
	+ assumes chine_in_hom [intro]: "\<guillemotleft>Chn \<mu> : dom.apex \<rightarrow> cod.apex\<guillemotright>"
	+ and leg0_commutes [simp]: "cod.leg0 \<cdot> Chn \<mu> = dom.leg0"
	+ and leg1_commutes [simp]: "cod.leg1 \<cdot> (Chn \<mu>) = dom.leg1"
	+ begin
	+
	+ abbreviation chine
	+ where "chine \<equiv> Chn \<mu>"
	+
	+ lemma chine_simps [simp]:
	+ shows "C.arr chine" and "C.dom chine = dom.apex" and "C.cod chine = cod.apex"
	+ using chine_in_hom by auto
	+
	+ lemma cod_src_eq_dom_src [simp]:
	+ shows "cod.src = dom.src"
	+ using dom.is_span cod.is_span
	+ by (metis C.cod_comp leg0_commutes)
	+
	+ lemma cod_trg_eq_dom_trg [simp]:
	+ shows "cod.trg = dom.trg"
	+ using dom.is_span cod.is_span
	+ by (metis C.cod_comp leg1_commutes)
	+
	+ abbreviation dsrc
	+ where "dsrc \<equiv> dom.src"
	+
	+ abbreviation dtrg
	+ where "dtrg \<equiv> dom.trg"
	+
	+ end
	+
	+ locale identity_arrow_of_spans =
	+ arrow_of_spans +
	+ assumes chine_is_identity [simp]: "C.ide (Chn \<mu>)"
	+ begin
	+
	+ abbreviation apex
	+ where "apex \<equiv> dom.apex"
	+
	+ abbreviation leg0
	+ where "leg0 \<equiv> dom.leg0"
	+
	+ abbreviation leg1
	+ where "leg1 \<equiv> dom.leg1"
	+
	+ lemma chine_eq_apex [simp]:
	+ shows "chine = apex"
	+ using chine_is_identity C.ideD(2) chine_simps(2) by presburger
	+
	+ lemma cod_simps [simp]:
	+ shows "cod.apex = apex" and "cod.leg0 = leg0" and "cod.leg1 = leg1"
	+ using chine_is_identity chine_simps(3) C.comp_arr_ide leg0_commutes leg1_commutes
	+ by force+
	+
	+ end
	+
	+ subsection "The Vertical Category of Spans"
	+
	+ text \<open>
	+ The following locale constructs the category of spans and arrows of spans in
	+ an underlying category C, which is not yet assumed to have pullbacks.
	+ The composition is vertical composition of arrows of spans, to which we will
	+ later add horizontal composition to obtain a bicategory.
	+ \<close>
	+
	+ locale span_vertical_category =
	+ C: category
	+ begin
	+
	+ abbreviation Null
	+ where "Null \<equiv> \<lparr>Chn = C.null,
	+ Dom = \<lparr>Leg0 = C.null, Leg1 = C.null\<rparr>,
	+ Cod = \<lparr>Leg0 = C.null, Leg1 = C.null\<rparr>\<rparr>"
	+
	+ lemma not_arr_Null:
	+ shows "\<not> arrow_of_spans C Null"
	+ unfolding arrow_of_spans_def arrow_of_spans_axioms_def
	+ by auto
	+
	+ text \<open>
	+ Arrows of spans are composed simply by composing their chines.
	+ \<close>
	+
	+ definition vcomp
	+ where "vcomp \<nu> \<mu> \<equiv> if arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>
	+ then \<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>
	+ else Null"
	+
	+ notation vcomp (infixr "\<bullet>" 55)
	+
	+ (*
	+ * TODO: The reason why the this and the subsequent category interpretation are declared
	+ * as V: is that subsequently proved facts with the same names as the partial_magma and
	+ * category locales silently override the latter, resulting in problems proving things.
	+ * The presence of the extra "V" is only an issue up until a later sublocale declaration
	+ * inherits everything from horizontal_homs. I wish I could say that I completely
	+ * understood the inheritance and overriding rules for locales.
	+ *)
	+ interpretation V: partial_magma vcomp
	+ using not_arr_Null vcomp_def
	+ apply unfold_locales
	+ by (metis (no_types, hide_lams))
	+
	+ lemma is_partial_magma:
	+ shows "partial_magma vcomp"
	+ ..
	+
	+ lemma null_char:
	+ shows "V.null = Null"
	+ using V.null_def vcomp_def not_arr_Null
	+ by (metis (no_types, lifting) V.comp_null(2))
	+
	+ text \<open>
	+ Identities are arrows of spans whose chines are identities of C.
	+ \<close>
	+
	+ lemma ide_char:
	+ shows "V.ide \<mu> \<longleftrightarrow> arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>)"
	+ proof
	+ show "V.ide \<mu> \<Longrightarrow> arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>)"
	+ proof
	+ assume 0: "V.ide \<mu>"
	+ have 1: "vcomp \<mu> \<mu> \<noteq> Null \<and> (\<forall>\<nu>. (\<nu> \<bullet> \<mu> \<noteq> Null \<longrightarrow> \<nu> \<bullet> \<mu> = \<nu>) \<and>
	+ (\<mu> \<bullet> \<nu> \<noteq> Null \<longrightarrow> \<mu> \<bullet> \<nu> = \<nu>))"
	+ using 0 V.ide_def null_char by simp
	+ show \<mu>: "arrow_of_spans C \<mu>"
	+ using 1 vcomp_def by metis
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using \<mu> by auto
	+ show "C.ide (Chn \<mu>)"
	+ proof -
	+ have "\<mu>.chine \<cdot> \<mu>.chine \<noteq> C.null"
	+ using 1 vcomp_def
	+ by (metis C.in_homE C.not_arr_null C.seqI \<mu>.chine_in_hom)
	+ moreover have "\<And>f. f \<cdot> Chn \<mu> \<noteq> C.null \<Longrightarrow> f \<cdot> Chn \<mu> = f"
	+ proof -
	+ fix f
	+ assume "f \<cdot> \<mu>.chine \<noteq> C.null"
	+ hence f: "\<guillemotleft>f : \<mu>.cod.apex \<rightarrow> C.cod f\<guillemotright>"
	+ using C.ext C.in_homI by force
	+ let ?cod_\<mu> = "\<lparr>Chn = C.cod \<mu>.chine, Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
	+ interpret cod_\<mu>: arrow_of_spans C ?cod_\<mu>
	+ using C.ide_in_hom \<mu>.cod.ide_apex \<mu>.chine_in_hom C.comp_arr_dom
	+ by (unfold_locales, auto)
	+ have "?cod_\<mu> \<bullet> \<mu> = ?cod_\<mu>"
	+ proof -
	+ have "?cod_\<mu> \<bullet> \<mu> \<noteq> Null"
	+ unfolding vcomp_def
	+ using \<mu> cod_\<mu>.arrow_of_spans_axioms \<mu>.cod.is_span C.comp_cod_arr
	+ apply simp
	+ using \<mu>.chine_simps(1) by force
	+ thus ?thesis
	+ using 1 by simp
	+ qed
	+ thus "f \<cdot> \<mu>.chine = f"
	+ unfolding vcomp_def
	+ using f C.comp_arr_ide C.comp_cod_arr \<mu>.arrow_of_spans_axioms
	+ cod_\<mu>.arrow_of_spans_axioms
	+ by auto
	+ qed
	+ moreover have "\<And>f. \<mu>.chine \<cdot> f \<noteq> C.null \<Longrightarrow> \<mu>.chine \<cdot> f = f"
	+ proof -
	+ fix f
	+ assume "\<mu>.chine \<cdot> f \<noteq> C.null"
	+ hence f: "\<guillemotleft>f : C.dom f \<rightarrow> \<mu>.dom.apex\<guillemotright>"
	+ using C.ext C.in_homI by force
	+ let ?dom_\<mu> = "\<lparr>Chn = C.cod f, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
	+ interpret dom_\<mu>: arrow_of_spans C ?dom_\<mu>
	+ using f C.ide_in_hom \<mu>.dom.ide_apex \<mu>.chine_in_hom C.comp_arr_dom
	+ by (unfold_locales, auto)
	+ have "\<mu> \<bullet> ?dom_\<mu> = ?dom_\<mu>"
	+ proof -
	+ have "\<mu> \<bullet> ?dom_\<mu> \<noteq> Null"
	+ unfolding vcomp_def
	+ using \<mu> dom_\<mu>.arrow_of_spans_axioms \<mu>.cod.is_span by (simp, force)
	+ thus ?thesis
	+ using 1 by simp
	+ qed
	+ hence "\<mu>.chine \<cdot> C.cod f = C.cod f"
	+ unfolding vcomp_def
	+ using \<mu> dom_\<mu>.arrow_of_spans_axioms f 0 C.comp_ide_arr C.comp_arr_ide
	+ by simp
	+ thus "\<mu>.chine \<cdot> f = f"
	+ unfolding vcomp_def
	+ using f C.comp_ide_arr C.comp_arr_dom \<mu>.arrow_of_spans_axioms
	+ dom_\<mu>.arrow_of_spans_axioms
	+ by auto
	+ qed
	+ ultimately show "C.ide \<mu>.chine"
	+ unfolding C.ide_def by simp
	+ qed
	+ qed
	+ show "arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>) \<Longrightarrow> V.ide \<mu>"
	+ proof -
	+ assume \<mu>: "arrow_of_spans C \<mu> \<and> C.ide (Chn \<mu>)"
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using \<mu> by auto
	+ have 1: "Dom \<mu> = Cod \<mu>"
	+ proof -
	+ have "\<mu>.dom.leg0 = \<mu>.cod.leg0 \<and> \<mu>.dom.leg1 = \<mu>.cod.leg1"
	+ using \<mu> C.comp_arr_ide \<mu>.cod.is_span by force
	+ thus ?thesis by simp
	+ qed
	+ show "V.ide \<mu>"
	+ proof -
	+ have "\<mu> \<bullet> \<mu> \<noteq> V.null"
	+ using \<mu> 1 vcomp_def by (simp add: C.ide_def null_char)
	+ moreover have "\<And>\<nu>. vcomp \<nu> \<mu> \<noteq> V.null \<Longrightarrow> vcomp \<nu> \<mu> = \<nu>"
	+ proof -
	+ fix \<nu> :: "'a arrow_of_spans_data"
	+ assume \<nu>: "\<nu> \<bullet> \<mu> \<noteq> V.null"
	+ have 2: "arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
	+ using \<nu> 1 vcomp_def by (metis V.comp_null(2))
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ using 2 by auto
	+ show "\<nu> \<bullet> \<mu> = \<nu>"
	+ unfolding vcomp_def
	+ using \<mu> 1 2 C.comp_arr_ide by simp
	+ qed
	+ moreover have "\<And>\<nu>. \<mu> \<bullet> \<nu> \<noteq> V.null \<Longrightarrow> \<mu> \<bullet> \<nu> = \<nu>"
	+ proof -
	+ fix \<nu> :: "'a arrow_of_spans_data"
	+ assume \<nu>: "\<mu> \<bullet> \<nu> \<noteq> V.null"
	+ have 2: "arrow_of_spans C \<nu> \<and> Dom \<mu> = Cod \<nu>"
	+ using \<nu> 1 vcomp_def by (metis V.comp_null(1))
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ using 2 by auto
	+ show "\<mu> \<bullet> \<nu> = \<nu>"
	+ unfolding vcomp_def
	+ using \<mu> 1 2 C.comp_ide_arr by simp
	+ qed
	+ ultimately show ?thesis
	+ unfolding V.ide_def by blast
	+ qed
	+ qed
	+ qed
	+
	+ lemma has_domain_char:
	+ shows "V.domains \<mu> \<noteq> {} \<longleftrightarrow> arrow_of_spans C \<mu>"
	+ proof
	+ show "V.domains \<mu> \<noteq> {} \<Longrightarrow> arrow_of_spans C \<mu>"
	+ using V.domains_def null_char vcomp_def by fastforce
	+ show "arrow_of_spans C \<mu> \<Longrightarrow> V.domains \<mu> \<noteq> {}"
	+ proof -
	+ assume \<mu>: "arrow_of_spans C \<mu>"
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using \<mu> by auto
	+ let ?dom_\<mu> = "\<lparr>Chn = \<mu>.dom.apex, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
	+ interpret dom_\<mu>: arrow_of_spans C ?dom_\<mu>
	+ using C.comp_arr_dom by (unfold_locales, auto)
	+ have "?dom_\<mu> \<in> V.domains \<mu>"
	+ proof -
	+ have "V.ide ?dom_\<mu>"
	+ using ide_char dom_\<mu>.arrow_of_spans_axioms by simp
	+ moreover have "\<mu> \<bullet> ?dom_\<mu> \<noteq> V.null"
	+ using \<mu> vcomp_def \<mu>.cod.span_in_category_axioms dom_\<mu>.arrow_of_spans_axioms
	+ null_char span_in_category.leg_simps(1)
	+ by fastforce
	+ ultimately show ?thesis
	+ unfolding V.domains_def by blast
	+ qed
	+ thus "V.domains \<mu> \<noteq> {}" by blast
	+ qed
	+ qed
	+
	+ lemma has_codomain_char:
	+ shows "V.codomains \<mu> \<noteq> {} \<longleftrightarrow> arrow_of_spans C \<mu>"
	+ proof
	+ show "V.codomains \<mu> \<noteq> {} \<Longrightarrow> arrow_of_spans C \<mu>"
	+ using V.codomains_def null_char vcomp_def by fastforce
	+ show "arrow_of_spans C \<mu> \<Longrightarrow> V.codomains \<mu> \<noteq> {}"
	+ proof -
	+ assume \<mu>: "arrow_of_spans C \<mu>"
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using \<mu> by auto
	+ let ?cod_f = "\<lparr>Chn = \<mu>.cod.apex, Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
	+ interpret cod_f: arrow_of_spans C ?cod_f
	+ using C.comp_arr_dom by (unfold_locales, auto)
	+ have "?cod_f \<in> V.codomains \<mu>"
	+ proof -
	+ have "V.ide ?cod_f"
	+ using ide_char cod_f.arrow_of_spans_axioms by simp
	+ moreover have "?cod_f \<bullet> \<mu> \<noteq> V.null"
	+ using \<mu> vcomp_def \<mu>.cod.span_in_category_axioms cod_f.arrow_of_spans_axioms
	+ null_char span_in_category.leg_simps(1)
	+ by fastforce
	+ ultimately show ?thesis
	+ unfolding V.codomains_def by blast
	+ qed
	+ thus "V.codomains \<mu> \<noteq> {}" by blast
	+ qed
	+ qed
	+
	+ lemma arr_char:
	+ shows "V.arr \<mu> \<longleftrightarrow> arrow_of_spans C \<mu>"
	+ unfolding V.arr_def
	+ using has_domain_char has_codomain_char by simp
	+
	+ lemma seq_char:
	+ shows "V.seq \<nu> \<mu> \<longleftrightarrow> arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
	+ proof
	+ show "V.seq \<nu> \<mu> \<Longrightarrow> arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
	+ using vcomp_def by (metis V.not_arr_null null_char)
	+ show "arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu> \<Longrightarrow> V.seq \<nu> \<mu>"
	+ proof -
	+ assume 1: "arrow_of_spans C \<mu> \<and> arrow_of_spans C \<nu> \<and> Dom \<nu> = Cod \<mu>"
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using 1 by auto
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ using 1 by auto
	+ show "V.seq \<nu> \<mu>"
	+ proof -
	+ let ?\<nu>\<mu> = "\<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>"
	+ have "\<nu> \<bullet> \<mu> = ?\<nu>\<mu>"
	+ using 1 vcomp_def by metis
	+ moreover have "V.arr ?\<nu>\<mu>"
	+ proof -
	+ interpret Dom: span_in_category C \<open>Dom ?\<nu>\<mu>\<close>
	+ by (simp add: \<mu>.dom.span_in_category_axioms)
	+ interpret Cod: span_in_category C \<open>Cod ?\<nu>\<mu>\<close>
	+ by (simp add: \<nu>.cod.span_in_category_axioms)
	+ have "arrow_of_spans C ?\<nu>\<mu>"
	+ using 1 \<mu>.chine_in_hom \<nu>.chine_in_hom C.comp_reduce
	+ by (unfold_locales, cases ?\<nu>\<mu>, auto)
	+ thus ?thesis
	+ using arr_char by blast
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+
	+ interpretation V: category vcomp
	+ proof
	+ show "\<And>\<mu>. (V.domains \<mu> \<noteq> {}) = (V.codomains \<mu> \<noteq> {})"
	+ using has_domain_char has_codomain_char by simp
	+ show "\<And>\<nu> \<mu>. \<nu> \<bullet> \<mu> \<noteq> V.null \<Longrightarrow> V.seq \<nu> \<mu>"
	+ using seq_char vcomp_def null_char by metis
	+ show "\<And>\<pi> \<nu> \<mu>. V.seq \<pi> \<nu> \<Longrightarrow> V.seq (\<pi> \<bullet> \<nu>) \<mu> \<Longrightarrow> V.seq \<nu> \<mu>"
	+ using seq_char vcomp_def by (metis arrow_of_spans_data.select_convs(2))
	+ show "\<And>\<pi> \<nu> \<mu>. V.seq \<pi> (\<nu> \<bullet> \<mu>) \<Longrightarrow> V.seq \<nu> \<mu> \<Longrightarrow> V.seq \<pi> \<nu>"
	+ using seq_char vcomp_def by (metis arrow_of_spans_data.select_convs(3))
	+ show "\<And>\<nu> \<mu> \<pi>. V.seq \<nu> \<mu> \<Longrightarrow> V.seq \<pi> \<nu> \<Longrightarrow> V.seq (\<pi> \<bullet> \<nu>) \<mu>"
	+ using seq_char vcomp_def by (metis arr_char arrow_of_spans_data.select_convs(2))
	+ show "\<And>\<nu> \<mu> \<pi>. V.seq \<nu> \<mu> \<Longrightarrow> V.seq \<pi> \<nu> \<Longrightarrow> (\<pi> \<bullet> \<nu>) \<bullet> \<mu> = \<pi> \<bullet> \<nu> \<bullet> \<mu>"
	+ proof -
	+ fix \<mu> \<nu> \<pi>
	+ assume \<mu>\<nu>: "V.seq \<nu> \<mu>" and \<nu>\<pi>: "V.seq \<pi> \<nu>"
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using \<mu>\<nu> seq_char by auto
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ using \<mu>\<nu> seq_char by auto
	+ interpret \<pi>: arrow_of_spans C \<pi>
	+ using \<nu>\<pi> seq_char by auto
	+ show "(\<pi> \<bullet> \<nu>) \<bullet> \<mu> = \<pi> \<bullet> \<nu> \<bullet> \<mu>"
	+ unfolding vcomp_def
	+ using \<mu>\<nu> \<nu>\<pi> seq_char \<mu>.chine_in_hom \<nu>.chine_in_hom \<pi>.chine_in_hom
	+ by (simp add: C.comp_assoc, metis arr_char vcomp_def)
	+ qed
	+ qed
	+
	+ lemma is_category:
	+ shows "category vcomp"
	+ ..
	+
	+ lemma dom_char:
	+ shows "V.dom = (\<lambda>\<mu>. if V.arr \<mu> then
	+ \<lparr>Chn = span_in_category.apex C (Dom \<mu>), Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>
	+ else V.null)"
	+ proof
	+ fix \<mu>
	+ have "\<not> V.arr \<mu> \<Longrightarrow> V.dom \<mu> = V.null"
	+ by (simp add: V.arr_def V.dom_def)
	+ moreover have "V.arr \<mu> \<Longrightarrow> V.dom \<mu> = \<lparr>Chn = span_in_category.apex C (Dom \<mu>),
	+ Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
	+ proof (intro V.dom_eqI)
	+ assume \<mu>: "V.arr \<mu>"
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using \<mu> arr_char by auto
	+ let ?dom_\<mu> = "\<lparr>Chn = \<mu>.dom.apex, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
	+ interpret dom_\<mu>: arrow_of_spans C ?dom_\<mu>
	+ using C.comp_arr_dom by (unfold_locales, auto)
	+ show "V.ide ?dom_\<mu>"
	+ using ide_char dom_\<mu>.arrow_of_spans_axioms by simp
	+ thus "V.seq \<mu> ?dom_\<mu>"
	+ using seq_char ide_char \<mu>.arrow_of_spans_axioms by simp
	+ qed
	+ ultimately show "V.dom \<mu> = (if V.arr \<mu> then
	+ \<lparr>Chn = span_in_category.apex C (Dom \<mu>),
	+ Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>
	+ else V.null)"
	+ by argo
	+ qed
	+
	+ lemma cod_char:
	+ shows "V.cod = (\<lambda>\<mu>. if V.arr \<mu> then
	+ \<lparr>Chn = span_in_category.apex C (Cod \<mu>), Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>
	+ else V.null)"
	+ proof
	+ fix \<mu>
	+ have "\<not> V.arr \<mu> \<Longrightarrow> V.cod \<mu> = V.null"
	+ by (simp add: V.arr_def V.cod_def)
	+ moreover have "V.arr \<mu> \<Longrightarrow> V.cod \<mu> = \<lparr>Chn = span_in_category.apex C (Cod \<mu>),
	+ Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
	+ proof (intro V.cod_eqI)
	+ assume \<mu>: "V.arr \<mu>"
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using \<mu> arr_char by auto
	+ let ?cod_\<mu> = "\<lparr>Chn = \<mu>.cod.apex, Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
	+ interpret cod_\<mu>: arrow_of_spans C ?cod_\<mu>
	+ using C.comp_arr_dom by (unfold_locales, auto)
	+ show "V.ide ?cod_\<mu>"
	+ using ide_char cod_\<mu>.arrow_of_spans_axioms by simp
	+ thus "V.seq ?cod_\<mu> \<mu>"
	+ using seq_char ide_char \<mu>.arrow_of_spans_axioms by simp
	+ qed
	+ ultimately show "V.cod \<mu> = (if V.arr \<mu> then
	+ \<lparr>Chn = span_in_category.apex C (Cod \<mu>),
	+ Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>
	+ else V.null)"
	+ by argo
	+ qed
	+
	+ lemma vcomp_char:
	+ shows "vcomp = (\<lambda>\<nu> \<mu>. if V.seq \<nu> \<mu> then
	+ \<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>
	+ else V.null)"
	+ proof -
	+ have "\<And>\<mu> \<nu>. \<nu> \<bullet> \<mu> = (if V.seq \<nu> \<mu> then
	+ \<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>
	+ else V.null)"
	+ using vcomp_def seq_char null_char by simp
	+ thus ?thesis by auto
	+ qed
	+
	+ lemma vcomp_eq:
	+ assumes "V.seq \<nu> \<mu>"
	+ shows "\<nu> \<bullet> \<mu> = \<lparr>Chn = Chn \<nu> \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Cod \<nu>\<rparr>"
	+ using assms vcomp_char by meson
	+
	+ lemma Chn_vcomp:
	+ assumes "V.seq \<nu> \<mu>"
	+ shows "Chn (\<nu> \<bullet> \<mu>) = Chn \<nu> \<cdot> Chn \<mu>"
	+ using assms vcomp_eq [of \<nu> \<mu>] by simp
	+
	+ lemma ide_char':
	+ shows "V.ide \<mu> \<longleftrightarrow> identity_arrow_of_spans C \<mu>"
	+ using arr_char ide_char identity_arrow_of_spans_axioms_def identity_arrow_of_spans_def
	+ identity_arrow_of_spans.axioms(1) identity_arrow_of_spans.chine_is_identity
	+ by metis
	+
	+ lemma Chn_in_hom:
	+ assumes "V.in_hom \<tau> f g"
	+ shows "C.in_hom (Chn \<tau>) (Chn f) (Chn g)"
	+ using assms ide_char arr_char dom_char cod_char
	+ by (metis (no_types, lifting) C.ide_char arrow_of_spans.chine_in_hom
	+ arrow_of_spans.chine_simps(3) arrow_of_spans_data.simps(3) V.ide_cod
	+ V.ide_dom V.in_homE)
	+
	+ abbreviation mkIde
	+ where "mkIde f0 f1 \<equiv>
	+ \<lparr>Chn = C.dom f0, Dom = \<lparr>Leg0 = f0, Leg1 = f1\<rparr>, Cod = \<lparr>Leg0 = f0, Leg1 = f1\<rparr>\<rparr>"
	+
	+ lemma ide_mkIde:
	+ assumes "C.span f0 f1"
	+ shows "V.ide (mkIde f0 f1)"
	+ proof -
	+ interpret f: span_in_category C \<open>\<lparr>Leg0 = f0, Leg1 = f1\<rparr>\<close>
	+ using assms by (unfold_locales, auto)
	+ interpret ff: arrow_of_spans C \<open>mkIde f0 f1\<close>
	+ using assms f.apex_def C.comp_arr_dom
	+ by (unfold_locales, auto)
	+ show ?thesis
	+ using assms ff.arrow_of_spans_axioms ide_char by simp
	+ qed
	+
	+ abbreviation mkObj
	+ where "mkObj a \<equiv> mkIde a a"
	+
	+ lemma ide_mkObj:
	+ assumes "C.ide a"
	+ shows "V.ide (mkObj a)"
	+ using assms ide_mkIde [of a a] by auto
	+
	+ lemma inverse_arrows:
	+ assumes "V.arr \<mu>" and "C.iso (Chn \<mu>)"
	+ shows "V.inverse_arrows \<mu> \<lparr>Chn = C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Dom \<mu>\<rparr>"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ let ?\<nu> = "\<lparr>Chn = C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Dom \<mu>\<rparr>"
	+ interpret \<nu>: arrow_of_spans C ?\<nu>
	+ using assms C.invert_side_of_triangle(2) [of \<mu>.dom.leg0 \<mu>.cod.leg0 \<mu>.chine]
	+ C.invert_side_of_triangle(2) [of \<mu>.dom.leg1 \<mu>.cod.leg1 \<mu>.chine]
	+ by (unfold_locales, auto)
	+ show "V.inverse_arrows \<mu> ?\<nu>"
	+ proof
	+ show "V.ide (?\<nu> \<bullet> \<mu>)"
	+ proof -
	+ have 1: "V.seq ?\<nu> \<mu>"
	+ using arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
	+ \<nu>.arrow_of_spans_axioms
	+ by (intro V.seqI', auto)
	+ have 2: "?\<nu> \<bullet> \<mu> = \<lparr>Chn = C.inv (Chn \<mu>) \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
	+ using 1 arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
	+ \<nu>.arrow_of_spans_axioms
	+ by simp
	+ moreover have
	+ "V.ide \<lparr>Chn = C.inv (Chn \<mu>) \<cdot> Chn \<mu>, Dom = Dom \<mu>, Cod = Dom \<mu>\<rparr>"
	+ using assms 1 2 arr_char ide_char by (simp add: C.comp_inv_arr')
	+ ultimately show ?thesis by simp
	+ qed
	+ show "V.ide (\<mu> \<bullet> ?\<nu>)"
	+ proof -
	+ have 1: "V.seq \<mu> ?\<nu>"
	+ using arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
	+ \<nu>.arrow_of_spans_axioms
	+ by (intro V.seqI', auto)
	+ have 2: "\<mu> \<bullet> ?\<nu> = \<lparr>Chn = Chn \<mu> \<cdot> C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
	+ using 1 arr_char ide_char dom_char cod_char vcomp_def \<mu>.arrow_of_spans_axioms
	+ \<nu>.arrow_of_spans_axioms
	+ by simp
	+ moreover have "V.ide \<lparr>Chn = Chn \<mu> \<cdot> C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Cod \<mu>\<rparr>"
	+ using assms 1 2 arr_char ide_char by (simp add: C.comp_arr_inv')
	+ ultimately show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+
	+ lemma iso_char:
	+ shows "V.iso \<mu> \<longleftrightarrow> V.arr \<mu> \<and> C.iso (Chn \<mu>)"
	+ proof
	+ show "V.iso \<mu> \<Longrightarrow> V.arr \<mu> \<and> C.iso (Chn \<mu>)"
	+ using vcomp_eq ide_char
	+ by (metis C.iso_iff_section_and_retraction C.retractionI C.sectionI Chn_vcomp
	+ V.arr_cod V.arr_dom V.comp_arr_inv' V.comp_inv_arr' V.ide_cod V.ide_dom
	+ V.iso_is_arr)
	+ show "V.arr \<mu> \<and> C.iso (Chn \<mu>) \<Longrightarrow> V.iso \<mu>"
	+ using inverse_arrows by auto
	+ qed
	+
	+ lemma inv_eq:
	+ assumes "V.iso \<mu>"
	+ shows "V.inv \<mu> = \<lparr>Chn = C.inv (Chn \<mu>), Dom = Cod \<mu>, Cod = Dom \<mu>\<rparr>"
	+ using assms inverse_arrows iso_char by (simp add: V.inverse_unique)
	+
	+ end
	+
	+ subsection "Putting Spans in Homs"
	+
	+ context span_vertical_category
	+ begin
	+
	+ interpretation V: category vcomp
	+ using is_category by simp
	+
	+ definition src
	+ where "src \<mu> \<equiv> if V.arr \<mu> then mkObj (C.cod (Leg0 (Dom \<mu>))) else V.null"
	+
	+ lemma ide_src [simp]:
	+ assumes "V.arr \<mu>"
	+ shows "V.ide (src \<mu>)"
	+ using assms src_def arr_char ide_mkObj C.ide_cod
	+ by (simp add: arrow_of_spans_def span_in_category.leg_simps(1))
	+
	+ interpretation src: endofunctor vcomp src
	+ proof
	+ show "\<And>\<mu>. \<not> V.arr \<mu> \<Longrightarrow> src \<mu> = V.null"
	+ using arr_char by (simp add: src_def null_char)
	+ show 1: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.arr (src \<mu>)"
	+ using ide_src by simp
	+ show 2: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.dom (src \<mu>) = src (V.dom \<mu>)"
	+ using 1 arr_char src_def dom_char ide_src V.arr_dom V.ideD(2) by force
	+ show 3: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.cod (src \<mu>) = src (V.cod \<mu>)"
	+ using 1 arr_char src_def cod_char ide_src V.arr_cod V.ideD(3)
	+ arrow_of_spans.cod_src_eq_dom_src
	+ by force
	+ show "\<And>\<mu> \<nu>. V.seq \<nu> \<mu> \<Longrightarrow> src (\<nu> \<bullet> \<mu>) = src \<nu> \<bullet> src \<mu>"
	+ proof -
	+ fix \<mu> \<nu>
	+ assume \<mu>\<nu>: "V.seq \<nu> \<mu>"
	+ show "src (\<nu> \<bullet> \<mu>) = src \<nu> \<bullet> src \<mu>"
	+ proof -
	+ have "src (\<nu> \<bullet> \<mu>) = mkObj (C.cod (Leg0 (Dom \<mu>)))"
	+ using \<mu>\<nu> src_def vcomp_def
	+ apply simp
	+ using V.not_arr_null null_char by auto
	+ also have
	+ "... = \<lparr>Chn = C.dom (C.cod (Leg0 (Dom \<mu>))) \<cdot> C.dom (C.cod (Leg0 (Dom \<mu>))),
	+ Dom = \<lparr>Leg0 = C.cod (Leg0 (Dom \<mu>)), Leg1 = C.cod (Leg0 (Dom \<mu>))\<rparr>,
	+ Cod = \<lparr>Leg0 = C.cod (Leg0 (Dom \<mu>)), Leg1 = C.cod (Leg0 (Dom \<mu>))\<rparr>\<rparr>"
	+ using \<mu>\<nu> 1
	+ by (simp add: arrow_of_spans_def seq_char span_in_category.leg_simps(1))
	+ also have "... = src \<nu> \<bullet> src \<mu>"
	+ using \<mu>\<nu> 1 src_def vcomp_def
	+ apply (elim V.seqE, simp)
	+ by (metis \<mu>\<nu> arrow_of_spans.cod_src_eq_dom_src ide_char seq_char ide_src)
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+
	+ lemma src_is_endofunctor:
	+ shows "endofunctor vcomp src"
	+ ..
	+
	+ lemma src_vcomp:
	+ assumes "V.seq \<nu> \<mu>"
	+ shows "src (\<nu> \<bullet> \<mu>) = src \<nu> \<bullet> src \<mu>"
	+ using assms src.preserves_comp by simp
	+
	+ definition trg
	+ where "trg \<mu> \<equiv> if V.arr \<mu> then mkObj (C.cod (Leg1 (Dom \<mu>))) else V.null"
	+
	+ lemma ide_trg [simp]:
	+ assumes "V.arr \<mu>"
	+ shows "V.ide (trg \<mu>)"
	+ using assms trg_def arr_char ide_mkObj C.ide_cod
	+ by (simp add: arrow_of_spans_def span_in_category.leg_simps(3))
	+
	+ interpretation trg: endofunctor vcomp trg
	+ proof
	+ show "\<And>\<mu>. \<not> V.arr \<mu> \<Longrightarrow> trg \<mu> = V.null"
	+ using arr_char by (simp add: trg_def null_char)
	+ show 1: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.arr (trg \<mu>)"
	+ using ide_trg by simp
	+ show 2: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.dom (trg \<mu>) = trg (V.dom \<mu>)"
	+ using 1 arr_char trg_def dom_char ide_trg V.arr_dom V.ideD(2) by force
	+ show 3: "\<And>\<mu>. V.arr \<mu> \<Longrightarrow> V.cod (trg \<mu>) = trg (V.cod \<mu>)"
	+ using 1 arr_char trg_def cod_char ide_trg V.arr_cod V.ideD(3)
	+ arrow_of_spans.cod_trg_eq_dom_trg
	+ by force
	+ show "\<And>\<mu> \<nu>. V.seq \<nu> \<mu> \<Longrightarrow> trg (\<nu> \<bullet> \<mu>) = trg \<nu> \<bullet> trg \<mu>"
	+ proof -
	+ fix \<mu> \<nu>
	+ assume \<mu>\<nu>: "V.seq \<nu> \<mu>"
	+ show "trg (\<nu> \<bullet> \<mu>) = trg \<nu> \<bullet> trg \<mu>"
	+ proof -
	+ have "trg (\<nu> \<bullet> \<mu>) = mkObj (C.cod (Leg1 (Dom \<mu>)))"
	+ using \<mu>\<nu> trg_def vcomp_def
	+ apply simp
	+ using V.not_arr_null null_char by auto
	+ also have "... = \<lparr>Chn = Chn (trg \<nu>) \<cdot> Chn (trg \<mu>),
	+ Dom = Dom (trg \<mu>), Cod = Cod (trg \<nu>)\<rparr>"
	+ using \<mu>\<nu> 1 trg_def vcomp_def
	+ apply (elim V.seqE, simp)
	+ by (metis C.ide_def \<mu>\<nu> arrow_of_spans.cod_trg_eq_dom_trg select_convs(1) ide_char
	+ ide_trg seq_char)
	+ also have "... = trg \<nu> \<bullet> trg \<mu>"
	+ using \<mu>\<nu> 1 src_def vcomp_def
	+ apply (elim V.seqE, simp)
	+ by (metis "2" "3" V.ideD(2) V.ideD(3) select_convs(2) select_convs(3) ide_char
	+ ide_trg trg_def)
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+
	+ lemma trg_is_endofunctor:
	+ shows "endofunctor vcomp trg"
	+ ..
	+
	+ lemma trg_vcomp:
	+ assumes "V.seq \<nu> \<mu>"
	+ shows "trg (\<nu> \<bullet> \<mu>) = trg \<nu> \<bullet> trg \<mu>"
	+ using assms trg.preserves_comp by simp
	+
	+ lemma src_trg_simps [simp]:
	+ assumes "V.arr \<mu>"
	+ shows "src (src \<mu>) = src \<mu>"
	+ and "src (trg \<mu>) = trg \<mu>"
	+ and "trg (src \<mu>) = src \<mu>"
	+ and "trg (trg \<mu>) = trg \<mu>"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ have 1: "V.arr \<lparr>Chn = \<mu>.dsrc, Dom = \<lparr>Leg0 = \<mu>.dsrc, Leg1 = \<mu>.dsrc\<rparr>,
	+ Cod = \<lparr>Leg0 = \<mu>.dsrc, Leg1 = \<mu>.dsrc\<rparr>\<rparr>"
	+ using ide_mkObj by auto
	+ have 2: "V.arr \<lparr>Chn = \<mu>.dtrg, Dom = \<lparr>Leg0 = \<mu>.dtrg, Leg1 = \<mu>.dtrg\<rparr>,
	+ Cod = \<lparr>Leg0 = \<mu>.dtrg, Leg1 = \<mu>.dtrg\<rparr>\<rparr>"
	+ using ide_mkObj by auto
	+ show "src (src \<mu>) = src \<mu>"
	+ using assms 1 src_def by simp
	+ show "trg (src \<mu>) = src \<mu>"
	+ using assms 1 src_def trg_def by simp
	+ show "src (trg \<mu>) = trg \<mu>"
	+ using assms 2 src_def trg_def by simp
	+ show "trg (trg \<mu>) = trg \<mu>"
	+ using assms 2 trg_def by simp
	+ qed
	+
	+ sublocale horizontal_homs vcomp src trg
	+ by (unfold_locales, simp_all)
	+
	+ lemma has_horizontal_homs:
	+ shows "horizontal_homs vcomp src trg"
	+ ..
	+
	+ lemma obj_char:
	+ shows "obj a \<longleftrightarrow> V.ide a \<and> a = mkObj (Chn a)"
	+ proof
	+ show "obj a \<Longrightarrow> V.ide a \<and> a = mkObj (Chn a)"
	+ proof
	+ assume a: "obj a"
	+ show 1: "V.ide a"
	+ using a by auto
	+ show "a = mkObj (Chn a)"
	+ using a 1 obj_def src_def ide_char
	+ apply simp
	+ by (metis arrow_of_spans_data.select_convs(1) arrow_of_spans_def category.dom_cod
	+ span_in_category.is_span)
	+ qed
	+ show "V.ide a \<and> a = mkObj (Chn a) \<Longrightarrow> obj a"
	+ proof -
	+ assume a: "V.ide a \<and> a = mkObj (Chn a)"
	+ show "obj a"
	+ unfolding obj_def src_def
	+ using a
	+ apply simp
	+ by (metis C.ide_char arrow_of_spans_data.select_convs(2) ide_char
	+ span_data.select_convs(1))
	+ qed
	+ qed
	+
	+ end
	+
	+ subsection "Horizontal Composite of Spans"
	+
	+ text \<open>
	+ We now define the horizontal composite \<open>S \<star> T\<close> of spans \<open>S\<close> and \<open>T\<close>,
	+ assuming that \<open>C\<close> is a category with chosen pullbacks.
	+ We think of Leg0 as an input and Leg1 as an output.
	+ The following then defines the composite span \<open>S \<star> T\<close>, with \<open>T\<close> on the ``input side'' of \<open>S\<close>.
	+ The notation is such that the \<open>\<p>\<^sub>0\<close> projections of \<open>C\<close> are used for legs on the input
	+ (\emph{i.e.} the ``0'') side and the \<open>\<p>\<^sub>1\<close> projections are used for legs on the output
	+ (\emph{i.e.} the ``1'') side.
	+ \<close>
	+
	+ locale composite_span =
	+ C: elementary_category_with_pullbacks +
	+ S: span_in_category C S +
	+ T: span_in_category C T
	+ for S (structure)
	+ and T (structure) +
	+ assumes composable: "C.cod (Leg0 S) = C.cod (Leg1 T)"
	+ begin
	+
	+ abbreviation this
	+ where "this \<equiv> \<lparr>Leg0 = T.leg0 \<cdot> \<p>\<^sub>0[S.leg0, T.leg1], Leg1 = S.leg1 \<cdot> \<p>\<^sub>1[S.leg0, T.leg1]\<rparr>"
	+
	+ lemma leg0_prj_in_hom:
	+ shows "\<guillemotleft>T.leg0 \<cdot> \<p>\<^sub>0[S.leg0, T.leg1] : S.leg0 \<down>\<down> T.leg1 \<rightarrow> C.cod (Leg0 T)\<guillemotright>"
	+ using S.is_span T.is_span C.prj0_in_hom [of "Leg0 S" "Leg1 T"] composable by auto
	+
	+ lemma leg1_prj_in_hom:
	+ shows "\<guillemotleft>S.leg1 \<cdot> \<p>\<^sub>1[S.leg0, T.leg1] : S.leg0 \<down>\<down> T.leg1 \<rightarrow> C.cod (Leg1 S)\<guillemotright>"
	+ using S.is_span T.is_span C.prj1_in_hom [of "Leg0 S" "Leg1 T"] composable by auto
	+
	+ lemma is_span [simp]:
	+ shows "span_in_category C this"
	+ using leg0_prj_in_hom leg1_prj_in_hom
	+ by (unfold_locales, fastforce)
	+
	+ sublocale span_in_category C this
	+ using is_span by auto
	+
	+ end
	+
	+ locale span_bicategory =
	+ C: elementary_category_with_pullbacks +
	+ span_vertical_category
	+ begin
	+
	+ definition chine_hcomp
	+ where "chine_hcomp \<nu> \<mu> \<equiv>
	+ \<langle>Chn \<nu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]
	+ \<lbrakk>Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)\<rbrakk>
	+ Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]\<rangle>"
	+
	+ text \<open>
	+$$\xymatrix{
	+ & & \scriptstyle{{\rm src}({\rm Dom}~\nu)} \;=\; {{\rm trg}({\rm Dom}~\mu)} & &\\
	+ &
	+ \ar[ddl] _{{\rm Leg1}({\rm Dom}~\nu)}
	+ \ar [ur] ^<>(0.4){{\rm Leg0}({\rm Dom}~\nu)\hspace{20pt}}
	+ \ar[dddd] ^{{\rm Chn}~\nu}
	+ &
	+ &
	+ \ar[ul] _<>(0.4){\hspace{20pt}{\rm Leg1}({\rm Dom}~\mu)}
	+ \ar[ddr] ^{{\rm Leg0}({\rm Dom}~\mu)}
	+ \ar[dddd] _{{\rm Chn}~\mu}
	+ \\
	+ & &
	+ \ar[ul] ^{p_1}
	+ \ar[ur] _{p_0}
	+ \ar@ {.>}[dd]^<>(0.3){{\rm chn\_hcomp~\mu~\nu}}
	+ \\
	+ \scriptstyle{{\rm trg}~\nu} & & & & \scriptstyle{{\rm src}~\mu} \\
	+ & &
	+ \ar[dl] _{p_1}
	+ \ar[dr] ^{p_0}
	+ & &
	+ \\
	+ &
	+ \ar[uul] ^{{\rm Leg1}({\rm Cod}~\nu)}
	+ \ar[dr] _<>(0.4){{\rm Leg1}({\rm Cod}~\nu)\hspace{20pt}}
	+ & &
	+ \ar[dl] ^<>(0.4){\hspace{20pt}{\rm Leg1}({\rm Cod}~\mu)}
	+ \ar[uur] _{{\rm Leg0}({\rm Cod}~\mu)}
	+ \\
	+ & & \scriptstyle{{\rm src}({\rm Cod}~\nu)} \;=\; {{\rm trg}({\rm Cod}~\mu)} & &
	+}$$
	+ \<close>
	+
	+ definition hcomp
	+ where "hcomp \<nu> \<mu> \<equiv> if arr \<mu> \<and> arr \<nu> \<and> src \<nu> = trg \<mu> then
	+ \<lparr>Chn = chine_hcomp \<nu> \<mu>,
	+ Dom = composite_span.this C prj0 prj1 (Dom \<nu>) (Dom \<mu>),
	+ Cod = composite_span.this C prj0 prj1 (Cod \<nu>) (Cod \<mu>)\<rparr>
	+ else
	+ null"
	+
	+ notation hcomp (infixr "\<star>" 53)
	+
	+ lemma chine_hcomp_props:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
	+ shows "\<guillemotleft>chine_hcomp \<nu> \<mu> :
	+ Leg0 (Dom \<nu>) \<down>\<down> Leg1 (Dom \<mu>) \<rightarrow> Leg0 (Cod \<nu>) \<down>\<down> Leg1 (Cod \<mu>)\<guillemotright>"
	+ and "C.commutative_square (Leg0 (Cod \<nu>)) (Leg1 (Cod \<mu>))
	+ (Chn \<nu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)])
	+ (Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)])"
	+ and "C.commutative_square \<p>\<^sub>1[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] (Chn \<nu>)
	+ (chine_hcomp \<nu> \<mu>) \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
	+ and "C.commutative_square \<p>\<^sub>0[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] (Chn \<mu>)
	+ (chine_hcomp \<nu> \<mu>) \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
	+ and "\<p>\<^sub>0[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] \<cdot> chine_hcomp \<nu> \<mu> =
	+ Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
	+ and "\<p>\<^sub>1[Leg0 (Cod \<nu>), Leg1 (Cod \<mu>)] \<cdot> chine_hcomp \<nu> \<mu> =
	+ Chn \<nu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<nu>), Leg1 (Dom \<mu>)]"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ using assms arr_char by auto
	+ show 0: "C.commutative_square \<nu>.cod.leg0 \<mu>.cod.leg1
	+ (\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]) (\<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
	+ using assms src_def trg_def C.pullback_commutes C.comp_reduce C.commutative_square_def
	+ by auto
	+ show 1: "\<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu> = \<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ unfolding chine_hcomp_def
	+ using 0 by simp
	+ show 2: "\<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu> = \<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ unfolding chine_hcomp_def
	+ using 0 by simp
	+ show 3: "\<guillemotleft>chine_hcomp \<nu> \<mu> : \<nu>.dom.leg0 \<down>\<down> \<mu>.dom.leg1 \<rightarrow> \<nu>.cod.leg0 \<down>\<down> \<mu>.cod.leg1\<guillemotright>"
	+ unfolding chine_hcomp_def
	+ using assms 0 src_def trg_def C.tuple_in_hom by auto
	+ show "C.commutative_square \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1] \<nu>.chine
	+ (chine_hcomp \<nu> \<mu>) \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using assms src_def trg_def 1 3 by auto
	+ show "C.commutative_square \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1] \<mu>.chine
	+ (chine_hcomp \<nu> \<mu>) \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using assms src_def trg_def 2 3 by auto
	+ qed
	+
	+ lemma chine_hcomp_in_hom [intro]:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
	+ shows "\<guillemotleft>chine_hcomp \<nu> \<mu> :
	+ Leg0 (Dom \<nu>) \<down>\<down> Leg1 (Dom \<mu>) \<rightarrow> Leg0 (Cod \<nu>) \<down>\<down> Leg1 (Cod \<mu>)\<guillemotright>"
	+ using assms chine_hcomp_props(1) by simp
	+
	+ lemma arrow_of_spans_hcomp:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
	+ shows "arrow_of_spans C (\<nu> \<star> \<mu>)"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ using assms arr_char by auto
	+ show ?thesis
	+ proof
	+ show span_Dom: "C.span (Leg0 (Dom (\<nu> \<star> \<mu>))) (Leg1 (Dom (\<nu> \<star> \<mu>)))"
	+ using assms src_def trg_def hcomp_def C.seqI' by auto
	+ interpret Dom: span_in_category C \<open>Dom (\<nu> \<star> \<mu>)\<close>
	+ using span_Dom by (unfold_locales, auto)
	+ show span_Cod: "C.span (Leg0 (Cod (\<nu> \<star> \<mu>))) (Leg1 (Cod (\<nu> \<star> \<mu>)))"
	+ using assms hcomp_def src_def trg_def by auto
	+ interpret Cod: span_in_category C \<open>Cod (\<nu> \<star> \<mu>)\<close>
	+ using span_Cod by (unfold_locales, auto)
	+ show map: "\<guillemotleft>Chn (\<nu> \<star> \<mu>) : Dom.apex \<rightarrow> Cod.apex\<guillemotright>"
	+ using assms src_def trg_def chine_hcomp_props hcomp_def Cod.apex_def Dom.apex_def
	+ by auto
	+ show "Cod.leg0 \<cdot> Chn (\<nu> \<star> \<mu>) = Dom.leg0"
	+ proof -
	+ have "(\<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
	+ \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ proof -
	+ have "(\<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
	+ \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu>"
	+ using assms
	+ by (metis (full_types) C.category_axioms C.comp_reduce C.dom_comp C.match_2
	+ C.seqE C.seqI category.ext)
	+ also have "... = \<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using assms src_def trg_def
	+ by (simp add: chine_hcomp_def chine_hcomp_props(2))
	+ also have "... = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using assms \<mu>.leg0_commutes C.comp_reduce
	+ by (metis (mono_tags, lifting) C.commutative_squareE \<mu>.dom.leg_simps(1)
	+ chine_hcomp_props(2))
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using assms src_def trg_def hcomp_def chine_hcomp_props \<mu>.chine_in_hom C.comp_reduce
	+ by auto
	+ qed
	+ show "Cod.leg1 \<cdot> Chn (\<nu> \<star> \<mu>) = Dom.leg1"
	+ proof -
	+ have "(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
	+ \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ proof -
	+ have "(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu> =
	+ \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1] \<cdot> chine_hcomp \<nu> \<mu>"
	+ using assms
	+ by (metis (full_types) C.category_axioms C.comp_reduce C.dom_comp C.match_2
	+ C.seqE C.seqI category.ext)
	+ also have "... = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using assms src_def trg_def
	+ by (simp add: chine_hcomp_def chine_hcomp_props(2))
	+ also have "... = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using assms \<nu>.leg1_commutes C.comp_reduce
	+ by (metis (mono_tags, lifting) C.commutative_squareE \<nu>.dom.leg_simps(3)
	+ chine_hcomp_props(2))
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using assms src_def trg_def hcomp_def chine_hcomp_props \<nu>.chine_in_hom C.comp_reduce
	+ by auto
	+ qed
	+ qed
	+ qed
	+
	+ lemma chine_hcomp_ide_arr:
	+ assumes "ide f" and "arr \<mu>" and "src f = trg \<mu>"
	+ shows "chine_hcomp f \<mu> =
	+ \<langle>\<p>\<^sub>1[Leg0 (Dom f), Leg1 (Dom \<mu>)]
	+ \<lbrakk>Leg0 (Cod f), Leg1 (Cod \<mu>)\<rbrakk>
	+ Chn \<mu> \<cdot> \<p>\<^sub>0[Leg0 (Dom f), Leg1 (Dom \<mu>)]\<rangle>"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ interpret f: arrow_of_spans C f
	+ using assms ide_char by auto
	+ have 1: "C.cospan f.dom.leg0 \<mu>.dom.leg1"
	+ using assms src_def trg_def by auto
	+ have "chine_hcomp f \<mu> = \<langle>f.chine \<cdot> \<p>\<^sub>1[f.dom.leg0, \<mu>.dom.leg1]
	+ \<lbrakk>f.cod.leg0, \<mu>.cod.leg1\<rbrakk>
	+ \<mu>.chine \<cdot> \<p>\<^sub>0[f.dom.leg0, \<mu>.dom.leg1]\<rangle>"
	+ unfolding chine_hcomp_def
	+ using assms ide_char by simp
	+ moreover have "f.chine \<cdot> \<p>\<^sub>1[f.dom.leg0, \<mu>.dom.leg1] = \<p>\<^sub>1[f.dom.leg0, \<mu>.dom.leg1]"
	+ using assms 1 C.comp_ide_arr ide_char by auto
	+ ultimately show ?thesis by argo
	+ qed
	+
	+ lemma chine_hcomp_arr_ide:
	+ assumes "arr \<mu>" and "ide f" and "src \<mu> = trg f"
	+ shows "chine_hcomp \<mu> f =
	+ \<langle>Chn \<mu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<mu>), Leg1 (Dom f)]
	+ \<lbrakk>Leg0 (Cod \<mu>), Leg1 (Cod f)\<rbrakk>
	+ \<p>\<^sub>0[Leg0 (Dom \<mu>), Leg1 (Dom f)]\<rangle>"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ interpret f: arrow_of_spans C f
	+ using assms ide_char by auto
	+ have 1: "C.cospan \<mu>.dom.leg0 f.dom.leg1"
	+ using assms src_def trg_def by auto
	+ have "chine_hcomp \<mu> f = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, f.dom.leg1]
	+ \<lbrakk>\<mu>.cod.leg0, f.cod.leg1\<rbrakk>
	+ f.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, f.dom.leg1]\<rangle>"
	+ unfolding chine_hcomp_def
	+ using assms ide_char by simp
	+ moreover have "f.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, f.dom.leg1] = \<p>\<^sub>0[\<mu>.dom.leg0, f.dom.leg1]"
	+ using assms 1 C.comp_ide_arr ide_char by auto
	+ ultimately show ?thesis by argo
	+ qed
	+
	+ lemma chine_hcomp_ide_ide:
	+ assumes "ide g" and "ide f" and "src g = trg f"
	+ shows "chine_hcomp g f = Leg0 (Dom g) \<down>\<down> Leg1 (Dom f)"
	+ proof -
	+ interpret g: identity_arrow_of_spans C g
	+ using assms ide_char' by auto
	+ interpret f: identity_arrow_of_spans C f
	+ using assms ide_char' by auto
	+ have 1: "C.cospan g.dom.leg0 f.dom.leg1"
	+ using assms src_def trg_def by auto
	+ have "chine_hcomp g f = \<langle>g.chine \<cdot> \<p>\<^sub>1[g.dom.leg0, f.dom.leg1]
	+ \<lbrakk>g.cod.leg0, f.cod.leg1\<rbrakk>
	+ \<p>\<^sub>0[g.dom.leg0, f.dom.leg1]\<rangle>"
	+ using assms chine_hcomp_arr_ide by simp
	+ moreover have "g.chine \<cdot> \<p>\<^sub>1[g.dom.leg0, f.dom.leg1] = \<p>\<^sub>1[g.dom.leg0, f.dom.leg1]"
	+ using assms 1 C.comp_ide_arr ide_char by auto
	+ ultimately have "chine_hcomp g f = \<langle>\<p>\<^sub>1[g.dom.leg0, f.dom.leg1]
	+ \<lbrakk>g.cod.leg0, f.cod.leg1\<rbrakk>
	+ \<p>\<^sub>0[g.dom.leg0, f.dom.leg1]\<rangle>"
	+ by simp
	+ also have "... =
	+ \<langle>\<p>\<^sub>1[g.dom.leg0, f.dom.leg1] \<cdot> (g.dom.leg0 \<down>\<down> f.dom.leg1)
	+ \<lbrakk>g.cod.leg0, f.cod.leg1\<rbrakk>
	+ \<p>\<^sub>0[g.dom.leg0, f.dom.leg1] \<cdot> (g.dom.leg0 \<down>\<down> f.dom.leg1)\<rangle>"
	+ using assms 1 C.comp_arr_dom by simp
	+ also have "... = g.dom.leg0 \<down>\<down> f.dom.leg1"
	+ using 1 C.pullback_commutes C.tuple_prj by simp
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma chine_hcomp_trg_arr:
	+ assumes "arr \<mu>"
	+ shows "chine_hcomp (trg \<mu>) \<mu> =
	+ \<langle>\<p>\<^sub>1[C.cod (Leg1 (Dom \<mu>)), Leg1 (Dom \<mu>)]
	+ \<lbrakk>C.cod (Leg1 (Dom \<mu>)), Leg1 (Cod \<mu>)\<rbrakk>
	+ Chn \<mu> \<cdot> \<p>\<^sub>0[C.cod (Leg1 (Dom \<mu>)), Leg1 (Dom \<mu>)]\<rangle>"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ interpret trg_\<mu>: arrow_of_spans C \<open>trg \<mu>\<close>
	+ using assms ide_trg ide_char by simp
	+ have "trg_\<mu>.dom.leg0 = C.cod \<mu>.dom.leg1 \<and> trg_\<mu>.cod.leg0 = C.cod \<mu>.dom.leg1 \<and>
	+ trg_\<mu>.dom.leg0 = C.cod \<mu>.dom.leg1"
	+ using assms ide_char src_def trg_def by simp
	+ thus ?thesis
	+ using assms chine_hcomp_ide_arr [of "trg \<mu>" \<mu>] by auto
	+ qed
	+
	+ lemma chine_hcomp_trg_ide:
	+ assumes "ide f"
	+ shows "chine_hcomp (trg f) f = C.cod (Leg1 (Dom f)) \<down>\<down> Leg1 (Dom f)"
	+ proof -
	+ interpret f: arrow_of_spans C f
	+ using assms arr_char by auto
	+ interpret trg_f: arrow_of_spans C \<open>trg f\<close>
	+ using assms ide_trg ide_char by simp
	+ have "trg_f.dom.leg0 = C.cod f.dom.leg1"
	+ using assms trg_def by simp
	+ thus ?thesis
	+ using assms chine_hcomp_ide_ide [of "trg f" f] by auto
	+ qed
	+
	+ lemma chine_hcomp_arr_src:
	+ assumes "arr \<mu>"
	+ shows "chine_hcomp \<mu> (src \<mu>) =
	+ \<langle>Chn \<mu> \<cdot> \<p>\<^sub>1[Leg0 (Dom \<mu>), C.cod (Leg0 (Dom \<mu>))]
	+ \<lbrakk>Leg0 (Cod \<mu>), C.cod (Leg0 (Dom \<mu>))\<rbrakk>
	+ \<p>\<^sub>0[Leg0 (Dom \<mu>), C.cod (Leg0 (Dom \<mu>))]\<rangle>"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ interpret src_\<mu>: arrow_of_spans C \<open>src \<mu>\<close>
	+ using assms ide_src ide_char by simp
	+ have "src_\<mu>.dom.leg1 = \<mu>.dsrc \<and> src_\<mu>.cod.leg1 = \<mu>.dsrc"
	+ using assms ide_char src_def trg_def by simp
	+ thus ?thesis
	+ using assms chine_hcomp_arr_ide by auto
	+ qed
	+
	+ lemma chine_hcomp_ide_src:
	+ assumes "ide f"
	+ shows "chine_hcomp f (src f) = Leg0 (Dom f) \<down>\<down> C.cod (Leg0 (Dom f))"
	+ proof -
	+ interpret f: arrow_of_spans C f
	+ using assms arr_char by auto
	+ interpret src_f: arrow_of_spans C \<open>src f\<close>
	+ using assms ide_src ide_char by simp
	+ have "C.cod f.dom.leg0 = src_f.dom.leg1"
	+ using assms src_def by simp
	+ thus ?thesis
	+ using assms chine_hcomp_ide_ide by auto
	+ qed
	+
	+ lemma src_hcomp [simp]:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
	+ shows "src (\<nu> \<star> \<mu>) = src \<mu>"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ using assms arr_char by auto
	+ have "C.cod (\<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]) = C.cod \<mu>.dom.leg0"
	+ using assms C.commutative_squareE chine_hcomp_props(2)
	+ by (metis (mono_tags, lifting) C.cod_comp C.match_3 \<mu>.leg0_commutes \<mu>.dom.is_span)
	+ thus ?thesis
	+ using assms arr_char hcomp_def src_def C.comp_cod_arr C.comp_arr_dom arrow_of_spans_hcomp
	+ by simp
	+ qed
	+
	+ lemma trg_hcomp [simp]:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
	+ shows "trg (\<nu> \<star> \<mu>) = trg \<nu>"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ using assms arr_char by auto
	+ have "C.cod (\<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]) = \<nu>.dtrg"
	+ using assms C.commutative_squareE chine_hcomp_props(2)
	+ by (metis (mono_tags, lifting) C.cod_comp C.match_3 \<nu>.leg1_commutes \<nu>.dom.is_span)
	+ thus ?thesis
	+ using assms arr_char hcomp_def trg_def C.comp_cod_arr C.comp_arr_dom arrow_of_spans_hcomp
	+ by simp
	+ qed
	+
	+ lemma dom_hcomp [simp]:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
	+ shows "dom (\<nu> \<star> \<mu>) = dom \<nu> \<star> dom \<mu>"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ using assms arr_char by auto
	+ interpret \<nu>\<mu>: arrow_of_spans C \<open>hcomp \<nu> \<mu>\<close>
	+ using assms arr_char arrow_of_spans_hcomp by simp
	+ have 1: "C.cospan \<mu>.dom.leg1 \<nu>.dom.leg0"
	+ using assms \<mu>.dom.is_span \<nu>.dom.is_span src_def trg_def by auto
	+ have "dom (\<nu> \<star> \<mu>) =
	+ \<lparr>Chn = \<nu>.dom.leg0 \<down>\<down> \<mu>.dom.leg1,
	+ Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
	+ Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
	+ Cod = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
	+ Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>\<rparr>"
	+ using assms \<nu>\<mu>.arrow_of_spans_axioms \<nu>\<mu>.dom.leg_simps(2) \<nu>\<mu>.dom.is_span
	+ arr_char dom_char hcomp_def
	+ by auto
	+ also have "... =
	+ \<lparr>Chn = chine_hcomp (dom \<nu>) (dom \<mu>),
	+ Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
	+ Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
	+ Cod = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
	+ Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>\<rparr>"
	+ using assms src_dom trg_dom ide_dom dom_char chine_hcomp_ide_ide by auto
	+ also have "... = dom \<nu> \<star> dom \<mu>"
	+ using assms src_dom trg_dom arr_dom dom_char hcomp_def by auto
	+ finally show ?thesis by blast
	+ qed
	+
	+ lemma cod_hcomp [simp]:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
	+ shows "cod (\<nu> \<star> \<mu>) = cod \<nu> \<star> cod \<mu>"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using assms arr_char by auto
	+ interpret \<nu>: arrow_of_spans C \<nu>
	+ using assms arr_char by auto
	+ interpret \<nu>\<mu>: arrow_of_spans C \<open>hcomp \<nu> \<mu>\<close>
	+ using assms arr_char arrow_of_spans_hcomp by simp
	+ have 1: "C.cospan \<mu>.cod.leg1 \<nu>.cod.leg0"
	+ using assms \<mu>.cod.is_span \<nu>.cod.is_span src_def trg_def by simp
	+ have 2: "cod (\<nu> \<star> \<mu>) =
	+ \<lparr>Chn = \<nu>.cod.leg0 \<down>\<down> \<mu>.cod.leg1,
	+ Dom = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
	+ Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>,
	+ Cod = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
	+ Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>\<rparr>"
	+ using assms \<nu>\<mu>.arrow_of_spans_axioms \<nu>\<mu>.cod.leg_simps(2) \<nu>\<mu>.cod.is_span
	+ arr_char cod_char hcomp_def
	+ by auto
	+ also have "... =
	+ \<lparr>Chn = chine_hcomp (cod \<nu>) (cod \<mu>),
	+ Dom = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
	+ Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>,
	+ Cod = \<lparr>Leg0 = \<mu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1],
	+ Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]\<rparr>\<rparr>"
	+ using assms src_cod trg_cod ide_cod cod_char chine_hcomp_ide_ide by auto
	+ also have "... = cod \<nu> \<star> cod \<mu>"
	+ using assms src_cod trg_cod arr_cod cod_char hcomp_def by auto
	+ finally show ?thesis by simp
	+ qed
	+
	+ lemma hcomp_vcomp:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<nu> = trg \<mu>"
	+ and "arr \<mu>'" and "arr \<nu>'" and "src \<nu>' = trg \<mu>'"
	+ and "seq \<mu>' \<mu>" and "seq \<nu>' \<nu>"
	+ shows "(\<nu>' \<bullet> \<nu>) \<star> (\<mu>' \<bullet> \<mu>) = (\<nu>' \<star> \<mu>') \<bullet> (\<nu> \<star> \<mu>)"
	+ proof -
	+ interpret \<mu>: arrow_of_spans C \<mu> using assms arr_char by auto
	+ interpret \<nu>: arrow_of_spans C \<nu> using assms arr_char by auto
	+ interpret \<mu>': arrow_of_spans C \<mu>' using assms arr_char by auto
	+ interpret \<nu>': arrow_of_spans C \<nu>' using assms arr_char by auto
	+ interpret \<nu>\<mu>: arrow_of_spans C \<open>hcomp \<nu> \<mu>\<close>
	+ using assms arr_char arrow_of_spans_hcomp by auto
	+ interpret \<nu>'\<mu>': arrow_of_spans C \<open>hcomp \<nu>' \<mu>'\<close>
	+ using assms arr_char arrow_of_spans_hcomp by auto
	+
	+ have 1: "Dom \<nu>' = Cod \<nu> \<and> Dom \<mu>' = Cod \<mu>"
	+ using assms src_def trg_def seq_char by blast
	+ have 2: "Dom (\<mu>' \<bullet> \<mu>) = Dom \<mu> \<and> Dom (\<nu>' \<bullet> \<nu>) = Dom \<nu> \<and>
	+ Cod (\<mu>' \<bullet> \<mu>) = Cod \<mu>' \<and> Cod (\<nu>' \<bullet> \<nu>) = Cod \<nu>'"
	+ using assms seq_char arr_char vcomp_def
	+ by (metis arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
	+ have 3: "chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
	+ \<langle>Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]
	+ \<lbrakk>\<nu>'.cod.leg0, \<mu>'.cod.leg1\<rbrakk>
	+ Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rangle>"
	+ unfolding chine_hcomp_def using 2 by simp
	+
	+ have C1: "C.commutative_square \<nu>'.cod.leg0 \<mu>'.cod.leg1
	+ (Chn \<nu>' \<cdot> \<p>\<^sub>1[\<nu>'.dom.leg0, \<mu>'.dom.leg1])
	+ (Chn \<mu>' \<cdot> \<p>\<^sub>0[\<nu>'.dom.leg0, \<mu>'.dom.leg1])"
	+ using assms 1 vcomp_def seq_char arr_char chine_hcomp_props(2) by blast
	+ have C2: "C.commutative_square \<nu>'.cod.leg0 \<mu>'.cod.leg1
	+ (Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])
	+ (Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
	+ (* using assms 1 2 vcomp_def seq_char arr_char chine_hcomp_props(1-2) src_vcomp trg_vcomp
	+ by smt *)
	+ proof
	+ show 3: "C.cospan \<nu>'.cod.leg0 \<mu>'.cod.leg1"
	+ using assms 1 2 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
	+ src_vcomp trg_vcomp
	+ by (meson C.commutative_squareE)
	+ show 4: "C.span (Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])
	+ (Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
	+ using assms 1 2 3 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
	+ src_vcomp trg_vcomp
	+ by simp
	+ show "C.dom \<nu>'.cod.leg0 = C.cod (Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])"
	+ using assms 1 2 4 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
	+ src_vcomp trg_vcomp
	+ by simp
	+ show "\<nu>'.cod.leg0 \<cdot> Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1] =
	+ \<mu>'.cod.leg1 \<cdot> Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using assms 1 2 vcomp_def seq_char arr_char chine_hcomp_props(1-2)
	+ src_vcomp trg_vcomp
	+ by (metis (mono_tags, lifting) C.comp_assoc C.pullback_commutes' Chn_vcomp
	+ \<mu>'.cod_trg_eq_dom_trg \<mu>'.leg1_commutes \<mu>.cod_trg_eq_dom_trg \<mu>.dom.leg_simps(3)
	+ \<mu>.leg1_commutes \<nu>'.cod_src_eq_dom_src \<nu>'.leg0_commutes \<nu>.cod_src_eq_dom_src
	+ \<nu>.dom.leg_simps(1) \<nu>.leg0_commutes \<open>C.cospan \<nu>'.cod.leg0 \<mu>'.cod.leg1\<close>)
	+ qed
	+ have "(\<nu>' \<bullet> \<nu>) \<star> (\<mu>' \<bullet> \<mu>) =
	+ \<lparr>Chn = chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>),
	+ Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
	+ Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
	+ Cod = \<lparr>Leg0 = \<mu>'.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1],
	+ Leg1 = \<nu>'.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1]\<rparr>\<rparr>"
	+ proof -
	+ have "\<nu>' \<bullet> \<nu> \<star> \<mu>' \<bullet> \<mu> =
	+ \<lparr>Chn = chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>),
	+ Dom =
	+ \<lparr>Leg0 = Leg0 (Dom (\<mu>' \<bullet> \<mu>)) \<cdot> \<p>\<^sub>0[Leg0 (Dom (\<nu>' \<bullet> \<nu>)), Leg1 (Dom (\<mu>' \<bullet> \<mu>))],
	+ Leg1 = Leg1 (Dom (\<nu>' \<bullet> \<nu>)) \<cdot> \<p>\<^sub>1[Leg0 (Dom (\<nu>' \<bullet> \<nu>)), Leg1 (Dom (\<mu>' \<bullet> \<mu>))]\<rparr>,
	+ Cod = \<lparr>Leg0 = Leg0 (Cod (\<mu>' \<bullet> \<mu>)) \<cdot> \<p>\<^sub>0[Leg0 (Cod (\<nu>' \<bullet> \<nu>)), Leg1 (Cod (\<mu>' \<bullet> \<mu>))],
	+ Leg1 = Leg1 (Cod (\<nu>' \<bullet> \<nu>)) \<cdot> \<p>\<^sub>1[Leg0 (Cod (\<nu>' \<bullet> \<nu>)), Leg1 (Cod (\<mu>' \<bullet> \<mu>))]\<rparr>\<rparr>"
	+ by (simp add: assms(3) assms(6-8) hcomp_def)
	+ then show ?thesis
	+ by (metis "2")
	+ qed
	+ moreover
	+ have "(\<nu>' \<star> \<mu>') \<bullet> (\<nu> \<star> \<mu>) =
	+ \<lparr>Chn = chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>,
	+ Dom = \<lparr>Leg0 = \<mu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1],
	+ Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rparr>,
	+ Cod = \<lparr>Leg0 = \<mu>'.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1],
	+ Leg1 = \<nu>'.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1]\<rparr>\<rparr>"
	+ proof -
	+ have "arr (\<nu>' \<star> \<mu>') \<and> arr (\<nu> \<star> \<mu>)"
	+ using assms arrow_of_spans_hcomp arr_char by simp
	+ moreover have "Dom (\<nu>' \<star> \<mu>') = Cod (\<nu> \<star> \<mu>)"
	+ using assms src_def trg_def seq_char hcomp_def src_hcomp trg_hcomp by simp
	+ ultimately show ?thesis
	+ using assms seq_char arr_char vcomp_eq hcomp_def by auto
	+ qed
	+ moreover have "chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) = chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
	+ proof -
	+ have "C.cospan \<nu>'.cod.leg0 \<mu>'.cod.leg1"
	+ using assms src_def trg_def by simp
	+ moreover have "C.seq \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] (chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>))"
	+ using assms 2 C2 chine_hcomp_props [of "\<mu>' \<bullet> \<mu>" "\<nu>' \<bullet> \<nu>"] by auto
	+ moreover have "C.seq \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] (chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>)"
	+ using assms 1 chine_hcomp_props [of \<mu> \<nu>] chine_hcomp_props [of \<mu>' \<nu>'] by auto
	+ moreover have "\<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
	+ \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
	+ proof -
	+ have "\<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
	+ Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using C2 3 by simp
	+ also have "... = (\<mu>'.chine \<cdot> \<mu>.chine) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using assms vcomp_def seq_char arr_char
	+ by (metis arrow_of_spans_data.select_convs(1))
	+ also have "... = \<mu>'.chine \<cdot> \<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using C.comp_assoc by simp
	+ also have "... = (\<mu>'.chine \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu>"
	+ using assms 1
	+ C.prj_tuple(1)
	+ [of "\<nu>.cod.leg0" "\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ "\<mu>.cod.leg1" "\<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"]
	+ by (metis (mono_tags, lifting) C.commutative_squareE C.comp_assoc chine_hcomp_props(4))
	+ also have "... = (\<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>') \<cdot> chine_hcomp \<nu> \<mu>"
	+ using assms 1
	+ by (metis (mono_tags, lifting) C.commutative_squareE chine_hcomp_props(4))
	+ also have "... = \<p>\<^sub>0[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
	+ using C.comp_assoc by simp
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
	+ \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
	+ proof -
	+ have "\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>) =
	+ \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot>
	+ \<langle>Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]
	+ \<lbrakk>Leg0 (Cod \<nu>'), Leg1 (Cod \<mu>')\<rbrakk>
	+ Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]\<rangle>"
	+ using 3 by simp
	+ also have "... = Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using C2 C.prj_tuple(2) [of "Leg0 (Cod \<nu>')"
	+ "Chn (\<nu>' \<bullet> \<nu>) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ "Leg1 (Cod \<mu>')"
	+ "Chn (\<mu>' \<bullet> \<mu>) \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1]"]
	+ by simp
	+ also have "... = (\<nu>'.chine \<cdot> \<nu>.chine) \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using assms vcomp_def seq_char arr_char
	+ by (metis (no_types, lifting) arrow_of_spans_data.select_convs(1))
	+ also have "... = \<nu>'.chine \<cdot> \<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1]"
	+ using C.comp_assoc by simp
	+ also have "... = (\<nu>'.chine \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<mu>.cod.leg1]) \<cdot> chine_hcomp \<nu> \<mu>"
	+ proof -
	+ have "C.commutative_square \<nu>.cod.leg0 \<mu>.cod.leg1
	+ (\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<mu>.dom.leg1])
	+ (\<mu>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<mu>.dom.leg1])"
	+ using assms 1 vcomp_def seq_char arr_char chine_hcomp_props(2) by auto
	+ thus ?thesis
	+ using assms 1 \<nu>'.leg0_commutes C.prj_tuple(2) apply (simp add: C.comp_assoc)
	+ by (metis (mono_tags, lifting) C.commutative_squareE chine_hcomp_props(3))
	+ qed
	+ also have "... = (\<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>') \<cdot> chine_hcomp \<nu> \<mu>"
	+ unfolding chine_hcomp_def using C1 1 C.prj_tuple(2) by simp
	+ also have "... = \<p>\<^sub>1[\<nu>'.cod.leg0, \<mu>'.cod.leg1] \<cdot> chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"
	+ using C.comp_assoc by simp
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis
	+ using C.prj_joint_monic
	+ [of "\<nu>'.cod.leg0" "\<mu>'.cod.leg1"
	+ "chine_hcomp (\<nu>' \<bullet> \<nu>) (\<mu>' \<bullet> \<mu>)" "chine_hcomp \<nu>' \<mu>' \<cdot> chine_hcomp \<nu> \<mu>"]
	+ by simp
	+ qed
	+ ultimately show ?thesis by auto
	+ qed
	+
	+ interpretation VxV: product_category vcomp vcomp ..
	+ interpretation VV: subcategory VxV.comp
	+ \<open>\<lambda>\<nu>\<mu>. arr (fst \<nu>\<mu>) \<and> arr (snd \<nu>\<mu>) \<and> src (fst \<nu>\<mu>) = trg (snd \<nu>\<mu>)\<close>
	+ by (unfold_locales, simp_all)
	+
	+ interpretation H: "functor" VV.comp vcomp \<open>\<lambda>\<nu>\<mu>. fst \<nu>\<mu> \<star> snd \<nu>\<mu>\<close>
	+ proof
	+ show "\<And>\<nu>\<mu>. \<not> VV.arr \<nu>\<mu> \<Longrightarrow> fst \<nu>\<mu> \<star> snd \<nu>\<mu> = null"
	+ using hcomp_def VV.arr_char null_char by auto
	+ show "\<And>\<nu>\<mu>. VV.arr \<nu>\<mu> \<Longrightarrow> arr (fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
	+ using arr_char arrow_of_spans_hcomp VV.arr_char by simp
	+ show "\<And>\<nu>\<mu>. VV.arr \<nu>\<mu> \<Longrightarrow>
	+ dom (fst \<nu>\<mu> \<star> snd \<nu>\<mu>) = fst (VV.dom \<nu>\<mu>) \<star> snd (VV.dom \<nu>\<mu>)"
	+ using VV.arr_char VV.dom_char dom_hcomp by auto
	+ show "\<And>\<nu>\<mu>. VV.arr \<nu>\<mu> \<Longrightarrow> cod (fst \<nu>\<mu> \<star> snd \<nu>\<mu>) = fst (VV.cod \<nu>\<mu>) \<star> snd (VV.cod \<nu>\<mu>)"
	+ using VV.arr_char VV.cod_char cod_hcomp by auto
	+ show "\<And>\<nu>\<mu>' \<nu>\<mu>. VV.seq \<nu>\<mu>' \<nu>\<mu> \<Longrightarrow> fst (VV.comp \<nu>\<mu>' \<nu>\<mu>) \<star> snd (VV.comp \<nu>\<mu>' \<nu>\<mu>) =
	+ (fst \<nu>\<mu>' \<star> snd \<nu>\<mu>') \<bullet> (fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
	+ proof -
	+ fix \<nu>\<mu>' \<nu>\<mu>
	+ assume 1: "VV.seq \<nu>\<mu>' \<nu>\<mu>"
	+ have "VV.comp \<nu>\<mu>' \<nu>\<mu> = (fst \<nu>\<mu>' \<bullet> fst \<nu>\<mu>, snd \<nu>\<mu>' \<bullet> snd \<nu>\<mu>)"
	+ using 1 VV.comp_char VV.seq_char VxV.comp_char by auto
	+ thus "fst (VV.comp \<nu>\<mu>' \<nu>\<mu>) \<star> snd (VV.comp \<nu>\<mu>' \<nu>\<mu>) =
	+ (fst \<nu>\<mu>' \<star> snd \<nu>\<mu>') \<bullet> (fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
	+ using 1 hcomp_vcomp VV.seq_char VV.arr_char VV.comp_char
	+ by (metis (no_types, lifting) fst_conv snd_conv)
	+ qed
	+ qed
	+
	+ lemma hcomp_is_functor:
	+ shows "functor VV.comp vcomp (\<lambda>\<nu>\<mu>. fst \<nu>\<mu> \<star> snd \<nu>\<mu>)"
	+ ..
	+
	+ lemma ide_hcomp:
	+ assumes "ide f" and "ide g" and "src f = trg g"
	+ shows "ide (f \<star> g)"
	+ using assms VV.ide_char VV.arr_char H.preserves_ide [of "(f, g)"] by auto
	+
	+ sublocale horizontal_composition vcomp hcomp src trg
	+ using src_hcomp trg_hcomp VV.arr_char not_arr_null hcomp_def null_char
	+ by (unfold_locales, auto)
	+
	+ lemma has_horizontal_composition:
	+ shows "horizontal_composition vcomp hcomp src trg"
	+ ..
	+
	+ end
	+
	+ subsection "The Bicategory Span(C)"
	+
	+ context span_bicategory
	+ begin
	+
	+ interpretation VxVxV: product_category vcomp VxV.comp ..
	+ interpretation VVV: subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using subcategory_VVV by auto
	+
	+ interpretation HoHV: "functor" VVV.comp vcomp HoHV
	+ using functor_HoHV by blast
	+ interpretation HoVH: "functor" VVV.comp vcomp HoVH
	+ using functor_HoVH by blast
	+
	+ lemma arr_eqI:
	+ assumes "par \<mu> \<mu>'" and "Chn \<mu> = Chn \<mu>'"
	+ shows "\<mu> = \<mu>'"
	+ using assms dom_char cod_char by auto
	+
	+ interpretation L: endofunctor vcomp L
	+ using endofunctor_L by auto
	+
	+ abbreviation \<l>
	+ where "\<l> f \<equiv> \<lparr>Chn = \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
	+ Dom = Dom (L f), Cod = Cod f\<rparr>"
	+
	+ interpretation \<ll>: transformation_by_components vcomp vcomp L map \<l>
	+ proof
	+ have *: "\<And>f. ide f \<Longrightarrow> arrow_of_spans C (\<l> f)"
	+ proof -
	+ fix f
	+ assume f: "ide f"
	+ interpret f: identity_arrow_of_spans C f
	+ using f ide_char' by auto
	+ interpret \<l>f: arrow_of_spans C \<open>\<l> f\<close>
	+ proof
	+ show Dom: "C.span (Leg0 (Dom (\<l> f))) (Leg1 (Dom (\<l> f)))"
	+ using f
	+ by (simp add: arrow_of_spans_hcomp arrow_of_spans.axioms(2)
	+ span_in_category.is_span)
	+ interpret Dom: span_in_category C \<open>Dom (\<l> f)\<close>
	+ using Dom by (unfold_locales, auto)
	+ show Cod: "C.span (Leg0 (Cod (\<l> f))) (Leg1 (Cod (\<l> f)))"
	+ using f hcomp_def trg_def src_def ide_mkObj C.pullback_commutes by force
	+ interpret Cod: span_in_category C \<open>Cod (\<l> f)\<close>
	+ using Cod by (unfold_locales, auto)
	+ show "\<guillemotleft>Chn (\<l> f) : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
	+ proof -
	+ have "C.dom Dom.leg0 = C.cod f.dom.leg1 \<down>\<down> f.dom.leg1"
	+ proof -
	+ have "arr (trg f)"
	+ using f by simp
	+ hence "Dom (\<l> f) = \<lparr>Leg0 = f.dom.leg0 \<cdot> \<p>\<^sub>0[C.cod f.dom.leg1, f.dom.leg1],
	+ Leg1 = C.cod f.dom.leg1 \<cdot> \<p>\<^sub>1[C.cod f.dom.leg1, f.dom.leg1]\<rparr>"
	+ using f src_def trg_def hcomp_def by simp
	+ thus ?thesis
	+ using f Dom hcomp_def by auto
	+ qed
	+ thus ?thesis
	+ using f ide_char Dom.apex_def Cod.apex_def by simp
	+ qed
	+ show "Cod.leg0 \<cdot> Chn (\<l> f) = Dom.leg0"
	+ using f ide_char hcomp_def src_def trg_def C.comp_arr_ide ide_mkObj by simp
	+ show "Cod.leg1 \<cdot> Chn (\<l> f) = Dom.leg1"
	+ using f ide_char hcomp_def src_def trg_def C.pullback_commutes ide_mkObj
	+ C.comp_arr_ide
	+ by (simp add: C.commutative_square_def)
	+ qed
	+ show "arrow_of_spans C (\<l> f)" ..
	+ qed
	+ show 0: "\<And>f. ide f \<Longrightarrow> \<guillemotleft>\<l> f : L f \<rightarrow> map f\<guillemotright>"
	+ proof -
	+ fix f
	+ assume f: "ide f"
	+ interpret f: identity_arrow_of_spans C f
	+ using f ide_char' by auto
	+ interpret \<l>f: arrow_of_spans C \<open>\<l> f\<close>
	+ using f * by blast
	+ show "in_hom (\<l> f) (L f) (map f)"
	+ proof
	+ show 1: "arr (\<l> f)"
	+ using f * arr_char by blast
	+ show "dom (\<l> f) = L f"
	+ using f 1 dom_char ideD(2) by auto
	+ show "cod (\<l> f) = map f"
	+ using f 1 cod_char ideD(3) by auto
	+ qed
	+ qed
	+ show "\<And>\<mu>. arr \<mu> \<Longrightarrow> \<l> (cod \<mu>) \<bullet> L \<mu> = map \<mu> \<bullet> \<l> (dom \<mu>)"
	+ proof -
	+ fix \<mu>
	+ assume \<mu>: "arr \<mu>"
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using \<mu> arr_char by auto
	+ interpret \<l>_dom_\<mu>: arrow_of_spans C \<open>\<l> (dom \<mu>)\<close>
	+ using \<mu> * [of "dom \<mu>"] by fastforce
	+ interpret \<l>_cod_\<mu>: arrow_of_spans C \<open>\<l> (cod \<mu>)\<close>
	+ using \<mu> * [of "cod \<mu>"] by fastforce
	+ interpret L\<mu>: arrow_of_spans C \<open>L \<mu>\<close>
	+ using \<mu> arr_char by blast
	+ show "\<l> (cod \<mu>) \<bullet> L \<mu> = map \<mu> \<bullet> \<l> (dom \<mu>)"
	+ proof (intro arr_eqI)
	+ show par: "par (\<l> (cod \<mu>) \<bullet> L \<mu>) (map \<mu> \<bullet> \<l> (dom \<mu>))"
	+ using \<mu> 0 [of "dom \<mu>"] 0 [of "cod \<mu>"] hseqI' by fastforce
	+ show "Chn (\<l> (cod \<mu>) \<bullet> L \<mu>) = Chn (map \<mu> \<bullet> \<l> (dom \<mu>))"
	+ proof -
	+ have "Chn (\<l> (cod \<mu>) \<bullet> L \<mu>) =
	+ \<p>\<^sub>0[\<mu>.dtrg, \<mu>.cod.leg1] \<cdot>
	+ \<langle>\<p>\<^sub>1[\<mu>.dtrg, \<mu>.dom.leg1] \<lbrakk>\<mu>.dtrg, \<mu>.cod.leg1\<rbrakk> \<mu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dtrg, \<mu>.dom.leg1]\<rangle>"
	+ proof -
	+ have "Chn (\<l> (cod \<mu>) \<bullet> L \<mu>) = \<p>\<^sub>0[\<mu>.dtrg, \<mu>.cod.leg1] \<cdot> Chn (trg \<mu> \<star> \<mu>)"
	+ proof -
	+ have "Dom (trg \<mu> \<star> cod \<mu>) = Cod (trg \<mu> \<star> \<mu>)"
	+ using \<mu> seq_char by fastforce
	+ moreover have "\<p>\<^sub>0[C.cod (Leg1 (Dom (cod \<mu>))), Leg1 (Dom (cod \<mu>))] \<cdot>
	+ Chn (trg \<mu> \<star> \<mu>) =
	+ \<p>\<^sub>0[\<mu>.dtrg, \<mu>.cod.leg1] \<cdot> Chn (trg \<mu> \<star> \<mu>)"
	+ by (simp add: \<mu> cod_char)
	+ moreover have "arrow_of_spans (\<cdot>)
	+ \<lparr>Chn = \<p>\<^sub>0[C.cod (Leg1 (Dom (cod \<mu>))), Leg1 (Dom (cod \<mu>))],
	+ Dom = Cod (trg \<mu> \<star> \<mu>), Cod = Cod (cod \<mu>)\<rparr>"
	+ using \<mu> par seq_char by auto
	+ ultimately show ?thesis
	+ using \<mu> vcomp_def L\<mu>.arrow_of_spans_axioms by auto
	+ qed
	+ moreover
	+ have "Chn (trg \<mu> \<star> \<mu>) = \<langle>\<p>\<^sub>1[\<mu>.dtrg, \<mu>.dom.leg1]
	+ \<lbrakk>\<mu>.dtrg, \<mu>.cod.leg1\<rbrakk>
	+ \<mu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dtrg, \<mu>.dom.leg1]\<rangle>"
	+ using \<mu> hcomp_def chine_hcomp_trg_arr by simp
	+ ultimately show ?thesis
	+ using \<mu> by (auto simp add: cod_char)
	+ qed
	+ also have "... = \<mu>.chine \<cdot> \<p>\<^sub>0[C.cod \<mu>.dom.leg1, \<mu>.dom.leg1]"
	+ using \<mu> C.in_homE C.pullback_commutes [of "C.cod \<mu>.dom.leg1" "\<mu>.dom.leg1"]
	+ C.comp_reduce ide_char C.prj_tuple(1)
	+ by auto
	+ also have "... = Chn (map \<mu> \<bullet> \<l> (dom \<mu>))"
	+ using \<mu> par seq_char dom_char vcomp_eq map_simp by simp
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+ qed
	+
	+ interpretation \<ll>: natural_isomorphism vcomp vcomp L map \<ll>.map
	+ proof
	+ fix f
	+ assume f: "ide f"
	+ show "iso (\<ll>.map f)"
	+ proof -
	+ interpret f: identity_arrow_of_spans C f
	+ using f ide_char' by auto
	+ have 1: "\<ll>.map f = \<lparr>Chn = \<p>\<^sub>0[f.dtrg, f.leg1], Dom = Dom (trg f \<star> f), Cod = Dom f\<rparr>"
	+ using f ide_char cod_char by simp
	+ interpret \<l>f: arrow_of_spans C \<open>\<ll>.map f\<close>
	+ using f arr_char \<ll>.preserves_reflects_arr by fastforce
	+ let ?\<l>f' = "\<lparr>Chn = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> C.dom f.leg1\<rangle>,
	+ Dom = Dom f, Cod = Dom (trg f \<star> f)\<rparr>"
	+ have 2: "C.inverse_arrows \<l>f.chine (Chn ?\<l>f')"
	+ using 1 C.pullback_arr_cod(2) [of "f.leg1"] by simp
	+ interpret \<l>f': arrow_of_spans C ?\<l>f'
	+ proof
	+ show Dom: "C.span (Leg0 (Dom ?\<l>f')) (Leg1 (Dom ?\<l>f'))"
	+ using f 1 by auto
	+ interpret Dom: span_in_category C \<open>Dom ?\<l>f'\<close>
	+ using Dom by (unfold_locales, auto)
	+ show Cod: "C.span (Leg0 (Cod ?\<l>f')) (Leg1 (Cod ?\<l>f'))"
	+ using f 1 \<l>f.dom.is_span by auto
	+ interpret Cod: span_in_category C \<open>Cod ?\<l>f'\<close>
	+ using Cod by (unfold_locales, auto)
	+ show "\<guillemotleft>Chn ?\<l>f' : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
	+ using f src_def trg_def hcomp_def ide_mkObj Cod.apex_def Dom.apex_def
	+ C.comp_arr_dom C.comp_cod_arr
	+ by auto
	+ show "Cod.leg0 \<cdot> Chn ?\<l>f' = Dom.leg0"
	+ using 2 \<l>f.leg0_commutes C.invert_side_of_triangle
	+ by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<l>f.dom.is_span
	+ arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
	+ show "Cod.leg1 \<cdot> Chn ?\<l>f' = Dom.leg1"
	+ using 2 \<l>f.leg1_commutes C.invert_side_of_triangle
	+ by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<l>f.dom.is_span
	+ arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
	+ qed
	+ have "inverse_arrows (\<ll>.map f) ?\<l>f'"
	+ proof
	+ show "ide (?\<l>f' \<bullet> \<ll>.map f)"
	+ proof -
	+ have "?\<l>f' \<bullet> \<ll>.map f = dom (\<ll>.map f)"
	+ proof -
	+ have "?\<l>f' \<bullet> \<ll>.map f =
	+ \<lparr>Chn = f.dtrg \<down>\<down> f.leg1, Dom = Dom (\<ll>.map f), Cod = Dom (\<ll>.map f)\<rparr>"
	+ using f 1 2 f.arrow_of_spans_axioms \<l>f.arrow_of_spans_axioms
	+ \<l>f'.arrow_of_spans_axioms vcomp_def ide_char arr_char
	+ by (simp add: vcomp_def C.comp_inv_arr)
	+ also have "... = dom (\<ll>.map f)"
	+ proof -
	+ have "C.cod f.dom.leg1 \<down>\<down> f.dom.leg1 = C.dom (Leg1 (Dom (hcomp (trg f) f)))"
	+ using f f.arrow_of_spans_axioms hcomp_def src_def trg_def ide_mkObj
	+ by auto
	+ thus ?thesis
	+ using 1 f.arrow_of_spans_axioms arr_char dom_char \<l>f.dom.is_span
	+ \<l>f.arrow_of_spans_axioms \<l>f'.cod.apex_def
	+ by auto
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using \<l>f.arrow_of_spans_axioms arr_char by simp
	+ qed
	+ show "ide (\<ll>.map f \<bullet> ?\<l>f')"
	+ proof -
	+ have "\<ll>.map f \<bullet> ?\<l>f' = dom ?\<l>f'"
	+ proof -
	+ have "\<ll>.map f \<bullet> ?\<l>f' = \<lparr>Chn = Chn f, Dom = Dom ?\<l>f', Cod = Dom ?\<l>f'\<rparr>"
	+ using f 1 2 f.arrow_of_spans_axioms \<l>f.arrow_of_spans_axioms
	+ \<l>f'.arrow_of_spans_axioms vcomp_def ide_char arr_char
	+ by fastforce
	+ also have "... = dom ?\<l>f'"
	+ using 1 \<l>f'.arrow_of_spans_axioms arr_char dom_char by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using \<l>f'.arrow_of_spans_axioms arr_char by simp
	+ qed
	+ qed
	+ thus ?thesis by auto
	+ qed
	+ qed
	+
	+ lemma \<ll>_is_natural_isomorphism:
	+ shows "natural_isomorphism vcomp vcomp L map \<ll>.map"
	+ ..
	+
	+ interpretation equivalence_functor vcomp vcomp L
	+ using L.isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
	+
	+ lemma equivalence_functor_L:
	+ shows "equivalence_functor vcomp vcomp L"
	+ ..
	+
	+ interpretation R: endofunctor vcomp R
	+ using endofunctor_R by auto
	+
	+ abbreviation \<r>
	+ where "\<r> f \<equiv> \<lparr>Chn = \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
	+ Dom = Dom (R f), Cod = Cod f\<rparr>"
	+
	+ interpretation \<rho>: transformation_by_components vcomp vcomp R map \<r>
	+ proof
	+ have *: "\<And>f. ide f \<Longrightarrow> arrow_of_spans C (\<r> f)"
	+ proof -
	+ fix f
	+ assume f: "ide f"
	+ interpret f: identity_arrow_of_spans C f
	+ using f ide_char' by auto
	+ interpret \<r>f: arrow_of_spans C \<open>\<r> f\<close>
	+ proof
	+ show Dom: "C.span (Leg0 (Dom (\<r> f))) (Leg1 (Dom (\<r> f)))"
	+ using f
	+ by (simp add: arrow_of_spans_hcomp arrow_of_spans.axioms(2)
	+ span_in_category.is_span)
	+ interpret Dom: span_in_category C \<open>Dom (\<r> f)\<close>
	+ using Dom by (unfold_locales, auto)
	+ show Cod: "C.span (Leg0 (Cod (\<r> f))) (Leg1 (Cod (\<r> f)))"
	+ using f hcomp_def trg_def src_def ide_mkObj C.pullback_commutes by force
	+ interpret Cod: span_in_category C \<open>Cod (\<r> f)\<close>
	+ using Cod by (unfold_locales, auto)
	+ show "\<guillemotleft>Chn (\<r> f) : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
	+ proof -
	+ have "C.dom Dom.leg0 = f.dom.leg0 \<down>\<down> C.cod f.dom.leg0"
	+ proof -
	+ have "arr (src f)"
	+ using f by simp
	+ hence "Dom (\<r> f) = \<lparr>Leg0 = C.cod f.dom.leg0 \<cdot> \<p>\<^sub>0[f.dom.leg0, C.cod f.dom.leg0],
	+ Leg1 = f.dom.leg1 \<cdot> \<p>\<^sub>1[f.dom.leg0, C.cod f.dom.leg0]\<rparr>"
	+ using f src_def trg_def by (simp add: hcomp_def)
	+ thus ?thesis
	+ using f ide_char Dom.apex_def Cod.apex_def by simp
	+ qed
	+ thus ?thesis
	+ using f ide_char Dom.apex_def Cod.apex_def by simp
	+ qed
	+ show "Cod.leg0 \<cdot> Chn (\<r> f) = Dom.leg0"
	+ using f ide_char hcomp_def src_def trg_def C.pullback_commutes
	+ ide_mkObj C.comp_arr_ide
	+ by (simp add: C.commutative_square_def)
	+ show "Cod.leg1 \<cdot> Chn (\<r> f) = Dom.leg1"
	+ using f ide_char hcomp_def src_def trg_def ide_mkObj C.comp_arr_ide
	+ by (simp add: C.commutative_square_def)
	+ qed
	+ show "arrow_of_spans C (\<r> f)" ..
	+ qed
	+ show 0: "\<And>f. ide f \<Longrightarrow> in_hom (\<r> f) (R f) (map f)"
	+ proof -
	+ fix f
	+ assume f: "ide f"
	+ interpret f: identity_arrow_of_spans C f
	+ using f ide_char' by auto
	+ interpret \<r>f: arrow_of_spans C \<open>\<r> f\<close>
	+ using f * by blast
	+ show "in_hom (\<r> f) (R f) (map f)"
	+ proof
	+ show 1: "arr (\<r> f)"
	+ using f * arr_char by blast
	+ show "dom (\<r> f) = R f"
	+ using f 1 dom_char ideD(2) by auto
	+ show "cod (\<r> f) = map f"
	+ using f 1 cod_char ideD(3) by auto
	+ qed
	+ qed
	+ show "\<And>\<mu>. arr \<mu> \<Longrightarrow> \<r> (cod \<mu>) \<bullet> R \<mu> = map \<mu> \<bullet> \<r> (dom \<mu>)"
	+ proof -
	+ fix \<mu>
	+ assume \<mu>: "arr \<mu>"
	+ interpret \<mu>: arrow_of_spans C \<mu>
	+ using \<mu> arr_char by auto
	+ interpret \<r>_dom_\<mu>: arrow_of_spans C \<open>\<r> (dom \<mu>)\<close>
	+ using \<mu> * [of "dom \<mu>"] by fastforce
	+ interpret \<r>_cod_\<mu>: arrow_of_spans C \<open>\<r> (cod \<mu>)\<close>
	+ using \<mu> * [of "cod \<mu>"] by fastforce
	+ interpret R\<mu>: arrow_of_spans C \<open>R \<mu>\<close>
	+ using \<mu> arr_char by blast
	+ show "\<r> (cod \<mu>) \<bullet> R \<mu> = map \<mu> \<bullet> \<r> (dom \<mu>)"
	+ proof (intro arr_eqI)
	+ show par: "par (\<r> (cod \<mu>) \<bullet> R \<mu>) (map \<mu> \<bullet> \<r> (dom \<mu>))"
	+ using \<mu> 0 [of "dom \<mu>"] 0 [of "cod \<mu>"] hseqI' by force
	+ show "Chn (\<r> (cod \<mu>) \<bullet> R \<mu>) = Chn (map \<mu> \<bullet> \<r> (dom \<mu>))"
	+ proof -
	+ have "Chn (\<r> (cod \<mu>) \<bullet> R \<mu>) =
	+ \<p>\<^sub>1[\<mu>.cod.leg0, \<mu>.cod.src] \<cdot>
	+ \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<mu>.dsrc] \<lbrakk>\<mu>.cod.leg0, \<mu>.cod.src\<rbrakk> \<p>\<^sub>0[\<mu>.dom.leg0, \<mu>.dsrc]\<rangle>"
	+ proof -
	+ have "Chn (\<r> (cod \<mu>) \<bullet> R \<mu>) = \<p>\<^sub>1[\<mu>.cod.leg0, \<mu>.cod.src] \<cdot> Chn (\<mu> \<star> src \<mu>)"
	+ proof -
	+ have "Dom (cod \<mu> \<star> src \<mu>) = Cod (\<mu> \<star> src \<mu>)"
	+ using \<mu> seq_char by fastforce
	+ moreover have "\<p>\<^sub>1[Leg0 (Dom (cod \<mu>)), C.cod (Leg0 (Dom (cod \<mu>)))] \<cdot>
	+ Chn (\<mu> \<star> src \<mu>) =
	+ \<p>\<^sub>1[\<mu>.cod.leg0, \<mu>.dsrc] \<cdot> Chn (\<mu> \<star> src \<mu>)"
	+ by (simp add: \<mu> cod_char)
	+ moreover have "arrow_of_spans (\<cdot>)
	+ \<lparr>Chn = \<p>\<^sub>1[Leg0 (Dom (cod \<mu>)), C.cod (Leg0 (Dom (cod \<mu>)))],
	+ Dom = Cod (\<mu> \<star> src \<mu>), Cod = Cod (cod \<mu>)\<rparr>"
	+ using \<mu> par seq_char by auto
	+ ultimately show ?thesis
	+ using \<mu> vcomp_def R\<mu>.arrow_of_spans_axioms by auto
	+ qed
	+ moreover
	+ have "Chn (\<mu> \<star> src \<mu>) = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<mu>.dsrc]
	+ \<lbrakk>\<mu>.cod.leg0, \<mu>.dsrc\<rbrakk>
	+ \<p>\<^sub>0[\<mu>.dom.leg0, \<mu>.dsrc]\<rangle>"
	+ using \<mu> hcomp_def chine_hcomp_arr_src by simp
	+ ultimately show ?thesis
	+ using \<mu> by (auto simp add: cod_char)
	+ qed
	+ also have "... = \<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, C.cod \<mu>.dom.leg0]"
	+ using \<mu> ide_char C.prj_tuple(2)
	+ C.in_homE C.pullback_commutes [of "\<mu>.dom.leg0" "C.cod \<mu>.dom.leg0"]
	+ C.comp_reduce
	+ by auto
	+ also have "... = Chn (map \<mu> \<bullet> \<r> (dom \<mu>))"
	+ using \<mu> par seq_char dom_char vcomp_eq map_simp by simp
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+ qed
	+
	+ interpretation \<rho>: natural_isomorphism vcomp vcomp R map \<rho>.map
	+ proof
	+ fix f
	+ assume f: "ide f"
	+ show "iso (\<rho>.map f)"
	+ proof -
	+ interpret f: identity_arrow_of_spans C f
	+ using f ide_char' by auto
	+ have 1: "\<rho>.map f = \<lparr>Chn = \<p>\<^sub>1[f.leg0, f.dsrc], Dom = Dom (f \<star> src f), Cod = Dom f\<rparr>"
	+ using f ide_char by auto
	+ interpret \<rho>f: arrow_of_spans C \<open>\<rho>.map f\<close>
	+ using f arr_char \<rho>.preserves_reflects_arr by fastforce
	+ let ?\<rho>f' = "\<lparr>Chn = \<langle>C.dom f.leg0 \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>,
	+ Dom = Dom f, Cod = Dom (f \<star> src f)\<rparr>"
	+ have 2: "C.inverse_arrows (Chn (\<rho>.map f)) (Chn ?\<rho>f')"
	+ using 1 C.pullback_arr_cod(1) [of "f.dom.leg0"] by simp
	+ interpret \<rho>f': arrow_of_spans C ?\<rho>f'
	+ proof
	+ show Dom: "C.span (Leg0 (Dom ?\<rho>f')) (Leg1 (Dom ?\<rho>f'))"
	+ using f 1 by auto
	+ interpret Dom: span_in_category C \<open>Dom ?\<rho>f'\<close>
	+ using Dom by (unfold_locales, auto)
	+ show Cod: "C.span (Leg0 (Cod ?\<rho>f')) (Leg1 (Cod ?\<rho>f'))"
	+ using f 1 \<rho>f.dom.is_span by auto
	+ interpret Cod: span_in_category C \<open>Cod ?\<rho>f'\<close>
	+ using Cod by (unfold_locales, auto)
	+ show "\<guillemotleft>Chn ?\<rho>f' : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
	+ using f src_def trg_def hcomp_def ide_mkObj Cod.apex_def Dom.apex_def
	+ C.comp_arr_dom C.comp_cod_arr
	+ by auto
	+ show "Cod.leg0 \<cdot> Chn ?\<rho>f' = Dom.leg0"
	+ using 2 \<rho>f.leg0_commutes C.invert_side_of_triangle
	+ by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<rho>f.dom.is_span
	+ arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
	+ show "Cod.leg1 \<cdot> Chn ?\<rho>f' = Dom.leg1"
	+ using 2 \<rho>f.leg1_commutes C.invert_side_of_triangle
	+ by (metis (no_types, lifting) "1" C.inverse_unique C.isoI \<rho>f.dom.is_span
	+ arrow_of_spans_data.select_convs(2) arrow_of_spans_data.select_convs(3))
	+ qed
	+ have "inverse_arrows (\<rho>.map f) ?\<rho>f'"
	+ proof
	+ show "ide (?\<rho>f' \<bullet> \<rho>.map f)"
	+ proof -
	+ have "?\<rho>f' \<bullet> \<rho>.map f = dom (\<rho>.map f)"
	+ proof -
	+ have "?\<rho>f' \<bullet> \<rho>.map f =
	+ \<lparr>Chn = f.leg0 \<down>\<down> f.dsrc, Dom = Dom (\<rho>.map f), Cod = Dom (\<rho>.map f)\<rparr>"
	+ using f 1 2 f.arrow_of_spans_axioms
	+ \<rho>f.arrow_of_spans_axioms \<rho>f'.arrow_of_spans_axioms
	+ vcomp_def ide_char arr_char C.comp_inv_arr
	+ by (simp add: vcomp_def)
	+ also have "... = dom (\<rho>.map f)"
	+ proof -
	+ have "C.dom (Leg0 (Dom (f \<star> src f))) = C.dom (Leg1 (Dom (f \<star> src f)))"
	+ using f f.arrow_of_spans_axioms hcomp_def src_def trg_def ide_mkObj
	+ by auto
	+ thus ?thesis
	+ using 1 f.arrow_of_spans_axioms arr_char dom_char \<rho>f.dom.is_span
	+ \<rho>f.arrow_of_spans_axioms \<rho>f'.cod.apex_def \<rho>f.chine_simps(2)
	+ by auto
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using \<rho>f.arrow_of_spans_axioms arr_char by simp
	+ qed
	+ show "ide (\<rho>.map f \<bullet> ?\<rho>f')"
	+ proof -
	+ have "\<rho>.map f \<bullet> ?\<rho>f' = dom ?\<rho>f'"
	+ proof -
	+ have "\<rho>.map f \<bullet> ?\<rho>f' = \<lparr>Chn = Chn f, Dom = Dom ?\<rho>f', Cod = Dom ?\<rho>f'\<rparr>"
	+ using f 1 2 f.arrow_of_spans_axioms
	+ \<rho>f.arrow_of_spans_axioms \<rho>f'.arrow_of_spans_axioms
	+ vcomp_def ide_char arr_char
	+ by fastforce
	+ also have "... = dom ?\<rho>f'"
	+ using 1 \<rho>f'.arrow_of_spans_axioms arr_char dom_char by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using \<rho>f'.arrow_of_spans_axioms arr_char by simp
	+ qed
	+ qed
	+ thus ?thesis by auto
	+ qed
	+ qed
	+
	+ lemma \<rho>_is_natural_isomorphism:
	+ shows "natural_isomorphism vcomp vcomp R map \<rho>.map"
	+ ..
	+
	+ interpretation equivalence_functor vcomp vcomp R
	+ using R.isomorphic_to_identity_is_equivalence \<rho>.natural_isomorphism_axioms by simp
	+
	+ lemma equivalence_functor_R:
	+ shows "equivalence_functor vcomp vcomp R"
	+ ..
	+
	+ definition unit ("\<i>[_]")
	+ where "\<i>[a] \<equiv> \<lparr>Chn = \<p>\<^sub>0[Chn a, Chn a], Dom = Dom (a \<star> a), Cod = Cod a\<rparr>"
	+
	+ lemma unit_in_hom [intro]:
	+ assumes "obj a"
	+ shows "in_hhom \<i>[a] a a"
	+ and "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<i>[a] : a \<star> a \<Rightarrow> a\<guillemotright>"
	+ proof (intro in_homI)
	+ interpret a: identity_arrow_of_spans C a
	+ using assms obj_char ide_char' by auto
	+ have 0: "src a = trg a"
	+ using assms arr_char obj_char src_def trg_def by (elim objE, auto)
	+ interpret aa: arrow_of_spans C \<open>a \<star> a\<close>
	+ using assms 0 a.arrow_of_spans_axioms arrow_of_spans_hcomp by auto
	+ interpret aa: identity_arrow_of_spans C \<open>a \<star> a\<close>
	+ proof
	+ have "ide (a \<star> a)"
	+ using assms 0 obj_char H.preserves_ide by simp
	+ thus "C.ide aa.chine" using ide_char by auto
	+ qed
	+ have 1: "\<guillemotleft>\<p>\<^sub>0[a.chine, a.chine] : a.chine \<down>\<down> a.chine \<rightarrow>\<^sub>C a.chine\<guillemotright> \<and>
	+ \<guillemotleft>\<p>\<^sub>1[a.chine, a.chine] : a.chine \<down>\<down> a.chine \<rightarrow>\<^sub>C a.chine\<guillemotright>"
	+ by auto
	+ have 2: "a.dom.leg0 = a.chine \<and> a.dom.leg1 = a.chine \<and>
	+ a.cod.leg0 = a.chine \<and> a.cod.leg1 = a.chine"
	+ using assms obj_char by (cases a, simp_all)
	+ have 3: "a \<star> a = \<lparr>Chn = a.chine \<down>\<down> a.chine,
	+ Dom = \<lparr>Leg0 = \<p>\<^sub>0[a.chine, a.chine], Leg1 = \<p>\<^sub>1[a.chine, a.chine]\<rparr>,
	+ Cod = \<lparr>Leg0 = \<p>\<^sub>0[a.chine, a.chine], Leg1 = \<p>\<^sub>1[a.chine, a.chine]\<rparr>\<rparr>"
	+ using assms 0 1 2 chine_hcomp_ide_ide hcomp_def C.comp_cod_arr
	+ a.identity_arrow_of_spans_axioms ide_char'
	+ by auto
	+ have "aa.apex = a.chine \<down>\<down> a.chine"
	+ using 3 aa.chine_eq_apex by auto
	+ interpret \<i>a: arrow_of_spans C \<open>\<i>[a]\<close>
	+ proof
	+ have 4: "Dom \<i>[a] = Dom (a \<star> a)"
	+ using assms hcomp_def unit_def by simp
	+ have 5: "Cod \<i>[a] = Cod a"
	+ using assms unit_def by simp
	+ show Dom: "C.span (Leg0 (Dom \<i>[a])) (Leg1 (Dom \<i>[a]))"
	+ using 4 by simp
	+ interpret Dom: span_in_category C \<open>Dom \<i>[a]\<close>
	+ using Dom by (unfold_locales, auto)
	+ show Cod: "C.span (Leg0 (Cod \<i>[a])) (Leg1 (Cod \<i>[a]))"
	+ using 5 by simp
	+ interpret Cod: span_in_category C \<open>Cod \<i>[a]\<close>
	+ using Cod by (unfold_locales, auto)
	+ show "\<guillemotleft>Chn \<i>[a] : Dom.apex \<rightarrow>\<^sub>C Cod.apex\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>Chn \<i>[a] : a.chine \<down>\<down> a.chine \<rightarrow>\<^sub>C C.dom a.chine\<guillemotright>"
	+ using assms obj_char ide_char unit_def by simp
	+ moreover have "C.dom (Leg0 (Dom \<i>[a])) = Chn a \<down>\<down> Chn a"
	+ using assms 3 unit_def obj_char ide_char by simp
	+ moreover have "C.dom a.chine = C.dom Cod.leg0"
	+ using unit_def by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ show "Cod.leg0 \<cdot> Chn \<i>[a] = Dom.leg0"
	+ unfolding unit_def using 1 2 3 C.comp_cod_arr by auto
	+ show "Cod.leg1 \<cdot> Chn \<i>[a] = Dom.leg1"
	+ unfolding unit_def using 1 2 3 C.comp_cod_arr C.pullback_ide_self by auto
	+ qed
	+ show "arr \<i>[a]"
	+ using \<i>a.arrow_of_spans_axioms arr_char by simp
	+ show "dom \<i>[a] = hcomp a a"
	+ using 3 unit_def \<i>a.arrow_of_spans_axioms arr_char dom_char \<i>a.dom.apex_def
	+ by auto
	+ show "cod \<i>[a] = a"
	+ using assms 3 obj_char arr_char dom_char cod_char unit_def
	+ \<i>a.arrow_of_spans_axioms
	+ by auto
	+ qed
	+ thus "in_hhom \<i>[a] a a"
	+ using assms
	+ by (metis arrI in_hhom_def objE vconn_implies_hpar(1) vconn_implies_hpar(2-4))
	+ qed
	+
	+ lemma unit_simps [simp]:
	+ assumes "obj a"
	+ shows "src \<i>[a] = a" and "trg \<i>[a] = a"
	+ and "dom \<i>[a] = hcomp a a" and "cod \<i>[a] = a"
	+ using assms unit_in_hom by auto
	+
	+ lemma iso_unit:
	+ assumes "obj a"
	+ shows "iso \<i>[a]"
	+ proof -
	+ have "Chn \<i>[a] = \<p>\<^sub>0[Chn a, Chn a]"
	+ unfolding unit_def by simp
	+ moreover have "C.iso \<p>\<^sub>0[Chn a, Chn a]"
	+ using assms C.ide_is_iso C.iso_is_arr C.iso_pullback_ide ide_char by blast
	+ ultimately show ?thesis
	+ using assms unit_in_hom iso_char by auto
	+ qed
	+
	+ end
	+
	+ locale two_composable_arrows_of_spans =
	+ span_bicategory +
	+ \<mu>: arrow_of_spans C \<mu> +
	+ \<nu>: arrow_of_spans C \<nu>
	+ for \<mu> (structure)
	+ and \<nu> (structure) +
	+ assumes composable: "src \<mu> = trg \<nu>"
	+ begin
	+
	+ lemma are_arrows [simp]:
	+ shows "arr \<mu>" and "arr \<nu>"
	+ using arr_char \<mu>.arrow_of_spans_axioms \<nu>.arrow_of_spans_axioms by auto
	+
	+ lemma legs_form_cospan:
	+ shows "C.cospan \<mu>.dom.leg0 \<nu>.dom.leg1" and "C.cospan \<mu>.cod.leg0 \<nu>.cod.leg1"
	+ using composable src_def trg_def by auto
	+
	+ interpretation \<mu>\<nu>: arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
	+ using arrow_of_spans_hcomp composable by auto
	+
	+ lemma composite_is_arrow [simp]:
	+ shows "arr (\<mu> \<star> \<nu>)"
	+ using \<mu>\<nu>.arrow_of_spans_axioms arr_char by auto
	+
	+ lemma composite_in_hom [intro]:
	+ shows "\<guillemotleft>\<mu> \<star> \<nu> : dom \<mu> \<star> dom \<nu> \<Rightarrow> cod \<mu> \<star> cod \<nu>\<guillemotright>"
	+ using composable by auto
	+
	+ lemma composite_simps [simp]:
	+ shows "src (\<mu> \<star> \<nu>) = src \<nu>" and "trg (\<mu> \<star> \<nu>) = trg \<mu>"
	+ and "dom (\<mu> \<star> \<nu>) = dom \<mu> \<star> dom \<nu>" and "cod (\<mu> \<star> \<nu>) = cod \<mu> \<star> cod \<nu>"
	+ by auto
	+
	+ lemma chine_composite:
	+ shows "Chn (\<mu> \<star> \<nu>) = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
	+ \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
	+ \<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle>"
	+ unfolding hcomp_def chine_hcomp_def using composable by simp
	+
	+ lemma chine_composite_in_hom [intro]:
	+ shows "\<guillemotleft>Chn (\<mu> \<star> \<nu>) : \<mu>.dom.leg0 \<down>\<down> \<nu>.dom.leg1 \<rightarrow>\<^sub>C \<mu>.cod.leg0 \<down>\<down> \<nu>.cod.leg1\<guillemotright>"
	+ using hcomp_def chine_hcomp_props(1) composable by auto
	+
	+ end
	+
	+ sublocale two_composable_arrows_of_spans \<subseteq> arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
	+ proof -
	+ interpret Dom\<mu>_Dom\<nu>: composite_span C prj0 prj1 \<open>Dom \<mu>\<close> \<open>Dom \<nu>\<close>
	+ using legs_form_cospan(1) by (unfold_locales, auto)
	+ interpret Cod\<mu>_Cod\<nu>: composite_span C prj0 prj1 \<open>Cod \<mu>\<close> \<open>Cod \<nu>\<close>
	+ using legs_form_cospan(1) by (unfold_locales, auto)
	+ interpret Dom_\<mu>\<nu>: span_in_category C \<open>Dom (\<mu> \<star> \<nu>)\<close>
	+ apply unfold_locales apply (unfold hcomp_def)
	+ using Dom\<mu>_Dom\<nu>.apex_def Dom\<mu>_Dom\<nu>.leg_simps(1) are_arrows(1) composable by auto
	+ interpret Cod_\<mu>\<nu>: span_in_category C \<open>Cod (\<mu> \<star> \<nu>)\<close>
	+ apply unfold_locales apply (unfold hcomp_def)
	+ using Cod\<mu>_Cod\<nu>.apex_def Cod\<mu>_Cod\<nu>.leg_simps(1) are_arrows(1) composable by auto
	+ show "arrow_of_spans C (\<mu> \<star> \<nu>)"
	+ proof
	+ show "\<guillemotleft>Chn (hcomp \<mu> \<nu>) : Dom_\<mu>\<nu>.apex \<rightarrow>\<^sub>C Cod_\<mu>\<nu>.apex\<guillemotright>"
	+ unfolding hcomp_def
	+ using are_arrows(1) are_arrows(2) arrow_of_spans_hcomp composable hcomp_def
	+ arrow_of_spans.chine_in_hom Cod\<mu>_Cod\<nu>.leg_simps(4) Dom\<mu>_Dom\<nu>.leg_simps(3)
	+ Dom\<mu>_Dom\<nu>.leg_simps(4) chine_composite_in_hom
	+ by auto
	+ show "Cod_\<mu>\<nu>.leg0 \<cdot> Chn (hcomp \<mu> \<nu>) = Dom_\<mu>\<nu>.leg0"
	+ proof (unfold hcomp_def)
	+ have "arrow_of_spans C
	+ \<lparr>Chn = chine_hcomp \<mu> \<nu>, Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>"
	+ using arrow_of_spans_hcomp composable hcomp_def by auto
	+ thus "Leg0 (Cod (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
	+ \<lparr>Chn = chine_hcomp \<mu> \<nu>,
	+ Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
	+ else null)) \<cdot>
	+ Chn (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
	+ \<lparr>Chn = chine_hcomp \<mu> \<nu>,
	+ Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
	+ else null) =
	+ Leg0 (Dom (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
	+ \<lparr>Chn = chine_hcomp \<mu> \<nu>,
	+ Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
	+ else null))"
	+ using arrow_of_spans.leg0_commutes composable by fastforce
	+ qed
	+ show "Cod_\<mu>\<nu>.leg1 \<cdot> Chn (hcomp \<mu> \<nu>) = Dom_\<mu>\<nu>.leg1"
	+ proof (unfold hcomp_def)
	+ have "arrow_of_spans C
	+ \<lparr>Chn = chine_hcomp \<mu> \<nu>, Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>"
	+ using arrow_of_spans_hcomp composable hcomp_def by force
	+ thus "Leg1 (Cod (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
	+ \<lparr>Chn = chine_hcomp \<mu> \<nu>,
	+ Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
	+ else null)) \<cdot>
	+ Chn (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
	+ \<lparr>Chn = chine_hcomp \<mu> \<nu>,
	+ Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
	+ else null) =
	+ Leg1 (Dom (if arr \<nu> \<and> arr \<mu> \<and> src \<mu> = trg \<nu> then
	+ \<lparr>Chn = chine_hcomp \<mu> \<nu>,
	+ Dom = Dom\<mu>_Dom\<nu>.this, Cod = Cod\<mu>_Cod\<nu>.this\<rparr>
	+ else null))"
	+ using arrow_of_spans.leg1_commutes composable by force
	+ qed
	+ qed
	+ qed
	+
	+ locale two_composable_identity_arrows_of_spans =
	+ two_composable_arrows_of_spans +
	+ \<mu>: identity_arrow_of_spans C \<mu> +
	+ \<nu>: identity_arrow_of_spans C \<nu>
	+ begin
	+
	+ lemma are_identities [simp]:
	+ shows "ide \<mu>" and "ide \<nu>"
	+ using ide_char \<mu>.arrow_of_spans_axioms \<nu>.arrow_of_spans_axioms by auto
	+
	+ interpretation VxV: product_category vcomp vcomp ..
	+ interpretation VV: subcategory VxV.comp \<open>\<lambda>\<nu>\<mu>. arr (fst \<nu>\<mu>) \<and> arr (snd \<nu>\<mu>) \<and>
	+ src (fst \<nu>\<mu>) = trg (snd \<nu>\<mu>)\<close>
	+ by (unfold_locales, simp_all)
	+ interpretation H: "functor" VV.comp vcomp \<open>\<lambda>\<nu>\<mu>. fst \<nu>\<mu> \<star> snd \<nu>\<mu>\<close>
	+ using hcomp_is_functor by auto
	+
	+ interpretation \<mu>\<nu>: identity_arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
	+ proof
	+ have "VV.ide (\<mu>, \<nu>)"
	+ using VV.ide_char composable by auto
	+ hence "ide (hcomp \<mu> \<nu>)"
	+ using H.preserves_ide [of "(\<mu>, \<nu>)"] by simp
	+ thus "C.ide chine"
	+ using ide_char by simp
	+ qed
	+
	+ lemma ide_composite [simp]:
	+ shows "ide (\<mu> \<star> \<nu>)"
	+ using \<mu>\<nu>.identity_arrow_of_spans_axioms arrow_of_spans_axioms ide_char by auto
	+
	+ lemma apex_composite:
	+ shows "\<mu>\<nu>.apex = \<mu>.leg0 \<down>\<down> \<nu>.leg1"
	+ using dom.apex_def hcomp_def chine_hcomp_ide_ide composable legs_form_cospan
	+ by simp
	+
	+ lemma leg0_composite:
	+ shows "\<mu>\<nu>.leg0 = \<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1]"
	+ using dom.apex_def hcomp_def composable legs_form_cospan by simp
	+
	+ lemma leg1_composite:
	+ shows "\<mu>\<nu>.leg1 = \<mu>.leg1 \<cdot> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1]"
	+ using dom.apex_def hcomp_def composable legs_form_cospan by simp
	+
	+ lemma chine_composite:
	+ shows "Chn (\<mu> \<star> \<nu>) = \<mu>.leg0 \<down>\<down> \<nu>.leg1"
	+ unfolding hcomp_def using chine_hcomp_ide_ide composable by simp
	+
	+ abbreviation prj\<^sub>0
	+ where "prj\<^sub>0 \<equiv> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1]"
	+
	+ abbreviation prj\<^sub>1
	+ where "prj\<^sub>1 \<equiv> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1]"
	+
	+ lemma prj_in_hom [intro]:
	+ shows "\<guillemotleft>prj\<^sub>1 : \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
	+ and "\<guillemotleft>prj\<^sub>0 : \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<rightarrow>\<^sub>C \<nu>.apex\<guillemotright>"
	+ using legs_form_cospan by auto
	+
	+ lemma prj_simps [simp]:
	+ shows "C.arr prj\<^sub>1" and "C.dom prj\<^sub>1 = \<mu>.leg0 \<down>\<down> \<nu>.leg1" and "C.cod prj\<^sub>1 = \<mu>.apex"
	+ and "C.arr prj\<^sub>0" and "C.dom prj\<^sub>0 = \<mu>.leg0 \<down>\<down> \<nu>.leg1" and "C.cod prj\<^sub>0 = \<nu>.apex"
	+ using prj_in_hom by auto
	+
	+ sublocale identity_arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
	+ using apex_composite dom.ide_apex chine_composite by (unfold_locales, auto)
	+
	+ end
	+
	+ locale three_composable_arrows_of_spans =
	+ span_bicategory +
	+ \<mu>: arrow_of_spans C \<mu> +
	+ \<nu>: arrow_of_spans C \<nu> +
	+ \<pi>: arrow_of_spans C \<pi> +
	+ \<mu>\<nu>: two_composable_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
	+ \<nu>\<pi>: two_composable_arrows_of_spans C prj0 prj1 \<nu> \<pi>
	+ for \<mu> (structure)
	+ and \<nu> (structure)
	+ and \<pi> (structure)
	+ begin
	+
	+ interpretation \<mu>\<nu>\<pi>: arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
	+ using \<mu>.arrow_of_spans_axioms \<nu>\<pi>.arrow_of_spans_axioms
	+ arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
	+ by force
	+
	+ interpretation \<mu>\<nu>_\<pi>: arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
	+ using \<mu>\<nu>.arrow_of_spans_axioms \<pi>.arrow_of_spans_axioms
	+ arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
	+ by force
	+
	+ lemma composites_are_arrows [simp]:
	+ shows "arr (\<mu> \<star> \<nu> \<star> \<pi>)" and "arr ((\<mu> \<star> \<nu>) \<star> \<pi>)"
	+ using \<mu>\<nu>\<pi>.arrow_of_spans_axioms \<mu>\<nu>_\<pi>.arrow_of_spans_axioms arr_char by auto
	+
	+ lemma composite_in_hom [intro]:
	+ shows "\<guillemotleft>\<mu> \<star> \<nu> \<star> \<pi> : dom \<mu> \<star> dom \<nu> \<star> dom \<pi> \<Rightarrow> cod \<mu> \<star> cod \<nu> \<star> cod \<pi>\<guillemotright>"
	+ and "\<guillemotleft>(\<mu> \<star> \<nu>) \<star> \<pi> : (dom \<mu> \<star> dom \<nu>) \<star> dom \<pi> \<Rightarrow> (cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>\<guillemotright>"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable by auto
	+
	+ lemma composite_simps [simp]:
	+ shows "src (\<mu> \<star> \<nu> \<star> \<pi>) = src \<pi>"
	+ and "src ((\<mu> \<star> \<nu>) \<star> \<pi>) = src \<pi>"
	+ and "trg (\<mu> \<star> \<nu> \<star> \<pi>) = trg \<mu>"
	+ and "trg ((\<mu> \<star> \<nu>) \<star> \<pi>) = trg \<mu>"
	+ and "dom (\<mu> \<star> \<nu> \<star> \<pi>) = dom \<mu> \<star> dom \<nu> \<star> dom \<pi>"
	+ and "dom ((\<mu> \<star> \<nu>) \<star> \<pi>) = (dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>"
	+ and "cod (\<mu> \<star> \<nu> \<star> \<pi>) = cod \<mu> \<star> cod \<nu> \<star> cod \<pi>"
	+ and "cod ((\<mu> \<star> \<nu>) \<star> \<pi>) = (cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>"
	+ by auto
	+
	+ lemma chine_composite:
	+ shows "\<mu>\<nu>\<pi>.chine =
	+ \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]
	+ \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
	+ \<langle>\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]
	+ \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk>
	+ \<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rangle> \<cdot>
	+ \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]\<rangle>"
	+ and "\<mu>\<nu>_\<pi>.chine =
	+ \<langle>\<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
	+ \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
	+ \<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle> \<cdot>
	+ \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]
	+ \<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
	+ \<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]\<rangle>"
	+ proof -
	+ show "\<mu>\<nu>\<pi>.chine =
	+ \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]
	+ \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
	+ \<langle>\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]
	+ \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk>
	+ \<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rangle> \<cdot>
	+ \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]\<rangle>"
	+ unfolding hcomp_def chine_hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composable
	+ using trg_def \<nu>\<pi>.are_arrows(1-2) \<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow
	+ \<nu>\<pi>.composite_simps(2) hcomp_def
	+ by (simp add: chine_hcomp_def)
	+ show "\<mu>\<nu>_\<pi>.chine =
	+ \<langle>\<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
	+ \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
	+ \<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle> \<cdot>
	+ \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]
	+ \<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
	+ \<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]\<rangle>"
	+ unfolding hcomp_def chine_hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composable
	+ using src_def \<mu>\<nu>.are_arrows(1-2) \<mu>\<nu>.composable \<mu>\<nu>.composite_is_arrow
	+ \<mu>\<nu>.composite_simps(1) hcomp_def \<nu>\<pi>.composable
	+ by (simp add: chine_hcomp_def)
	+ qed
	+
	+ end
	+
	+ locale three_composable_identity_arrows_of_spans =
	+ three_composable_arrows_of_spans +
	+ \<mu>: identity_arrow_of_spans C \<mu> +
	+ \<nu>: identity_arrow_of_spans C \<nu> +
	+ \<pi>: identity_arrow_of_spans C \<pi> +
	+ \<mu>\<nu>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
	+ \<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<pi>
	+ begin
	+
	+ lemma composites_are_identities [simp]:
	+ shows "ide (\<mu> \<star> \<nu> \<star> \<pi>)" and "ide ((\<mu> \<star> \<nu>) \<star> \<pi>)"
	+ proof -
	+ interpret \<mu>_H\<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<open>\<nu> \<star> \<pi>\<close>
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable
	+ by (unfold_locales, simp)
	+ show "ide (\<mu> \<star> \<nu> \<star> \<pi>)"
	+ by auto
	+ interpret H\<mu>\<nu>_\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<mu> \<star> \<nu>\<close> \<pi>
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable
	+ by (unfold_locales, simp)
	+ show "ide ((\<mu> \<star> \<nu>) \<star> \<pi>)"
	+ by auto
	+ qed
	+
	+ interpretation \<mu>\<nu>\<pi>: identity_arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
	+ using composites_are_identities ide_char' by auto
	+ interpretation \<mu>\<nu>_\<pi>: identity_arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
	+ using composites_are_identities ide_char' by auto
	+
	+ abbreviation Prj\<^sub>1\<^sub>1
	+ where "Prj\<^sub>1\<^sub>1 \<equiv> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1] \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1]"
	+ abbreviation Prj\<^sub>0\<^sub>1
	+ where "Prj\<^sub>0\<^sub>1 \<equiv> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1] \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1]"
	+ abbreviation Prj\<^sub>0
	+ where "Prj\<^sub>0 \<equiv> \<p>\<^sub>0[\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1]"
	+
	+ abbreviation Prj\<^sub>1
	+ where "Prj\<^sub>1 \<equiv> \<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]]"
	+ abbreviation Prj\<^sub>1\<^sub>0
	+ where "Prj\<^sub>1\<^sub>0 \<equiv> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1] \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]]"
	+ abbreviation Prj\<^sub>0\<^sub>0
	+ where "Prj\<^sub>0\<^sub>0 \<equiv> \<p>\<^sub>0[\<nu>.leg0, \<pi>.leg1] \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]]"
	+
	+ lemma leg0_composite:
	+ shows "\<mu>\<nu>\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0\<^sub>0"
	+ and "\<mu>\<nu>_\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0"
	+ proof -
	+ show "\<mu>\<nu>\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0\<^sub>0"
	+ using hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composite_is_arrow \<nu>\<pi>.composite_simps(2)
	+ C.comp_assoc
	+ by auto
	+ show "\<mu>\<nu>_\<pi>.leg0 = \<pi>.leg0 \<cdot> Prj\<^sub>0"
	+ using hcomp_def \<mu>\<nu>.composite_is_arrow \<mu>\<nu>.composite_simps(1) \<nu>\<pi>.composable by auto
	+ qed
	+
	+ lemma leg1_composite:
	+ shows "\<mu>\<nu>\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1"
	+ and "\<mu>\<nu>_\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1\<^sub>1"
	+ proof -
	+ show "\<mu>\<nu>\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1"
	+ using hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composite_is_arrow \<nu>\<pi>.composite_simps(2) by auto
	+ show "\<mu>\<nu>_\<pi>.leg1 = \<mu>.leg1 \<cdot> Prj\<^sub>1\<^sub>1"
	+ using hcomp_def \<mu>\<nu>.composite_is_arrow \<mu>\<nu>.composite_simps(1) \<nu>\<pi>.composable
	+ C.comp_assoc
	+ by auto
	+ qed
	+
	+ definition chine_assoc
	+ where "chine_assoc \<equiv>
	+ \<langle>Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.leg0, \<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]\<rbrakk> \<langle>Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>.leg1\<rbrakk> Prj\<^sub>0\<rangle>\<rangle>"
	+
	+ definition chine_assoc'
	+ where "chine_assoc' \<equiv>
	+ \<langle>\<langle>Prj\<^sub>1 \<lbrakk>\<mu>.leg0, \<nu>.leg1\<rbrakk> Prj\<^sub>1\<^sub>0\<rangle> \<lbrakk>\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1], \<pi>.leg1\<rbrakk> Prj\<^sub>0\<^sub>0\<rangle>"
	+
	+ (*
	+ * Don't be fooled by how short the following proofs look -- there's a heck of a lot
	+ * going on behind the scenes here!
	+ *)
	+ lemma chine_composite:
	+ shows "\<mu>\<nu>_\<pi>.chine = \<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0 \<down>\<down> \<pi>.leg1"
	+ and "\<mu>\<nu>\<pi>.chine = \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1"
	+ proof -
	+ show "\<mu>\<nu>_\<pi>.chine = \<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0 \<down>\<down> \<pi>.leg1"
	+ using hcomp_def chine_hcomp_arr_ide [of "hcomp \<mu> \<nu>" \<pi>] chine_hcomp_ide_ide
	+ src_def trg_def \<mu>\<nu>.composable \<nu>\<pi>.composable \<mu>\<nu>.ide_composite
	+ \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities(2)
	+ by simp
	+ show "\<mu>\<nu>\<pi>.chine = \<mu>.leg0 \<down>\<down> \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1"
	+ using hcomp_def chine_hcomp_ide_arr [of \<mu> "hcomp \<nu> \<pi>"] chine_hcomp_ide_ide
	+ src_def trg_def \<mu>\<nu>.composable \<nu>\<pi>.composable \<nu>\<pi>.ide_composite
	+ \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities(2)
	+ by simp
	+ qed
	+
	+ lemma prj_in_hom [intro]:
	+ shows "\<guillemotleft>Prj\<^sub>1\<^sub>1 : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
	+ and "\<guillemotleft>Prj\<^sub>0\<^sub>1 : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<nu>.apex\<guillemotright>"
	+ and "\<guillemotleft>Prj\<^sub>0 : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<pi>.apex\<guillemotright>"
	+ and "\<guillemotleft>Prj\<^sub>1 : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
	+ and "\<guillemotleft>Prj\<^sub>1\<^sub>0 : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<nu>.apex\<guillemotright>"
	+ and "\<guillemotleft>Prj\<^sub>0\<^sub>0 : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<pi>.apex\<guillemotright>"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite by auto
	+
	+ lemma prj_simps [simp]:
	+ shows "C.arr Prj\<^sub>1\<^sub>1"
	+ and "C.arr Prj\<^sub>0\<^sub>1"
	+ and "C.arr Prj\<^sub>0"
	+ and "C.dom Prj\<^sub>1\<^sub>1 = \<mu>\<nu>_\<pi>.chine"
	+ and "C.dom Prj\<^sub>0\<^sub>1 = \<mu>\<nu>_\<pi>.chine"
	+ and "C.dom Prj\<^sub>0 = \<mu>\<nu>_\<pi>.chine"
	+ and "C.cod Prj\<^sub>1\<^sub>1 = \<mu>.apex"
	+ and "C.cod Prj\<^sub>0\<^sub>1 = \<nu>.apex"
	+ and "C.cod Prj\<^sub>0 = \<pi>.apex"
	+ and "C.arr Prj\<^sub>1"
	+ and "C.arr Prj\<^sub>1\<^sub>0"
	+ and "C.arr Prj\<^sub>0\<^sub>0"
	+ and "C.dom Prj\<^sub>1 = \<mu>\<nu>\<pi>.chine"
	+ and "C.dom Prj\<^sub>1\<^sub>0 = \<mu>\<nu>\<pi>.chine"
	+ and "C.dom Prj\<^sub>0\<^sub>0 = \<mu>\<nu>\<pi>.chine"
	+ and "C.cod Prj\<^sub>1 = \<mu>.apex"
	+ and "C.cod Prj\<^sub>1\<^sub>0 = \<nu>.apex"
	+ and "C.cod Prj\<^sub>0\<^sub>0 = \<pi>.apex"
	+ using prj_in_hom by auto
	+
	+ lemma chine_assoc_props:
	+ shows "\<guillemotleft>chine_assoc : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
	+ and "Prj\<^sub>1 \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1"
	+ and "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1"
	+ and "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0"
	+ proof -
	+ have 1: "\<nu>.leg0 \<cdot> Prj\<^sub>0\<^sub>1 = \<pi>.leg1 \<cdot> Prj\<^sub>0"
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
	+ C.pullback_commutes [of "\<nu>.leg0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1]" \<pi>.leg1] C.comp_assoc
	+ by auto
	+ have 2: "\<mu>.leg0 \<cdot> Prj\<^sub>1\<^sub>1 = \<nu>.leg1 \<cdot> Prj\<^sub>0\<^sub>1"
	+ proof -
	+ have "\<mu>.leg0 \<cdot> Prj\<^sub>1\<^sub>1 = (\<mu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>1) \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1]"
	+ using C.comp_assoc by auto
	+ also have "... = \<nu>.leg1 \<cdot> Prj\<^sub>0\<^sub>1"
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
	+ C.pullback_commutes
	+ by (auto simp add: C.commutative_square_def C.comp_assoc)
	+ finally show ?thesis by simp
	+ qed
	+ show "\<guillemotleft>chine_assoc : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
	+ unfolding chine_assoc_def
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
	+ src_def trg_def chine_composite C.comp_assoc by auto
	+ show "Prj\<^sub>1 \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1"
	+ unfolding chine_assoc_def
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
	+ src_def trg_def C.comp_assoc
	+ by auto
	+ show "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1"
	+ unfolding chine_assoc_def
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
	+ src_def trg_def C.comp_assoc
	+ by auto
	+ show "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0"
	+ unfolding chine_assoc_def
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
	+ src_def trg_def C.comp_assoc
	+ by auto
	+ qed
	+
	+ lemma chine_assoc_in_hom [intro]:
	+ shows "\<guillemotleft>chine_assoc : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
	+ using chine_assoc_props(1) by simp
	+
	+ lemma prj_chine_assoc [simp]:
	+ shows "Prj\<^sub>1 \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1"
	+ and "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1"
	+ and "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc = Prj\<^sub>0"
	+ using chine_assoc_props(2-4) by auto
	+
	+ lemma chine_assoc'_props:
	+ shows "\<guillemotleft>chine_assoc' : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
	+ and "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1"
	+ and "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0"
	+ and "Prj\<^sub>0 \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0"
	+ proof -
	+ have 1: "\<mu>.leg0 \<cdot> Prj\<^sub>1 = \<nu>.leg1 \<cdot> Prj\<^sub>1\<^sub>0"
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable
	+ src_def trg_def C.pullback_commutes [of \<mu>.leg0 "\<nu>.leg1 \<cdot> \<p>\<^sub>1[\<nu>.leg0, \<pi>.leg1]"]
	+ C.comp_assoc
	+ by auto
	+ have 2: "\<nu>.leg0 \<cdot> Prj\<^sub>1\<^sub>0 = \<pi>.leg1 \<cdot> Prj\<^sub>0\<^sub>0"
	+ proof -
	+ have "\<nu>.leg0 \<cdot> Prj\<^sub>1\<^sub>0 = (\<nu>.leg0 \<cdot> \<nu>\<pi>.prj\<^sub>1) \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1]"
	+ using C.comp_assoc by simp
	+ also have "... = \<pi>.leg1 \<cdot> Prj\<^sub>0\<^sub>0"
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
	+ C.pullback_commutes
	+ by (auto simp add: C.commutative_square_def C.comp_assoc)
	+ finally show ?thesis by auto
	+ qed
	+ show "\<guillemotleft>chine_assoc' : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
	+ unfolding chine_assoc'_def
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
	+ src_def trg_def chine_composite C.comp_assoc
	+ by auto
	+ show "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1"
	+ unfolding chine_assoc'_def
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
	+ src_def trg_def C.comp_assoc
	+ by auto
	+ show "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0"
	+ unfolding chine_assoc'_def
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
	+ src_def trg_def C.comp_assoc
	+ by auto
	+ show "Prj\<^sub>0 \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0"
	+ unfolding chine_assoc'_def
	+ using \<mu>\<nu>.are_identities \<nu>\<pi>.are_identities \<mu>\<nu>.composable \<nu>\<pi>.composable 1 2
	+ src_def trg_def C.comp_assoc
	+ by auto
	+ qed
	+
	+ lemma chine_assoc'_in_hom [intro]:
	+ shows "\<guillemotleft>chine_assoc' : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
	+ using chine_assoc'_props(1) by simp
	+
	+ lemma prj_chine_assoc' [simp]:
	+ shows "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1"
	+ and "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0"
	+ and "Prj\<^sub>0 \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0"
	+ using chine_assoc'_props(2-4) by auto
	+
	+ lemma prj_joint_monic:
	+ assumes "\<guillemotleft>h: a \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>" and "\<guillemotleft>h': a \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
	+ and "Prj\<^sub>1\<^sub>1 \<cdot> h = Prj\<^sub>1\<^sub>1 \<cdot> h'" and "Prj\<^sub>0\<^sub>1 \<cdot> h = Prj\<^sub>0\<^sub>1 \<cdot> h'" and "Prj\<^sub>0 \<cdot> h = Prj\<^sub>0 \<cdot> h'"
	+ shows "h = h'"
	+ proof -
	+ have "\<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h = \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"
	+ proof -
	+ have "\<mu>\<nu>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"
	+ using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(1)
	+ C.comp_assoc
	+ by force
	+ moreover
	+ have "\<mu>\<nu>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"
	+ using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(1)
	+ C.comp_assoc
	+ by force
	+ ultimately show ?thesis
	+ using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
	+ chine_composite(1) cod_char
	+ C.prj_joint_monic
	+ [of \<mu>.leg0 \<nu>.leg1 "\<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h"
	+ "\<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>.leg1] \<cdot> h'"]
	+ by auto
	+ qed
	+ moreover have "Prj\<^sub>0 \<cdot> h = Prj\<^sub>0 \<cdot> h'"
	+ using assms cod_char by simp
	+ ultimately show ?thesis
	+ using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
	+ chine_composite(1) cod_char
	+ C.prj_joint_monic [of "\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0" \<pi>.leg1 h h']
	+ by auto
	+ qed
	+
	+ lemma prj'_joint_monic:
	+ assumes "\<guillemotleft>h: a \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>" and "\<guillemotleft>h': a \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
	+ and "Prj\<^sub>1 \<cdot> h = Prj\<^sub>1 \<cdot> h'" and "Prj\<^sub>1\<^sub>0 \<cdot> h = Prj\<^sub>1\<^sub>0 \<cdot> h'" and "Prj\<^sub>0\<^sub>0 \<cdot> h = Prj\<^sub>0\<^sub>0 \<cdot> h'"
	+ shows "h = h'"
	+ proof -
	+ have "\<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h = \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"
	+ proof -
	+ have "\<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h = \<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"
	+ using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(2)
	+ C.comp_assoc
	+ by force
	+ moreover
	+ have "\<nu>\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"
	+ using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(2)
	+ C.comp_assoc
	+ by force
	+ ultimately show ?thesis
	+ using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
	+ chine_composite(2) cod_char
	+ C.prj_joint_monic
	+ [of \<nu>.leg0 \<pi>.leg1 "\<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h"
	+ "\<p>\<^sub>0[\<mu>.leg0, \<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1] \<cdot> h'"]
	+ by auto
	+ qed
	+ moreover have "Prj\<^sub>1 \<cdot> h = Prj\<^sub>1 \<cdot> h'"
	+ using assms cod_char by simp
	+ ultimately show ?thesis
	+ using assms \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def chine_composite(2)
	+ C.prj_joint_monic [of \<mu>.leg0 "\<nu>.leg1 \<cdot> \<nu>\<pi>.prj\<^sub>1" h h']
	+ by auto
	+ qed
	+
	+ lemma chine_assoc_inverse:
	+ shows "C.inverse_arrows chine_assoc chine_assoc'"
	+ proof
	+ show "C.ide (chine_assoc' \<cdot> chine_assoc)"
	+ proof -
	+ have 1: "C.ide \<mu>\<nu>_\<pi>.chine"
	+ using chine_assoc_props(1) C.ide_dom by fastforce
	+ have "chine_assoc' \<cdot> chine_assoc = \<mu>\<nu>_\<pi>.chine"
	+ proof -
	+ have 2: "C.seq chine_assoc' chine_assoc"
	+ using chine_assoc_props(1) chine_assoc'_props(1) by auto
	+ have 3: "C.seq Prj\<^sub>1\<^sub>1 chine_assoc' \<and> C.seq Prj\<^sub>0\<^sub>1 chine_assoc' \<and> C.seq Prj\<^sub>0 chine_assoc'"
	+ using prj_in_hom chine_assoc'_props(1) by auto
	+ have "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine"
	+ proof -
	+ have "Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = (Prj\<^sub>1\<^sub>1 \<cdot> chine_assoc') \<cdot> chine_assoc"
	+ using C.comp_assoc by metis
	+ thus ?thesis using 1 C.comp_arr_dom by simp
	+ qed
	+ moreover have "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = Prj\<^sub>0\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine"
	+ proof -
	+ have "Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc' \<cdot> chine_assoc = (Prj\<^sub>0\<^sub>1 \<cdot> chine_assoc') \<cdot> chine_assoc"
	+ using C.comp_assoc by metis
	+ thus ?thesis using 1 C.comp_arr_dom by simp
	+ qed
	+ moreover have "Prj\<^sub>0 \<cdot> chine_assoc' \<cdot> chine_assoc = Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.chine"
	+ proof -
	+ have "Prj\<^sub>0 \<cdot> chine_assoc' \<cdot> chine_assoc = (Prj\<^sub>0 \<cdot> chine_assoc') \<cdot> chine_assoc"
	+ using C.comp_assoc by metis
	+ thus ?thesis using 1 C.comp_arr_dom C.comp_arr_ide prj_in_hom(3) by auto
	+ qed
	+ moreover have "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : \<mu>\<nu>_\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>_\<pi>.chine\<guillemotright>"
	+ using chine_assoc_props(1) C.ide_dom [of chine_assoc]
	+ by (elim C.in_homE, auto)
	+ ultimately show ?thesis
	+ using chine_assoc_props(1) chine_assoc'_props(1)
	+ prj_joint_monic [of "chine_assoc' \<cdot> chine_assoc" "\<mu>\<nu>_\<pi>.chine" "\<mu>\<nu>_\<pi>.chine"]
	+ by auto
	+ qed
	+ thus ?thesis
	+ using 1 by simp
	+ qed
	+ show "C.ide (chine_assoc \<cdot> chine_assoc')"
	+ proof -
	+ have 1: "C.ide \<mu>\<nu>\<pi>.chine"
	+ using chine_assoc_props(1) C.ide_cod by fastforce
	+ have "chine_assoc \<cdot> chine_assoc' = \<mu>\<nu>\<pi>.chine"
	+ proof -
	+ have 2: "C.seq chine_assoc chine_assoc'"
	+ using chine_assoc_props(1) chine_assoc'_props(1) by auto
	+ have 3: "C.seq Prj\<^sub>1 chine_assoc \<and> C.seq Prj\<^sub>1\<^sub>0 chine_assoc \<and> C.seq Prj\<^sub>0\<^sub>0 chine_assoc"
	+ using prj_in_hom chine_assoc_props(1) by auto
	+ have "Prj\<^sub>1 \<cdot> chine_assoc \<cdot> chine_assoc' = Prj\<^sub>1 \<cdot> \<mu>\<nu>\<pi>.chine"
	+ proof -
	+ have "Prj\<^sub>1 \<cdot> chine_assoc \<cdot> chine_assoc' = (Prj\<^sub>1 \<cdot> chine_assoc) \<cdot> chine_assoc'"
	+ using C.comp_assoc by metis
	+ thus ?thesis using 1 C.comp_arr_dom prj_in_hom(4) by auto
	+ qed
	+ moreover have "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine"
	+ proof -
	+ have "Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = (Prj\<^sub>1\<^sub>0 \<cdot> chine_assoc) \<cdot> chine_assoc'"
	+ using C.comp_assoc by metis
	+ thus ?thesis using 1 C.comp_arr_dom by simp
	+ qed
	+ moreover have "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine"
	+ proof -
	+ have "Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc \<cdot> chine_assoc' = (Prj\<^sub>0\<^sub>0 \<cdot> chine_assoc) \<cdot> chine_assoc'"
	+ using C.comp_assoc by metis
	+ thus ?thesis using 1 C.comp_arr_dom by simp
	+ qed
	+ moreover have "\<guillemotleft>\<mu>\<nu>\<pi>.chine : \<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<mu>\<nu>\<pi>.chine\<guillemotright>"
	+ using chine_assoc'_props(1) C.ide_dom [of chine_assoc']
	+ by (elim C.in_homE, auto)
	+ ultimately show ?thesis
	+ using chine_assoc_props(1) chine_assoc'_props(1)
	+ prj'_joint_monic [of "chine_assoc \<cdot> chine_assoc'" "\<mu>\<nu>\<pi>.chine" "\<mu>\<nu>\<pi>.chine"]
	+ by auto
	+ qed
	+ thus ?thesis
	+ using 1 by simp
	+ qed
	+ qed
	+
	+ end
	+
	+ context three_composable_arrows_of_spans
	+ begin
	+
	+ interpretation V: category vcomp
	+ using is_category by auto
	+ interpretation H: horizontal_homs vcomp src trg
	+ using has_horizontal_homs by auto
	+
	+ interpretation dom_\<mu>: arrow_of_spans C \<open>dom \<mu>\<close>
	+ using \<mu>.arrow_of_spans_axioms arr_char [of "dom \<mu>"] by auto
	+ interpretation dom_\<nu>: arrow_of_spans C \<open>dom \<nu>\<close>
	+ using \<nu>.arrow_of_spans_axioms arr_char [of "dom \<nu>"] by auto
	+ interpretation dom_\<pi>: arrow_of_spans C \<open>dom \<pi>\<close>
	+ using \<pi>.arrow_of_spans_axioms arr_char [of "dom \<pi>"] by auto
	+ interpretation doms: three_composable_identity_arrows_of_spans C prj0 prj1
	+ \<open>dom \<mu>\<close> \<open>dom \<nu>\<close> \<open>dom \<pi>\<close>
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable ide_char [of "dom \<mu>"] ide_char [of "dom \<nu>"]
	+ ide_char [of "dom \<pi>"]
	+ by (unfold_locales, auto)
	+
	+ interpretation cod_\<mu>: arrow_of_spans C \<open>cod \<mu>\<close>
	+ using \<mu>.arrow_of_spans_axioms arr_char [of "cod \<mu>"] by auto
	+ interpretation cod_\<nu>: arrow_of_spans C \<open>cod \<nu>\<close>
	+ using \<nu>.arrow_of_spans_axioms arr_char [of "cod \<nu>"] by auto
	+ interpretation cod_\<pi>: arrow_of_spans C \<open>cod \<pi>\<close>
	+ using \<pi>.arrow_of_spans_axioms arr_char [of "cod \<pi>"] by auto
	+ interpretation cods: three_composable_identity_arrows_of_spans C prj0 prj1
	+ \<open>cod \<mu>\<close> \<open>cod \<nu>\<close> \<open>cod \<pi>\<close>
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable ide_char [of "cod \<mu>"] ide_char [of "cod \<nu>"]
	+ ide_char [of "cod \<pi>"]
	+ by (unfold_locales, auto)
	+
	+ interpretation \<mu>\<nu>\<pi>: arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
	+ using \<mu>.arrow_of_spans_axioms \<nu>\<pi>.arrow_of_spans_axioms
	+ arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
	+ by force
	+
	+ interpretation \<mu>\<nu>_\<pi>: arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
	+ using \<mu>\<nu>.arrow_of_spans_axioms \<pi>.arrow_of_spans_axioms
	+ arrow_of_spans_hcomp arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable
	+ by force
	+
	+ lemma chine_composite':
	+ shows "\<mu>\<nu>\<pi>.chine = \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1
	+ \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
	+ \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>\<rangle>"
	+ and "\<mu>\<nu>_\<pi>.chine = \<langle>\<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>
	+ \<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
	+ \<pi>.chine \<cdot> doms.Prj\<^sub>0\<rangle>"
	+ proof -
	+ show "\<mu>\<nu>_\<pi>.chine = \<langle>\<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>
	+ \<lbrakk>\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1\<rbrakk>
	+ \<pi>.chine \<cdot> doms.Prj\<^sub>0\<rangle>"
	+ proof -
	+ have "arr (\<mu> \<star> \<nu>)" by simp
	+ thus ?thesis
	+ unfolding hcomp_def chine_hcomp_def dom_char
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char chine_hcomp_props
	+ C.comp_tuple_arr C.pullback_commutes C.comp_assoc
	+ by auto
	+ qed
	+ show "\<mu>\<nu>\<pi>.chine = \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1
	+ \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rbrakk>
	+ \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>\<rangle>"
	+ proof -
	+ have "arr (\<nu> \<star> \<pi>)" by simp
	+ thus ?thesis
	+ unfolding hcomp_def chine_hcomp_def dom_char
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char chine_hcomp_props
	+ C.comp_tuple_arr C.pullback_commutes C.comp_assoc
	+ by auto
	+ qed
	+ qed
	+
	+ lemma chine_composite_in_hom [intro]:
	+ shows "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn ((cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>)\<guillemotright>"
	+ and "\<guillemotleft>\<mu>\<nu>\<pi>.chine : Chn (dom \<mu> \<star> dom \<nu> \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
	+ proof -
	+ interpret \<mu>\<nu>: arrow_of_spans C \<open>\<mu> \<star> \<nu>\<close>
	+ using arrow_of_spans_hcomp \<mu>\<nu>.composable by auto
	+ interpret \<nu>\<pi>: arrow_of_spans C \<open>\<nu> \<star> \<pi>\<close>
	+ using arrow_of_spans_hcomp \<nu>\<pi>.composable by auto
	+ show "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn ((cod \<mu> \<star> cod \<nu>) \<star> cod \<pi>)\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : \<mu>\<nu>.dom.leg0 \<down>\<down> \<pi>.dom.leg1 \<rightarrow>\<^sub>C \<mu>\<nu>.cod.leg0 \<down>\<down> \<pi>.cod.leg1\<guillemotright>"
	+ proof -
	+ have "src (\<mu> \<star> \<nu>) = trg \<pi>"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
	+ moreover have "arr (\<mu> \<star> \<nu>)"
	+ using \<mu>\<nu>.arrow_of_spans_axioms by auto
	+ ultimately show ?thesis
	+ using hcomp_def chine_hcomp_props(1) [of \<pi> "\<mu> \<star> \<nu>"] by auto
	+ qed
	+ hence "\<guillemotleft>\<mu>\<nu>_\<pi>.chine : \<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1] \<down>\<down> \<pi>.dom.leg1 \<rightarrow>\<^sub>C
	+ \<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1] \<down>\<down> \<pi>.cod.leg1\<guillemotright>"
	+ unfolding hcomp_def using \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
	+ thus ?thesis
	+ using doms.chine_composite(1) cods.chine_composite(1) dom_char cod_char
	+ by auto
	+ qed
	+ show "\<guillemotleft>\<mu>\<nu>\<pi>.chine : Chn (dom \<mu> \<star> dom \<nu> \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>\<mu>\<nu>\<pi>.chine : \<mu>.dom.leg0 \<down>\<down> \<nu>\<pi>.dom.leg1 \<rightarrow>\<^sub>C \<mu>.cod.leg0 \<down>\<down> \<nu>\<pi>.cod.leg1\<guillemotright>"
	+ proof -
	+ have "src \<mu> = trg (\<nu> \<star> \<pi>)"
	+ using trg_hcomp \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
	+ moreover have "arr (\<nu> \<star> \<pi>)"
	+ using \<mu>\<nu>.arrow_of_spans_axioms by auto
	+ ultimately show ?thesis
	+ using hcomp_def chine_hcomp_props(1) [of "\<nu> \<star> \<pi>" \<mu>] by auto
	+ qed
	+ hence "\<guillemotleft>\<mu>\<nu>\<pi>.chine : \<mu>.dom.leg0 \<down>\<down> \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1] \<rightarrow>\<^sub>C
	+ \<mu>.cod.leg0 \<down>\<down> \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<guillemotright>"
	+ unfolding hcomp_def \<mu>\<nu>.composable \<nu>\<pi>.composable by simp
	+ thus ?thesis
	+ using doms.chine_composite(2) cods.chine_composite(2) dom_char cod_char
	+ by auto
	+ qed
	+ qed
	+
	+ lemma cospan_\<mu>\<nu>:
	+ shows "C.cospan \<mu>.dom.leg0 \<nu>.dom.leg1"
	+ using \<mu>\<nu>.legs_form_cospan by simp
	+
	+ lemma cospan_\<nu>\<pi>:
	+ shows "C.cospan \<nu>.dom.leg0 \<pi>.dom.leg1"
	+ using \<nu>\<pi>.legs_form_cospan by simp
	+
	+ lemma commutativities:
	+ shows "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
	+ and "\<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0 =
	+ (\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
	+ \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>"
	+ proof -
	+ have AB: "\<mu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>1 = \<nu>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>1"
	+ proof -
	+ have "\<mu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>1 =
	+ (\<mu>.dom.leg0 \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]) \<cdot>
	+ \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
	+ by simp
	+ also have "... = (\<nu>.dom.leg1 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]) \<cdot>
	+ \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
	+ using C.pullback_commutes' \<mu>\<nu>.legs_form_cospan by auto
	+ also have "... = \<nu>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>1"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
	+ by simp
	+ finally show ?thesis by auto
	+ qed
	+ have BC: "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>0\<^sub>1 = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0"
	+ proof -
	+ have "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>0\<^sub>1 =
	+ (\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]) \<cdot>
	+ \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
	+ by simp
	+ also have "... = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0"
	+ using C.pullback_commutes' dom_char cod_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ show 1: "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
	+ using AB C.comp_assoc [of \<mu>.cod.leg0 \<mu>.chine]
	+ C.comp_assoc [of \<nu>.cod.leg1 \<nu>.chine doms.Prj\<^sub>0\<^sub>1]
	+ by simp
	+ show "\<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0 =
	+ (\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
	+ \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>"
	+ proof -
	+ have "(\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
	+ \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle> =
	+ \<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1] \<cdot>
	+ \<langle>\<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1 \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1\<rangle>"
	+ using 1 \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc by simp
	+ also have "... = \<nu>.cod.leg0 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
	+ using 1 dom_char \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def by simp
	+ also have "... = (\<nu>.cod.leg0 \<cdot> \<nu>.chine) \<cdot> doms.Prj\<^sub>0\<^sub>1"
	+ using C.comp_assoc [of \<nu>.cod.leg0 \<nu>.chine doms.Prj\<^sub>0\<^sub>1] by simp
	+ also have "... = (\<pi>.cod.leg1 \<cdot> \<pi>.chine) \<cdot> doms.Prj\<^sub>0"
	+ using BC by simp
	+ also have "... = \<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0"
	+ using C.comp_assoc by blast
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma prj_chine_composite:
	+ shows "cods.Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine = \<mu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>1"
	+ and "cods.Prj\<^sub>0\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>.chine = \<nu>.chine \<cdot> doms.Prj\<^sub>0\<^sub>1"
	+ and "cods.Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.chine = \<pi>.chine \<cdot> doms.Prj\<^sub>0"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char cod_char commutativities
	+ chine_composite' C.comp_assoc
	+ by auto
	+
	+ lemma commutativities':
	+ shows "\<nu>.cod.leg0 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 = \<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0"
	+ and "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1 =
	+ (\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot>
	+ \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>"
	+ proof -
	+ have AB: "\<mu>.dom.leg0 \<cdot> doms.Prj\<^sub>1 = \<nu>.dom.leg1 \<cdot> doms.Prj\<^sub>1\<^sub>0"
	+ using C.pullback_commutes' dom_char cod_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan
	+ C.comp_assoc
	+ by auto
	+ have BC: "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>0 = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>0"
	+ proof -
	+ have "\<nu>.dom.leg0 \<cdot> doms.Prj\<^sub>1\<^sub>0 =
	+ (\<nu>.dom.leg0 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]) \<cdot>
	+ \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]]"
	+ using dom_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan C.comp_assoc by simp
	+ also have "... = \<pi>.dom.leg1 \<cdot> doms.Prj\<^sub>0\<^sub>0"
	+ using C.pullback_commutes' dom_char \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan C.comp_assoc
	+ by simp
	+ finally show ?thesis by auto
	+ qed
	+ show 1: "\<nu>.cod.leg0 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 = \<pi>.cod.leg1 \<cdot> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0"
	+ using BC C.comp_assoc [of \<nu>.cod.leg0 \<nu>.chine doms.Prj\<^sub>1\<^sub>0]
	+ C.comp_assoc [of \<pi>.cod.leg1 \<pi>.chine doms.Prj\<^sub>0\<^sub>0]
	+ doms.prj_in_hom(5-6) dom_char
	+ by force
	+ show "\<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1 =
	+ (\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot>
	+ \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>"
	+ proof -
	+ have "(\<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot>
	+ \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle> =
	+ \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1] \<cdot>
	+ \<langle>\<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0 \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk> \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0\<rangle>"
	+ using 1 \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc by simp
	+ also have "... = \<nu>.cod.leg1 \<cdot> \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0"
	+ using 1 dom_char \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def
	+ by simp
	+ also have "... = (\<nu>.cod.leg1 \<cdot> \<nu>.chine) \<cdot> doms.Prj\<^sub>1\<^sub>0"
	+ using C.comp_assoc [of \<nu>.cod.leg1 \<nu>.chine doms.Prj\<^sub>1\<^sub>0] by auto
	+ also have "... = (\<mu>.cod.leg0 \<cdot> \<mu>.chine) \<cdot> doms.Prj\<^sub>1"
	+ using AB by simp
	+ also have "... = \<mu>.cod.leg0 \<cdot> \<mu>.chine \<cdot> doms.Prj\<^sub>1"
	+ using C.comp_assoc [of \<mu>.cod.leg0 \<mu>.chine doms.Prj\<^sub>1] doms.prj_in_hom(4) dom_char
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma prj'_chine_composite:
	+ shows "cods.Prj\<^sub>1 \<cdot> \<mu>\<nu>\<pi>.chine = \<mu>.chine \<cdot> doms.Prj\<^sub>1"
	+ and "cods.Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine = \<nu>.chine \<cdot> doms.Prj\<^sub>1\<^sub>0"
	+ and "cods.Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine = \<pi>.chine \<cdot> doms.Prj\<^sub>0\<^sub>0"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable src_def trg_def dom_char cod_char commutativities'
	+ chine_composite' C.comp_assoc
	+ by auto
	+
	+ lemma chine_assoc_naturality:
	+ shows "cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine = \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
	+ proof -
	+ have "\<guillemotleft>cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine :
	+ Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
	+ using cods.chine_assoc_props(1) chine_composite_in_hom(1) by blast
	+ moreover have "\<guillemotleft>\<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc :
	+ Chn ((dom \<mu> \<star> dom \<nu>) \<star> dom \<pi>) \<rightarrow>\<^sub>C Chn (cod \<mu> \<star> cod \<nu> \<star> cod \<pi>)\<guillemotright>"
	+ using doms.chine_assoc_props(1) chine_composite_in_hom(2) by blast
	+ moreover
	+ have "cods.Prj\<^sub>1 \<cdot> cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine =
	+ cods.Prj\<^sub>1 \<cdot> \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
	+ using C.comp_assoc doms.chine_assoc_props(2) cods.chine_assoc_props(2)
	+ prj_chine_composite prj'_chine_composite
	+ by metis
	+ moreover have "cods.Prj\<^sub>1\<^sub>0 \<cdot> cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine =
	+ cods.Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
	+ using C.comp_assoc doms.chine_assoc_props(3) cods.chine_assoc_props(3)
	+ prj_chine_composite prj'_chine_composite
	+ by metis
	+ moreover have "cods.Prj\<^sub>0\<^sub>0 \<cdot> cods.chine_assoc \<cdot> \<mu>\<nu>_\<pi>.chine =
	+ cods.Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine \<cdot> doms.chine_assoc"
	+ using C.comp_assoc doms.chine_assoc_props(4) cods.chine_assoc_props(4)
	+ prj_chine_composite prj'_chine_composite
	+ by metis
	+ ultimately show ?thesis
	+ using cods.prj'_joint_monic by auto
	+ qed
	+
	+ end
	+
	+ context span_bicategory
	+ begin
	+
	+ interpretation VxV: product_category vcomp vcomp ..
	+ interpretation VV: subcategory VxV.comp \<open>\<lambda>\<nu>\<mu>. arr (fst \<nu>\<mu>) \<and> arr (snd \<nu>\<mu>) \<and>
	+ src (fst \<nu>\<mu>) = trg (snd \<nu>\<mu>)\<close>
	+ by (unfold_locales, simp_all)
	+ interpretation VxVxV: product_category vcomp VxV.comp ..
	+ interpretation VVV: subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using subcategory_VVV by auto
	+
	+ interpretation H: horizontal_composition vcomp hcomp src trg
	+ using has_horizontal_composition by auto
	+ interpretation HoHV: "functor" VVV.comp vcomp HoHV
	+ using functor_HoHV by blast
	+ interpretation HoVH: "functor" VVV.comp vcomp HoVH
	+ using functor_HoVH by blast
	+
	+ abbreviation (input) assoc\<^sub>S\<^sub>B
	+ where "assoc\<^sub>S\<^sub>B f g h \<equiv> \<lparr>Chn = three_composable_identity_arrows_of_spans.chine_assoc
	+ C prj0 prj1 f g h,
	+ Dom = Dom ((f \<star> g) \<star> h), Cod = Cod (f \<star> g \<star> h)\<rparr>"
	+
	+ abbreviation (input) assoc'\<^sub>S\<^sub>B
	+ where "assoc'\<^sub>S\<^sub>B f g h \<equiv> \<lparr>Chn = three_composable_identity_arrows_of_spans.chine_assoc'
	+ C prj0 prj1 f g h,
	+ Dom = Cod (f \<star> g \<star> h), Cod = Dom ((f \<star> g) \<star> h)\<rparr>"
	+
	+ lemma assoc_props:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "src (assoc\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc\<^sub>S\<^sub>B f g h) = trg f"
	+ and "\<guillemotleft>assoc\<^sub>S\<^sub>B f g h : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
	+ and "src (assoc'\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc'\<^sub>S\<^sub>B f g h) = trg f"
	+ and "\<guillemotleft>assoc'\<^sub>S\<^sub>B f g h : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
	+ proof -
	+ have fgh: "VVV.ide (f, g, h)"
	+ using assms VVV.ide_char VV.ide_char VVV.arr_char VV.arr_char by simp
	+ interpret f: arrow_of_spans C f
	+ using assms arr_char by fastforce
	+ interpret g: arrow_of_spans C g
	+ using assms arr_char by fastforce
	+ interpret h: arrow_of_spans C h
	+ using assms arr_char by fastforce
	+ interpret fgh: three_composable_arrows_of_spans C prj0 prj1 f g h
	+ using assms arr_char by (unfold_locales, auto)
	+ interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1 f g h
	+ using assms ide_char by (unfold_locales, auto)
	+ interpret HHfgh: arrow_of_spans C \<open>(f \<star> g) \<star> h\<close>
	+ using assms fgh.composites_are_arrows arrow_of_spans_hcomp by simp
	+ interpret HfHgh: arrow_of_spans C \<open>f \<star> g \<star> h\<close>
	+ using assms fgh.composites_are_arrows arrow_of_spans_hcomp by simp
	+ interpret assoc_fgh: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B f g h\<close>
	+ apply unfold_locales
	+ apply simp_all
	+ apply (metis C.ideD(2) C.ideD(3) HHfgh.chine_simps(2) HfHgh.chine_simps(3)
	+ fgh.composites_are_identities(1) fgh.composites_are_identities(2)
	+ fgh.chine_assoc_in_hom ide_char)
	+ proof -
	+ have 1: "arr (f \<star> g)" using fgh.\<mu>\<nu>.composite_is_arrow by simp
	+ have 2: "arr (g \<star> h)" using fgh.\<nu>\<pi>.composite_is_arrow by simp
	+ show "HfHgh.cod.leg0 \<cdot> fgh.chine_assoc = HHfgh.dom.leg0"
	+ using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
	+ fgh.chine_assoc_props(4) C.comp_assoc
	+ by simp
	+ show "HfHgh.cod.leg1 \<cdot> fgh.chine_assoc = HHfgh.dom.leg1"
	+ using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
	+ fgh.chine_assoc_props(2) C.comp_assoc
	+ by simp
	+ qed
	+ interpret assoc'_fgh: arrow_of_spans C \<open>assoc'\<^sub>S\<^sub>B f g h\<close>
	+ apply unfold_locales
	+ apply simp_all
	+ apply (metis C.ideD(2) C.ideD(3) HHfgh.chine_simps(2) HfHgh.chine_simps(3)
	+ fgh.composites_are_identities(1) fgh.composites_are_identities(2)
	+ fgh.chine_assoc'_in_hom ide_char)
	+ proof -
	+ have 1: "arr (f \<star> g)" using fgh.\<mu>\<nu>.composite_is_arrow by simp
	+ have 2: "arr (g \<star> h)" using fgh.\<nu>\<pi>.composite_is_arrow by simp
	+ show "HHfgh.dom.leg0 \<cdot> fgh.chine_assoc' = HfHgh.cod.leg0"
	+ using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
	+ C.comp_assoc fgh.chine_assoc'_props(4)
	+ by simp
	+ show "HHfgh.dom.leg1 \<cdot> fgh.chine_assoc' = HfHgh.cod.leg1"
	+ using 1 2 hcomp_def src_def trg_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable
	+ C.comp_assoc fgh.chine_assoc'_props(2)
	+ by auto
	+ qed
	+ show 1: "\<guillemotleft>assoc\<^sub>S\<^sub>B f g h : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
	+ proof
	+ show 1: "arr (assoc\<^sub>S\<^sub>B f g h)"
	+ using assoc_fgh.arrow_of_spans_axioms arr_char by blast
	+ show "dom (assoc\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
	+ using fgh 1 dom_char fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable ideD(2)
	+ by auto
	+ show "cod (assoc\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
	+ using fgh 1 HoVH_def cod_char fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable ideD(3)
	+ by auto
	+ qed
	+ show 2: "\<guillemotleft>assoc'\<^sub>S\<^sub>B f g h : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright>"
	+ proof
	+ show 1: "arr (assoc'\<^sub>S\<^sub>B f g h)"
	+ using assoc'_fgh.arrow_of_spans_axioms arr_char by blast
	+ show "dom (assoc'\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
	+ using fgh 1 dom_char cod_char ideD(3) by auto
	+ show "cod (assoc'\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
	+ using fgh 1 cod_char dom_char ideD(2) by auto
	+ qed
	+ show 3: "src (assoc\<^sub>S\<^sub>B f g h) = src h"
	+ proof -
	+ have 4: "src (assoc\<^sub>S\<^sub>B f g h) =
	+ \<lparr>Chn = assoc_fgh.dsrc, Dom = \<lparr>Leg0 = assoc_fgh.dsrc, Leg1 = assoc_fgh.dsrc\<rparr>,
	+ Cod = \<lparr>Leg0 = assoc_fgh.dsrc, Leg1 = assoc_fgh.dsrc\<rparr>\<rparr>"
	+ unfolding src_def using 1 by auto
	+ also have "... = src h"
	+ using fgh.composite_simps(2) src_def by auto
	+ finally show ?thesis by blast
	+ qed
	+ show "src (assoc'\<^sub>S\<^sub>B f g h) = src h"
	+ proof -
	+ have "src (assoc'\<^sub>S\<^sub>B f g h) =
	+ \<lparr>Chn = assoc'_fgh.dsrc, Dom = \<lparr>Leg0 = assoc'_fgh.dsrc, Leg1 = assoc'_fgh.dsrc\<rparr>,
	+ Cod = \<lparr>Leg0 = assoc'_fgh.dsrc, Leg1 = assoc'_fgh.dsrc\<rparr>\<rparr>"
	+ unfolding src_def using 2 by auto
	+ also have "... = src h"
	+ using 1 3 assoc_fgh.cod_src_eq_dom_src arrI src_def by auto
	+ finally show ?thesis by blast
	+ qed
	+ show 4: "trg (assoc\<^sub>S\<^sub>B f g h) = trg f"
	+ proof -
	+ have 5: "trg (assoc\<^sub>S\<^sub>B f g h) =
	+ \<lparr>Chn = assoc_fgh.dtrg, Dom = \<lparr>Leg0 = assoc_fgh.dtrg, Leg1 = assoc_fgh.dtrg\<rparr>,
	+ Cod = \<lparr>Leg0 = assoc_fgh.dtrg, Leg1 = assoc_fgh.dtrg\<rparr>\<rparr>"
	+ unfolding trg_def using 1 by auto
	+ also have "... = trg f"
	+ using fgh.composite_simps(4) trg_def by auto
	+ finally show ?thesis by blast
	+ qed
	+ show "trg (assoc'\<^sub>S\<^sub>B f g h) = trg f"
	+ proof -
	+ have 5: "trg (assoc'\<^sub>S\<^sub>B f g h) =
	+ \<lparr>Chn = assoc'_fgh.dtrg, Dom = \<lparr>Leg0 = assoc'_fgh.dtrg, Leg1 = assoc'_fgh.dtrg\<rparr>,
	+ Cod = \<lparr>Leg0 = assoc'_fgh.dtrg, Leg1 = assoc'_fgh.dtrg\<rparr>\<rparr>"
	+ unfolding trg_def using 2 by auto
	+ also have "... = trg f"
	+ using 1 4 assoc_fgh.cod_trg_eq_dom_trg arrI trg_def by auto
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+
	+ lemma assoc_in_hom [intro]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "\<guillemotleft>assoc\<^sub>S\<^sub>B f g h : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright> "
	+ using assms assoc_props by auto
	+
	+ lemma assoc'_in_hom [intro]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "\<guillemotleft>assoc'\<^sub>S\<^sub>B f g h : f \<star> g \<star> h \<Rightarrow> (f \<star> g) \<star> h\<guillemotright> "
	+ using assms assoc_props by auto
	+
	+ lemma assoc_simps [simp]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "arr (assoc\<^sub>S\<^sub>B f g h)" and "dom (assoc\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
	+ and "cod (assoc\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
	+ and "src (assoc\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc\<^sub>S\<^sub>B f g h) = trg f"
	+ using assms assoc_props(1-3) by (fast, fast, fast, auto)
	+
	+ lemma assoc'_simps [simp]:
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "arr (assoc'\<^sub>S\<^sub>B f g h)" and "dom (assoc'\<^sub>S\<^sub>B f g h) = f \<star> g \<star> h"
	+ and "cod (assoc'\<^sub>S\<^sub>B f g h) = (f \<star> g) \<star> h"
	+ and "src (assoc'\<^sub>S\<^sub>B f g h) = src h" and "trg (assoc'\<^sub>S\<^sub>B f g h) = trg f"
	+ using assms assoc_props(4-6) by (fast, fast, fast, auto)
	+
	+ lemma inverse_assoc_assoc':
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "inverse_arrows (assoc\<^sub>S\<^sub>B f g h) (assoc'\<^sub>S\<^sub>B f g h)"
	+ proof -
	+ interpret f: arrow_of_spans C f using assms arr_char ideD(1) by simp
	+ interpret g: arrow_of_spans C g using assms arr_char ideD(1) by simp
	+ interpret h: arrow_of_spans C h using assms arr_char ideD(1) by simp
	+ interpret fgh: three_composable_arrows_of_spans C prj0 prj1 f g h
	+ using assms arr_char by (unfold_locales, auto)
	+ interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1 f g h
	+ using assms ide_char
	+ apply unfold_locales
	+ apply blast
	+ apply blast
	+ by blast
	+ interpret afgh: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B f g h\<close>
	+ using assms assoc_props(3) arr_char by blast
	+ interpret a'fgh: arrow_of_spans C \<open>assoc'\<^sub>S\<^sub>B f g h\<close>
	+ using assms assoc_props(6) arr_char by blast
	+ show ?thesis
	+ proof -
	+ have "inverse_arrows (assoc\<^sub>S\<^sub>B f g h)
	+ \<lparr>Chn = C.inv (Chn (assoc\<^sub>S\<^sub>B f g h)),
	+ Dom = Cod (assoc\<^sub>S\<^sub>B f g h), Cod = Dom (assoc\<^sub>S\<^sub>B f g h)\<rparr>"
	+ using inverse_arrows [of "assoc\<^sub>S\<^sub>B f g h"] afgh.arrow_of_spans_axioms
	+ arr_char fgh.chine_assoc_inverse
	+ by auto
	+ moreover have "C.inv (Chn (assoc\<^sub>S\<^sub>B f g h)) = fgh.chine_assoc'"
	+ using fgh.chine_assoc_inverse C.inv_is_inverse C.inverse_arrow_unique by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ qed
	+
	+ interpretation \<alpha>: transformation_by_components VVV.comp vcomp HoHV HoVH
	+ \<open>\<lambda>fgh. assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))\<close>
	+ proof
	+ show *: "\<And>fgh. VVV.ide fgh \<Longrightarrow> \<guillemotleft>assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh)) :
	+ HoHV fgh \<Rightarrow> HoVH fgh\<guillemotright>"
	+ proof -
	+ fix fgh
	+ assume fgh: "VVV.ide fgh"
	+ show "\<guillemotleft>assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh)) : HoHV fgh \<Rightarrow> HoVH fgh\<guillemotright>"
	+ unfolding HoHV_def HoVH_def
	+ using fgh assoc_in_hom [of "fst fgh" "fst (snd fgh)" "snd (snd fgh)"]
	+ VVV.arr_char VVV.ide_char VV.arr_char
	+ by simp
	+ qed
	+ show "\<And>\<mu>\<nu>\<pi>. VVV.arr \<mu>\<nu>\<pi> \<Longrightarrow>
	+ assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
	+ (snd (snd (VVV.cod \<mu>\<nu>\<pi>))) \<bullet>
	+ HoHV \<mu>\<nu>\<pi> =
	+ HoVH \<mu>\<nu>\<pi> \<bullet> assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
	+ (snd (snd (VVV.dom \<mu>\<nu>\<pi>)))"
	+ proof -
	+ fix \<mu>\<nu>\<pi>
	+ assume \<mu>\<nu>\<pi>: "VVV.arr \<mu>\<nu>\<pi>"
	+ interpret \<mu>: arrow_of_spans C \<open>fst \<mu>\<nu>\<pi>\<close>
	+ using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char arr_char by auto
	+ interpret \<nu>: arrow_of_spans C \<open>fst (snd \<mu>\<nu>\<pi>)\<close>
	+ using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
	+ interpret \<pi>: arrow_of_spans C \<open>snd (snd \<mu>\<nu>\<pi>)\<close>
	+ using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
	+ interpret \<mu>\<nu>\<pi>: three_composable_arrows_of_spans C prj0 prj1
	+ \<open>fst \<mu>\<nu>\<pi>\<close> \<open>fst (snd \<mu>\<nu>\<pi>)\<close> \<open>snd (snd \<mu>\<nu>\<pi>)\<close>
	+ using \<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char arr_char
	+ by (unfold_locales, auto)
	+
	+ interpret HoHV_\<mu>\<nu>\<pi>: arrow_of_spans C \<open>(fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>)) \<star> snd (snd \<mu>\<nu>\<pi>)\<close>
	+ proof -
	+ have "arr (HoHV \<mu>\<nu>\<pi>)"
	+ using \<mu>\<nu>\<pi> by simp
	+ thus "arrow_of_spans C ((fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>)) \<star> snd (snd \<mu>\<nu>\<pi>))"
	+ using \<mu>\<nu>\<pi> HoHV_def arr_char by auto
	+ qed
	+ interpret HoVH_\<mu>\<nu>\<pi>: arrow_of_spans C \<open>fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>) \<star> snd (snd \<mu>\<nu>\<pi>)\<close>
	+ proof -
	+ have "arr (HoVH \<mu>\<nu>\<pi>)"
	+ using \<mu>\<nu>\<pi> by simp
	+ thus "arrow_of_spans C (fst \<mu>\<nu>\<pi> \<star> fst (snd \<mu>\<nu>\<pi>) \<star> snd (snd \<mu>\<nu>\<pi>))"
	+ using \<mu>\<nu>\<pi> HoVH_def arr_char by auto
	+ qed
	+
	+ have dom_\<mu>\<nu>\<pi>: "VVV.ide (VVV.dom \<mu>\<nu>\<pi>)"
	+ using \<mu>\<nu>\<pi> VVV.ide_dom by blast
	+ interpret dom_\<mu>: identity_arrow_of_spans C \<open>fst (VVV.dom \<mu>\<nu>\<pi>)\<close>
	+ using dom_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
	+ interpret dom_\<nu>: identity_arrow_of_spans C \<open>fst (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
	+ using dom_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
	+ interpret dom_\<pi>: identity_arrow_of_spans C \<open>snd (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
	+ using dom_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
	+ interpret dom_\<mu>\<nu>\<pi>: three_composable_identity_arrows_of_spans C prj0 prj1
	+ \<open>fst (VVV.dom \<mu>\<nu>\<pi>)\<close> \<open>fst (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
	+ \<open>snd (snd (VVV.dom \<mu>\<nu>\<pi>))\<close>
	+ using dom_\<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char
	+ by (unfold_locales, auto)
	+ interpret assoc_dom_\<mu>\<nu>\<pi>: arrow_of_spans C
	+ \<open>assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
	+ (snd (snd (VVV.dom \<mu>\<nu>\<pi>)))\<close>
	+ using \<mu>\<nu>\<pi> VVV.ide_dom * arr_char by fast
	+
	+ have cod_\<mu>\<nu>\<pi>: "VVV.ide (VVV.cod \<mu>\<nu>\<pi>)"
	+ using \<mu>\<nu>\<pi> VVV.ide_cod by blast
	+ interpret cod_\<mu>: identity_arrow_of_spans C \<open>fst (VVV.cod \<mu>\<nu>\<pi>)\<close>
	+ using cod_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
	+ interpret cod_\<nu>: identity_arrow_of_spans C \<open>fst (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
	+ using cod_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
	+ interpret cod_\<pi>: identity_arrow_of_spans C \<open>snd (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
	+ using cod_\<mu>\<nu>\<pi> VVV.ide_char VV.ide_char ide_char' by blast
	+ interpret cod_\<mu>\<nu>\<pi>: three_composable_identity_arrows_of_spans C prj0 prj1
	+ \<open>fst (VVV.cod \<mu>\<nu>\<pi>)\<close> \<open>fst (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
	+ \<open>snd (snd (VVV.cod \<mu>\<nu>\<pi>))\<close>
	+ using cod_\<mu>\<nu>\<pi> VVV.ide_char VVV.arr_char VV.arr_char
	+ by (unfold_locales, auto)
	+ interpret assoc_cod_\<mu>\<nu>\<pi>: arrow_of_spans C
	+ \<open>assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
	+ (snd (snd (VVV.cod \<mu>\<nu>\<pi>)))\<close>
	+ using \<mu>\<nu>\<pi> VVV.ide_cod * arr_char by fast
	+
	+ have dom_legs:
	+ "dom_\<mu>.leg0 = \<mu>.dom.leg0 \<and> dom_\<nu>.leg0 = \<nu>.dom.leg0 \<and> dom_\<pi>.leg0 = \<pi>.dom.leg0 \<and>
	+ dom_\<mu>.leg1 = \<mu>.dom.leg1 \<and> dom_\<nu>.leg1 = \<nu>.dom.leg1 \<and> dom_\<pi>.leg1 = \<pi>.dom.leg1"
	+ using VVV.arr_char VVV.dom_char dom_char \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable
	+ by auto
	+ have cod_legs:
	+ "cod_\<mu>.leg0 = \<mu>.cod.leg0 \<and> cod_\<nu>.leg0 = \<nu>.cod.leg0 \<and> cod_\<pi>.leg0 = \<pi>.cod.leg0 \<and>
	+ cod_\<mu>.leg1 = \<mu>.cod.leg1 \<and> cod_\<nu>.leg1 = \<nu>.cod.leg1 \<and> cod_\<pi>.leg1 = \<pi>.cod.leg1"
	+ using \<mu>\<nu>\<pi> VVV.cod_char cod_char by auto
	+
	+ have Prj\<^sub>1\<^sub>1_dom: "dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 =
	+ \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1] \<cdot>
	+ \<p>\<^sub>1[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
	+ using dom_legs by argo
	+ have Prj\<^sub>1\<^sub>1_cod: "cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 =
	+ \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1] \<cdot>
	+ \<p>\<^sub>1[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1]"
	+ using cod_legs by argo
	+ have Prj\<^sub>0_dom: "dom_\<mu>\<nu>\<pi>.Prj\<^sub>0 = \<p>\<^sub>0[\<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1], \<pi>.dom.leg1]"
	+ using dom_legs by argo
	+ have Prj\<^sub>0_cod: "cod_\<mu>\<nu>\<pi>.Prj\<^sub>0 = \<p>\<^sub>0[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1]"
	+ using cod_legs by argo
	+
	+ have Dom: "Dom ((fst (VVV.dom \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.dom \<mu>\<nu>\<pi>))) \<star>
	+ snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
	+ \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>"
	+ proof -
	+ have "arr (dom (fst \<mu>\<nu>\<pi>) \<star> dom (fst (snd \<mu>\<nu>\<pi>)))"
	+ using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
	+ thus ?thesis
	+ using \<mu>\<nu>\<pi> hcomp_def dom_legs ide_dom dom_char
	+ apply simp
	+ using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
	+ by auto
	+ qed
	+ have Cod: "Cod (fst (VVV.dom \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.dom \<mu>\<nu>\<pi>)) \<star>
	+ snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
	+ \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>"
	+ proof -
	+ have "arr (dom (fst (snd \<mu>\<nu>\<pi>)) \<star> dom (snd (snd \<mu>\<nu>\<pi>)))"
	+ using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
	+ thus ?thesis
	+ using \<mu>\<nu>\<pi> hcomp_def dom_legs ide_dom dom_char
	+ apply simp
	+ using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_char C.comp_assoc
	+ by auto
	+ qed
	+ have Dom': "Dom ((fst (VVV.cod \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.cod \<mu>\<nu>\<pi>))) \<star>
	+ snd (snd (VVV.cod \<mu>\<nu>\<pi>))) =
	+ \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>"
	+ proof -
	+ have "arr (cod (fst \<mu>\<nu>\<pi>) \<star> cod (fst (snd \<mu>\<nu>\<pi>)))"
	+ using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
	+ moreover have "\<mu>.dsrc = \<nu>.dtrg"
	+ using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable src_def trg_def cod_char by simp
	+ moreover have "\<nu>.dsrc = \<pi>.dtrg"
	+ using \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def cod_char by simp
	+ ultimately show ?thesis
	+ using \<mu>\<nu>\<pi> hcomp_def cod_legs ide_cod cod_char
	+ apply simp
	+ using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def cod_char C.comp_assoc
	+ by simp
	+ qed
	+ have Cod': "Cod (fst (VVV.cod \<mu>\<nu>\<pi>) \<star> fst (snd (VVV.cod \<mu>\<nu>\<pi>)) \<star>
	+ snd (snd (VVV.cod \<mu>\<nu>\<pi>))) =
	+ \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>"
	+ proof -
	+ have "arr (cod (fst (snd \<mu>\<nu>\<pi>)) \<star> cod (snd (snd \<mu>\<nu>\<pi>)))"
	+ using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable by simp
	+ moreover have "\<mu>.dsrc = \<nu>.dtrg"
	+ using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable src_def trg_def cod_char by simp
	+ ultimately show ?thesis
	+ using \<mu>\<nu>\<pi> hcomp_def cod_legs ide_cod cod_char
	+ apply simp
	+ using \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def cod_char C.comp_assoc
	+ by auto
	+ qed
	+
	+ have assoc_dom:
	+ "assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
	+ (snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
	+ \<lparr>Chn = dom_\<mu>\<nu>\<pi>.chine_assoc,
	+ Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
	+ Cod = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
	+ using Dom Cod by simp
	+ have assoc_cod:
	+ "assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
	+ (snd (snd (VVV.cod \<mu>\<nu>\<pi>))) =
	+ \<lparr>Chn = cod_\<mu>\<nu>\<pi>.chine_assoc,
	+ Dom = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
	+ Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
	+ using Dom' Cod' by simp
	+ have HoHV_\<mu>\<nu>\<pi>:
	+ "HoHV \<mu>\<nu>\<pi> =
	+ \<lparr>Chn = HoHV_\<mu>\<nu>\<pi>.chine,
	+ Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
	+ Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>\<rparr>"
	+ proof -
	+ have "arr \<lparr>Chn = \<langle>\<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]
	+ \<lbrakk>\<mu>.cod.leg0, \<nu>.cod.leg1\<rbrakk>
	+ \<nu>.chine \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rangle>,
	+ Dom = \<lparr>Leg0 = \<nu>.dom.leg0 \<cdot> \<p>\<^sub>0[\<mu>.dom.leg0, \<nu>.dom.leg1],
	+ Leg1 = \<mu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<mu>.dom.leg0, \<nu>.dom.leg1]\<rparr>,
	+ Cod = \<lparr>Leg0 = \<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1],
	+ Leg1 = \<mu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1]\<rparr>\<rparr>"
	+ unfolding hcomp_def chine_hcomp_def
	+ using \<mu>\<nu>\<pi> hcomp_def dom_legs cod_legs ide_dom ide_cod dom_char cod_char
	+ \<mu>\<nu>\<pi>.\<mu>\<nu>.composable
	+ by (metis (no_types, lifting) hseq_char(1) \<mu>\<nu>\<pi>.\<mu>\<nu>.composite_is_arrow chine_hcomp_def)
	+ moreover have "(\<mu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1]) \<cdot>
	+ \<p>\<^sub>1[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1] =
	+ \<mu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<mu>.cod.leg0, \<nu>.cod.leg1] \<cdot>
	+ \<p>\<^sub>1[\<nu>.cod.leg0 \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1], \<pi>.cod.leg1]"
	+ using C.comp_assoc by simp
	+ ultimately show ?thesis
	+ unfolding HoHV_def hcomp_def chine_hcomp_def
	+ using \<mu>\<nu>\<pi> \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_legs cod_legs
	+ C.comp_assoc
	+ by simp
	+ qed
	+ have HoVH_\<mu>\<nu>\<pi>:
	+ "HoVH \<mu>\<nu>\<pi> =
	+ \<lparr>Chn = HoVH_\<mu>\<nu>\<pi>.chine,
	+ Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>,
	+ Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
	+ proof -
	+ have "arr \<lparr>Chn = \<langle>\<nu>.chine \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]
	+ \<lbrakk>\<nu>.cod.leg0, \<pi>.cod.leg1\<rbrakk>
	+ \<pi>.chine \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rangle>,
	+ Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> \<p>\<^sub>0[\<nu>.dom.leg0, \<pi>.dom.leg1],
	+ Leg1 = \<nu>.dom.leg1 \<cdot> \<p>\<^sub>1[\<nu>.dom.leg0, \<pi>.dom.leg1]\<rparr>,
	+ Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<pi>.cod.leg1],
	+ Leg1 = \<nu>.cod.leg1 \<cdot> \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]\<rparr>\<rparr>"
	+ unfolding hcomp_def chine_hcomp_def
	+ using \<mu>\<nu>\<pi> hcomp_def dom_legs cod_legs ide_dom ide_cod dom_char cod_char
	+ \<mu>\<nu>\<pi>.\<nu>\<pi>.composable
	+ by (metis (no_types, lifting) hseq_char \<mu>\<nu>\<pi>.\<nu>\<pi>.composite_is_arrow chine_hcomp_def)
	+ moreover have "(\<pi>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<pi>.cod.leg1]) \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot>
	+ \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]] =
	+ \<pi>.cod.leg0 \<cdot> \<p>\<^sub>0[\<nu>.cod.leg0, \<pi>.cod.leg1] \<cdot> \<p>\<^sub>0[\<mu>.cod.leg0, \<nu>.cod.leg1 \<cdot>
	+ \<p>\<^sub>1[\<nu>.cod.leg0, \<pi>.cod.leg1]]"
	+ using C.comp_assoc by simp
	+ ultimately show ?thesis
	+ unfolding HoVH_def hcomp_def chine_hcomp_def
	+ using \<mu>\<nu>\<pi> \<mu>\<nu>\<pi>.\<mu>\<nu>.composable \<mu>\<nu>\<pi>.\<nu>\<pi>.composable src_def trg_def dom_legs cod_legs
	+ C.comp_assoc
	+ by simp
	+ qed
	+ have "assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
	+ (snd (snd (VVV.cod \<mu>\<nu>\<pi>))) \<bullet>
	+ HoHV \<mu>\<nu>\<pi> =
	+ \<lparr>Chn = cod_\<mu>\<nu>\<pi>.chine_assoc \<cdot> HoHV_\<mu>\<nu>\<pi>.chine,
	+ Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
	+ Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
	+ proof -
	+ have "arr (HoHV \<mu>\<nu>\<pi>)"
	+ using \<mu>\<nu>\<pi> by simp
	+ thus ?thesis
	+ using vcomp_def HoHV_\<mu>\<nu>\<pi> HoHV_\<mu>\<nu>\<pi>.arrow_of_spans_axioms
	+ assoc_cod_\<mu>\<nu>\<pi>.arrow_of_spans_axioms assoc_cod dom_legs cod_legs
	+ arr_char
	+ by simp
	+ qed
	+ moreover
	+ have "HoVH \<mu>\<nu>\<pi> \<bullet>
	+ assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
	+ (snd (snd (VVV.dom \<mu>\<nu>\<pi>))) =
	+ \<lparr>Chn = HoVH_\<mu>\<nu>\<pi>.chine \<cdot> dom_\<mu>\<nu>\<pi>.chine_assoc,
	+ Dom = \<lparr>Leg0 = \<pi>.dom.leg0 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>0, Leg1 = \<mu>.dom.leg1 \<cdot> dom_\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1\<rparr>,
	+ Cod = \<lparr>Leg0 = \<pi>.cod.leg0 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0, Leg1 = \<mu>.cod.leg1 \<cdot> cod_\<mu>\<nu>\<pi>.Prj\<^sub>1\<rparr>\<rparr>"
	+ proof -
	+ have "arr (HoVH \<mu>\<nu>\<pi>)"
	+ using \<mu>\<nu>\<pi> by simp
	+ thus ?thesis
	+ using vcomp_def HoVH_\<mu>\<nu>\<pi> HoVH_\<mu>\<nu>\<pi>.arrow_of_spans_axioms
	+ assoc_dom_\<mu>\<nu>\<pi>.arrow_of_spans_axioms assoc_dom dom_legs cod_legs
	+ arr_char
	+ by simp
	+ qed
	+ moreover
	+ have "cod_\<mu>\<nu>\<pi>.chine_assoc \<cdot> HoHV_\<mu>\<nu>\<pi>.chine = HoVH_\<mu>\<nu>\<pi>.chine \<cdot> dom_\<mu>\<nu>\<pi>.chine_assoc"
	+ using \<mu>\<nu>\<pi> HoHV_def HoVH_def \<mu>\<nu>\<pi>.chine_assoc_naturality by simp
	+ ultimately show "assoc\<^sub>S\<^sub>B (fst (VVV.cod \<mu>\<nu>\<pi>)) (fst (snd (VVV.cod \<mu>\<nu>\<pi>)))
	+ (snd (snd (VVV.cod \<mu>\<nu>\<pi>))) \<bullet>
	+ HoHV \<mu>\<nu>\<pi> =
	+ HoVH \<mu>\<nu>\<pi> \<bullet>
	+ assoc\<^sub>S\<^sub>B (fst (VVV.dom \<mu>\<nu>\<pi>)) (fst (snd (VVV.dom \<mu>\<nu>\<pi>)))
	+ (snd (snd (VVV.dom \<mu>\<nu>\<pi>)))"
	+ by argo
	+ qed
	+ qed
	+
	+ definition assoc ("\<a>[_, _, _]")
	+ where "assoc \<equiv> \<lambda>\<mu> \<nu> \<pi>. \<alpha>.map (\<mu>, \<nu>, \<pi>)"
	+
	+ abbreviation (input) \<alpha>\<^sub>S\<^sub>B
	+ where "\<alpha>\<^sub>S\<^sub>B \<equiv> \<lambda>\<mu>\<nu>\<pi>. assoc (fst \<mu>\<nu>\<pi>) (fst (snd \<mu>\<nu>\<pi>)) (snd (snd \<mu>\<nu>\<pi>))"
	+
	+ lemma \<alpha>_ide:
	+ assumes "ide f" and "ide g" and "ide h"
	+ and "src f = trg g" and "src g = trg h"
	+ shows "\<alpha>\<^sub>S\<^sub>B (f, g, h) = assoc\<^sub>S\<^sub>B f g h"
	+ using assms assoc_def \<alpha>.map_simp_ide VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char
	+ by simp
	+
	+ lemma natural_transformation_\<alpha>:
	+ shows "natural_transformation VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B"
	+ using assoc_def \<alpha>.natural_transformation_axioms by auto
	+
	+ interpretation \<alpha>: natural_transformation VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B
	+ using natural_transformation_\<alpha> by simp
	+
	+ interpretation \<alpha>: natural_isomorphism VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B
	+ proof
	+ show "\<And>fgh. VVV.ide fgh \<Longrightarrow> iso (\<alpha>\<^sub>S\<^sub>B fgh)"
	+ proof -
	+ fix fgh
	+ assume fgh: "VVV.ide fgh"
	+ interpret f: arrow_of_spans C \<open>fst fgh\<close>
	+ using fgh VVV.ide_char VVV.arr_char arr_char by auto
	+ interpret g: arrow_of_spans C \<open>fst (snd fgh)\<close>
	+ using fgh VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
	+ interpret h: arrow_of_spans C \<open>snd (snd fgh)\<close>
	+ using fgh VVV.ide_char VVV.arr_char VV.arr_char arr_char by auto
	+ interpret fgh: three_composable_arrows_of_spans C prj0 prj1
	+ \<open>fst fgh\<close> \<open>fst (snd fgh)\<close> \<open>snd (snd fgh)\<close>
	+ using fgh VVV.ide_char VVV.arr_char VV.arr_char arr_char
	+ by (unfold_locales, auto)
	+ interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1
	+ \<open>fst fgh\<close> \<open>fst (snd fgh)\<close> \<open>snd (snd fgh)\<close>
	+ using fgh VVV.ide_char VV.ide_char ide_char
	+ apply unfold_locales
	+ apply blast
	+ apply blast
	+ by blast
	+ have 1: "arr (\<alpha>\<^sub>S\<^sub>B fgh)"
	+ using fgh \<alpha>.preserves_reflects_arr VVV.ideD(1) by blast
	+ have 2: "\<alpha>\<^sub>S\<^sub>B fgh = assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))"
	+ using fgh assoc_def \<alpha>_ide [of "fst fgh" "fst (snd fgh)" "snd (snd fgh)"]
	+ VVV.ide_char VV.ide_char VVV.arr_char VV.arr_char
	+ by simp
	+ moreover have "iso ..."
	+ using 1 2 iso_char [of "assoc\<^sub>S\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))"]
	+ fgh.chine_assoc_inverse by auto
	+ ultimately show "iso (\<alpha>\<^sub>S\<^sub>B fgh)" by argo
	+ qed
	+ qed
	+
	+ lemma natural_isomorphism_\<alpha>:
	+ shows "natural_isomorphism VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B"
	+ ..
	+
	+ end
	+
	+ locale four_composable_arrows_of_spans =
	+ span_bicategory +
	+ \<mu>: arrow_of_spans C \<mu> +
	+ \<nu>: arrow_of_spans C \<nu> +
	+ \<pi>: arrow_of_spans C \<pi> +
	+ \<rho>: arrow_of_spans C \<rho> +
	+ \<mu>\<nu>: two_composable_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
	+ \<nu>\<pi>: two_composable_arrows_of_spans C prj0 prj1 \<nu> \<pi> +
	+ \<pi>\<rho>: two_composable_arrows_of_spans C prj0 prj1 \<pi> \<rho> +
	+ \<mu>\<nu>\<pi>: three_composable_arrows_of_spans C prj0 prj1 \<mu> \<nu> \<pi> +
	+ \<nu>\<pi>\<rho>: three_composable_arrows_of_spans C prj0 prj1 \<nu> \<pi> \<rho>
	+ for \<mu> (structure)
	+ and \<nu> (structure)
	+ and \<pi> (structure)
	+ and \<rho> (structure)
	+
	+ locale four_composable_identity_arrows_of_spans =
	+ four_composable_arrows_of_spans +
	+ \<mu>: identity_arrow_of_spans C \<mu> +
	+ \<nu>: identity_arrow_of_spans C \<nu> +
	+ \<pi>: identity_arrow_of_spans C \<pi> +
	+ \<rho>: identity_arrow_of_spans C \<rho> +
	+ \<mu>\<nu>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> +
	+ \<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<pi> +
	+ \<pi>\<rho>: two_composable_identity_arrows_of_spans C prj0 prj1 \<pi> \<rho> +
	+ \<mu>\<nu>\<pi>: three_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> \<pi> +
	+ \<nu>\<pi>\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<pi> \<rho>
	+ begin
	+
	+ interpretation H: horizontal_composition vcomp hcomp src trg
	+ using has_horizontal_composition by auto
	+
	+ text \<open>
	+ The following interpretations provide us with some systematic names
	+ for a lot of things.
	+ \<close>
	+
	+ interpretation H\<mu>H\<nu>\<pi>: identity_arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi>\<close>
	+ using \<mu>\<nu>\<pi>.composites_are_identities ide_char' by auto
	+ interpretation HH\<mu>\<nu>\<pi>: identity_arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi>\<close>
	+ using \<mu>\<nu>\<pi>.composites_are_identities ide_char' by auto
	+ interpretation H\<nu>H\<pi>\<rho>: identity_arrow_of_spans C \<open>\<nu> \<star> \<pi> \<star> \<rho>\<close>
	+ using \<nu>\<pi>\<rho>.composites_are_identities ide_char' by auto
	+ interpretation HH\<nu>\<pi>\<rho>: identity_arrow_of_spans C \<open>(\<nu> \<star> \<pi>) \<star> \<rho>\<close>
	+ using \<nu>\<pi>\<rho>.composites_are_identities ide_char' by auto
	+
	+ interpretation H\<mu>H\<nu>H\<pi>\<rho>: arrow_of_spans C \<open>\<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<close>
	+ using arrow_of_spans_hcomp \<mu>\<nu>.composable \<nu>\<pi>\<rho>.composites_are_arrows(1) by auto
	+ interpretation H\<mu>HH\<nu>\<pi>\<rho>: arrow_of_spans C \<open>\<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>\<close>
	+ using arrow_of_spans_hcomp \<mu>\<nu>.composable \<nu>\<pi>\<rho>.composites_are_arrows(1) by auto
	+ interpretation HH\<mu>\<nu>H\<pi>\<rho>: arrow_of_spans C \<open>(\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho>\<close>
	+ using hseq_char' match_4 \<mu>\<nu>\<pi>.composites_are_arrows(2) \<pi>\<rho>.composite_is_arrow arr_char
	+ by auto
	+ interpretation HH\<mu>H\<nu>\<pi>\<rho>: arrow_of_spans C \<open>(\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>\<close>
	+ using arrow_of_spans_hcomp \<pi>\<rho>.composable \<mu>\<nu>\<pi>.composites_are_arrows(1) by auto
	+ interpretation HHH\<mu>\<nu>\<pi>\<rho>: arrow_of_spans C \<open>((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho>\<close>
	+ using arrow_of_spans_hcomp \<pi>\<rho>.composable \<mu>\<nu>\<pi>.composites_are_arrows(2) by auto
	+
	+ interpretation assoc\<mu>\<nu>\<pi>: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>\<close>
	+ using arr_char \<mu>\<nu>.composable \<nu>\<pi>.composable assoc_simps(1) by auto
	+ interpretation assoc\<nu>\<pi>\<rho>: arrow_of_spans C \<open>assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>\<close>
	+ using arr_char \<nu>\<pi>.composable \<pi>\<rho>.composable assoc_simps(1) by auto
	+
	+ interpretation \<mu>_\<nu>\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<open>\<nu> \<star> \<pi>\<close>
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable by (unfold_locales, auto)
	+ interpretation \<mu>\<nu>_\<pi>: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<mu> \<star> \<nu>\<close> \<pi>
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable by (unfold_locales, auto)
	+ interpretation \<nu>_\<pi>\<rho>: two_composable_identity_arrows_of_spans C prj0 prj1 \<nu> \<open>\<pi> \<star> \<rho>\<close>
	+ using \<nu>\<pi>.composable \<pi>\<rho>.composable by (unfold_locales, auto)
	+ interpretation \<nu>\<pi>_\<rho>: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<nu> \<star> \<pi>\<close> \<rho>
	+ using \<nu>\<pi>.composable \<pi>\<rho>.composable by (unfold_locales, auto)
	+ (* The two other cases, \<mu>\<nu>\<pi> and \<nu>\<pi>\<rho>, are part of the locale assumptions. *)
	+
	+ interpretation \<mu>_\<nu>\<pi>_\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<open>\<nu> \<star> \<pi>\<close> \<rho> ..
	+ interpretation \<mu>_\<nu>_\<pi>\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<mu> \<nu> \<open>\<pi> \<star> \<rho>\<close> ..
	+ interpretation \<mu>\<nu>_\<pi>_\<rho>: three_composable_identity_arrows_of_spans C prj0 prj1 \<open>\<mu> \<star> \<nu>\<close> \<pi> \<rho> ..
	+
	+ lemma chines_eq:
	+ shows "H\<mu>HH\<nu>\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> HH\<nu>\<pi>\<rho>.leg1"
	+ and "HH\<mu>H\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.cod.leg0 \<down>\<down> \<rho>.leg1"
	+ and "H\<mu>H\<nu>H\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> H\<nu>H\<pi>\<rho>.leg1"
	+ proof -
	+ show "H\<mu>HH\<nu>\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> HH\<nu>\<pi>\<rho>.leg1"
	+ using hcomp_def [of \<mu> "hcomp (hcomp \<nu> \<pi>) \<rho>"] chine_hcomp_ide_ide \<mu>\<nu>.composable
	+ by simp
	+ show "HH\<mu>H\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.cod.leg0 \<down>\<down> \<rho>.leg1"
	+ proof -
	+ have "hseq \<nu> \<pi> \<and> arr \<mu> \<and> src \<mu> = trg (hcomp \<nu> \<pi>)"
	+ using \<mu>_\<nu>\<pi>.are_arrows(1) \<mu>_\<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow by blast
	+ then have "assoc\<mu>\<nu>\<pi>.cod.leg0 = \<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0"
	+ using \<nu>\<pi>.composable by (simp add: hcomp_def)
	+ then show ?thesis
	+ by (simp add: \<mu>_\<nu>\<pi>_\<rho>.chine_composite(1))
	+ qed
	+ show "H\<mu>H\<nu>H\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> H\<nu>H\<pi>\<rho>.leg1"
	+ using hcomp_def [of \<mu> "hcomp \<nu> (hcomp \<pi> \<rho>)"] chine_hcomp_ide_ide \<mu>\<nu>.composable
	+ by simp
	+ qed
	+
	+ lemma cospan_\<mu>0_H\<nu>H\<pi>\<rho>1:
	+ shows "C.cospan \<mu>.leg0 H\<nu>H\<pi>\<rho>.leg1"
	+ proof -
	+ have "H\<nu>H\<pi>\<rho>.leg1 = \<nu>.leg1 \<cdot> \<nu>\<pi>\<rho>.Prj\<^sub>1"
	+ using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<nu>\<pi>.composable \<pi>\<rho>.composable
	+ apply auto
	+ by (auto simp add: hcomp_def)
	+ thus ?thesis
	+ using \<mu>\<nu>.legs_form_cospan \<nu>\<pi>.legs_form_cospan \<pi>\<rho>.legs_form_cospan by simp
	+ qed
	+
	+ (* TODO: Better name for this. *)
	+ lemma assoc_in_homs:
	+ shows "\<guillemotleft>\<mu> \<star> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
	+ and "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> : (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
	+ and "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
	+ and "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) : (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
	+ and "\<guillemotleft>assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho>\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<mu> \<star> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable hseqI' by auto
	+ show "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> : (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
	+ using assoc_in_hom \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by simp
	+ show "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>\<guillemotright>"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable hseqI' by auto
	+ show "\<guillemotleft>assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) : (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
	+ by auto
	+ show "\<guillemotleft>assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho> : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> (\<mu> \<star> \<nu>) \<star> \<pi> \<star> \<rho>\<guillemotright>"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
	+ qed
	+
	+ lemma chine_composites:
	+ shows "Chn (\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) = chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)"
	+ and "Chn (assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho>) = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc"
	+ and "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>) = chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ and "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>)) = \<mu>_\<nu>_\<pi>\<rho>.chine_assoc"
	+ and "Chn (assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>) = \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ show "Chn (\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) = chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)"
	+ using hcomp_def [of \<mu> "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>"] chine_hcomp_def [of \<mu> "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>"]
	+ \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
	+ by auto
	+ show "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>) = chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using assoc_in_homs(2-3) hcomp_def
	+ by (metis arrI arrow_of_spans_data.select_convs(1) hseqE)
	+ show "Chn (assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho>) = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc"
	+ using hcomp_def
	+ by (meson arrow_of_spans_data.select_convs(1))
	+ show "Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>)) = \<mu>_\<nu>_\<pi>\<rho>.chine_assoc"
	+ using hcomp_def
	+ by (meson arrow_of_spans_data.select_convs(1))
	+ show "Chn (assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>) = \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using hcomp_def
	+ by (meson arrow_of_spans_data.select_convs(1))
	+ qed
	+
	+ lemma prj_in_homs [intro, simp]:
	+ shows "\<guillemotleft>\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<nu>\<pi>\<rho>.chine\<guillemotright>"
	+ and "\<guillemotleft>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] : H\<mu>H\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
	+ and "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
	+ and "\<guillemotleft>\<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<rho>.chine\<guillemotright>"
	+ and "\<guillemotleft>\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
	+ and "\<guillemotleft>\<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
	+ and "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
	+ and "\<guillemotleft>\<mu>_\<nu>\<pi>.prj\<^sub>0 : H\<mu>H\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<nu>\<pi>.apex\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<nu>\<pi>\<rho>.chine\<guillemotright>"
	+ proof
	+ show "C.cospan \<mu>.leg0 HH\<nu>\<pi>\<rho>.leg1"
	+ using hcomp_def [of "hcomp \<nu> \<pi>" \<rho>] \<mu>_\<nu>\<pi>_\<rho>.cospan_\<mu>\<nu> \<pi>\<rho>.composable \<nu>\<pi>_\<rho>.legs_form_cospan
	+ by auto
	+ show "H\<mu>HH\<nu>\<pi>\<rho>.chine = \<mu>.leg0 \<down>\<down> HH\<nu>\<pi>\<rho>.leg1"
	+ using hcomp_def [of \<mu> "hcomp (hcomp \<nu> \<pi>) \<rho>"] chine_hcomp_ide_ide \<mu>\<nu>.composable
	+ by simp
	+ show "HH\<nu>\<pi>\<rho>.chine = C.dom HH\<nu>\<pi>\<rho>.leg1"
	+ by simp
	+ qed
	+ show "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
	+ proof
	+ show "C.cospan assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1"
	+ using hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] hcomp_def [of \<nu> \<pi>]
	+ by (metis C.cod_comp H\<mu>H\<nu>\<pi>.cod.leg_simps(1) \<nu>\<pi>.cod_simps(2) \<mu>_\<nu>\<pi>.are_arrows(1)
	+ \<mu>_\<nu>\<pi>.composable \<mu>_\<nu>\<pi>_\<rho>.cospan_\<nu>\<pi> \<nu>\<pi>.composite_is_arrow \<rho>.cod_simps(3)
	+ arrow_of_spans_data.select_convs(3) span_data.select_convs(1))
	+ show "HH\<mu>H\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.cod.leg0 \<down>\<down> \<rho>.cod.leg1"
	+ using chines_eq(2) by simp
	+ show "H\<mu>H\<nu>\<pi>.chine = C.dom assoc\<mu>\<nu>\<pi>.cod.leg0"
	+ by auto
	+ qed
	+ show "\<guillemotleft>\<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<rho>.chine\<guillemotright>"
	+ proof
	+ show "C.cospan HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1"
	+ using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable \<mu>\<nu>_\<pi>_\<rho>.cospan_\<mu>\<nu> \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
	+ by simp
	+ show "HHH\<mu>\<nu>\<pi>\<rho>.chine = HH\<mu>\<nu>\<pi>.leg0 \<down>\<down> \<rho>.leg1"
	+ using chine_hcomp_ide_ide hcomp_def [of "hcomp (hcomp \<mu> \<nu>) \<pi>" \<rho>] \<pi>\<rho>.composable
	+ by simp
	+ show "\<rho>.chine = C.dom \<rho>.leg1 " by simp
	+ qed
	+ show "\<guillemotleft>\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
	+ proof
	+ show "C.cospan HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1"
	+ using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable \<mu>\<nu>_\<pi>_\<rho>.cospan_\<mu>\<nu> \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
	+ by simp
	+ show "HHH\<mu>\<nu>\<pi>\<rho>.chine = HH\<mu>\<nu>\<pi>.leg0 \<down>\<down> \<rho>.leg1"
	+ using chine_hcomp_ide_ide hcomp_def [of "hcomp (hcomp \<mu> \<nu>) \<pi>" \<rho>] \<pi>\<rho>.composable
	+ by simp
	+ show "HH\<mu>\<nu>\<pi>.chine = C.dom HH\<mu>\<nu>\<pi>.leg0" by simp
	+ qed
	+ show "\<guillemotleft>\<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] : HH\<mu>H\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
	+ proof
	+ show "C.cospan (\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0) \<rho>.leg1"
	+ using \<mu>_\<nu>\<pi>.prj_in_hom(2) C.seqI' \<mu>_\<nu>\<pi>_\<rho>.cospan_\<nu>\<pi> by auto
	+ show "HH\<mu>H\<nu>\<pi>\<rho>.chine = \<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0 \<down>\<down> \<rho>.leg1"
	+ using chines_eq(2) hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] \<mu>\<nu>.composable by simp
	+ show "H\<mu>H\<nu>\<pi>.chine = C.dom (\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0)"
	+ using \<mu>_\<nu>\<pi>.prj_in_hom(2) hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] chine_hcomp_ide_ide \<mu>\<nu>.composable
	+ by auto
	+ qed
	+ show "\<guillemotleft>\<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>\<pi>.chine\<guillemotright>"
	+ proof
	+ show "C.cospan assoc\<mu>\<nu>\<pi>.dom.leg0 \<rho>.leg1"
	+ using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable \<mu>\<nu>_\<pi>_\<rho>.cospan_\<mu>\<nu> \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
	+ by simp
	+ show "HHH\<mu>\<nu>\<pi>\<rho>.chine = assoc\<mu>\<nu>\<pi>.dom.leg0 \<down>\<down> \<rho>.leg1"
	+ using hcomp_def [of "hcomp (hcomp \<mu> \<nu>) \<pi>" \<rho>] chine_hcomp_ide_ide \<pi>\<rho>.composable
	+ by simp
	+ show "HH\<mu>\<nu>\<pi>.chine = C.dom assoc\<mu>\<nu>\<pi>.dom.leg0"
	+ using assoc\<mu>\<nu>\<pi>.dom.apex_def assoc\<mu>\<nu>\<pi>.chine_in_hom by fastforce
	+ qed
	+ show "\<guillemotleft>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] : H\<mu>H\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C \<mu>.apex\<guillemotright>"
	+ using cospan_\<mu>0_H\<nu>H\<pi>\<rho>1 chine_hcomp_ide_ide hcomp_def [of \<mu> "hcomp \<nu> (hcomp \<pi> \<rho>)"]
	+ \<mu>\<nu>.composable
	+ by auto
	+ show "\<guillemotleft>\<mu>_\<nu>\<pi>.prj\<^sub>0 : H\<mu>H\<nu>\<pi>.chine \<rightarrow>\<^sub>C \<nu>\<pi>.apex\<guillemotright>"
	+ using \<mu>_\<nu>\<pi>.prj_in_hom(2) chine_hcomp_ide_ide hcomp_def [of \<mu> "hcomp \<nu> \<pi>"] \<mu>\<nu>.composable
	+ by simp
	+ qed
	+
	+ lemma chine_in_homs [intro, simp]:
	+ shows "\<guillemotleft>assoc\<mu>\<nu>\<pi>.chine : HH\<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
	+ and "\<guillemotleft>assoc\<nu>\<pi>\<rho>.chine : HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ and "\<guillemotleft>chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ and "\<guillemotleft>chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>H\<nu>\<pi>\<rho>.chine\<guillemotright>"
	+ proof -
	+ show 1: "\<guillemotleft>assoc\<mu>\<nu>\<pi>.chine : HH\<mu>\<nu>\<pi>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>\<pi>.chine\<guillemotright>"
	+ using \<mu>\<nu>\<pi>.chine_assoc_in_hom by simp
	+ show "\<guillemotleft>assoc\<nu>\<pi>\<rho>.chine : HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ using \<nu>\<pi>\<rho>.chine_assoc_in_hom by simp
	+ show "\<guillemotleft>chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) : H\<mu>HH\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<mu>H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ using Chn_in_hom by (metis assoc_in_homs(1) chine_composites(1))
	+ show "\<guillemotleft>chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>H\<nu>\<pi>\<rho>.chine\<guillemotright>"
	+ using Chn_in_hom by (metis assoc_in_homs(3) chine_composites(3))
	+ qed
	+
	+ lemma commutative_squares [intro, simp]:
	+ shows "C.commutative_square \<nu>\<pi>.leg0 \<rho>.leg1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
	+ and "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
	+ and "C.commutative_square \<p>\<^sub>0[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] assoc\<nu>\<pi>\<rho>.chine
	+ (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>0[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
	+ and "C.commutative_square \<p>\<^sub>1[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] \<mu>.chine
	+ (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>1[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
	+ and "C.commutative_square assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1
	+ (assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])
	+ (\<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])"
	+ and "C.commutative_square \<mu>.leg0 (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1
	+ \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
	+ and "C.commutative_square \<mu>.leg0 (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1
	+ \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ proof -
	+ show 1: "C.commutative_square \<nu>\<pi>.leg0 \<rho>.leg1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
	+ proof -
	+ have 1: "C.arr \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 \<and> C.dom \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 = HH\<mu>H\<nu>\<pi>\<rho>.chine \<and>
	+ C.cod \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 = \<rho>.apex"
	+ by (meson C.in_homE \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(3))
	+ hence "(\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0) \<cdot> \<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] = \<rho>.leg1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
	+ by (meson C.prj0_simps_arr C.pullback_commutes')
	+ thus ?thesis
	+ using 1 C.comp_assoc \<nu>\<pi>_\<rho>.legs_form_cospan(1) by simp
	+ qed
	+ show 2: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
	+ proof -
	+ have "\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>\<rho>.leg1] =
	+ \<pi>\<rho>.leg1 \<cdot> \<p>\<^sub>0[\<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0, \<pi>\<rho>.leg1]"
	+ by (metis (no_types) C.category_axioms C.prj0_simps_arr C.pullback_commutes'
	+ category.comp_reduce \<mu>_\<nu>_\<pi>\<rho>.prj_simps(2) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(3))
	+ thus ?thesis
	+ using C.commutative_square_def \<mu>_\<nu>_\<pi>\<rho>.cospan_\<nu>\<pi>
	+ \<mu>_\<nu>_\<pi>\<rho>.prj_simps(2) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(3) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(5) \<mu>_\<nu>_\<pi>\<rho>.prj_simps(6)
	+ \<mu>_\<nu>_\<pi>\<rho>.prj_simps(8) \<nu>.dom.apex_def
	+ by presburger
	+ qed
	+ show "C.commutative_square \<p>\<^sub>0[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] assoc\<nu>\<pi>\<rho>.chine
	+ (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>0[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
	+ using assoc_in_homs(1) chine_hcomp_props(4) [of "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>" \<mu>] hseq_char by blast
	+ show "C.commutative_square \<p>\<^sub>1[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] \<mu>.chine
	+ (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>1[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
	+ using chine_hcomp_props(3) [of "assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>" \<mu>] hseq_char
	+ \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
	+ by auto
	+ show "C.commutative_square assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1
	+ (assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])
	+ (\<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])"
	+ using assoc_in_homs(3) hseq_char chine_hcomp_props(2) by blast
	+ show "C.commutative_square \<mu>.leg0 (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1
	+ \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
	+ proof
	+ show "C.cospan \<mu>.leg0 (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1)"
	+ using HH\<nu>\<pi>\<rho>.dom.leg_simps(1) \<mu>_\<nu>\<pi>_\<rho>.cospan_\<mu>\<nu> C.arrI by fastforce
	+ show "C.span \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
	+ using 1 \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(1) by auto
	+ show "C.dom \<mu>.leg0 = C.cod \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ by simp
	+ show "\<mu>.leg0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 =
	+ (\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
	+ proof -
	+ have "(\<nu>\<pi>.leg1 \<cdot> \<nu>\<pi>_\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> =
	+ \<nu>\<pi>.leg1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
	+ using 1 C.comp_assoc by auto
	+ also have "... = \<mu>.leg0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ using hcomp_def [of \<nu> \<pi>]
	+ by (metis (no_types, lifting) C.comp_assoc C.prj1_simps_arr C.pullback_commutes'
	+ \<open>C.span \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>\<close> C.seqE)
	+ finally show ?thesis by auto
	+ qed
	+ qed
	+ show "C.commutative_square \<mu>.leg0 (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1
	+ \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ proof
	+ show "C.cospan \<mu>.leg0 (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1)"
	+ using C.arrI \<mu>_\<nu>_\<pi>\<rho>.prj_in_hom(4) by auto
	+ show "C.span \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ using 2 by fastforce
	+ thus "C.dom \<mu>.leg0 = C.cod \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1"
	+ using \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu> by simp
	+ show "\<mu>.leg0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 =
	+ (\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ proof -
	+ have "(\<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1) \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
	+ \<nu>.leg1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ using C.comp_assoc by auto
	+ also have "... = \<nu>.leg1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1"
	+ using 2 by simp
	+ also have "... = \<mu>.leg0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1"
	+ using C.pullback_commutes [of \<mu>.leg0 \<nu>.leg1]
	+ by (metis C.comp_assoc C.pullback_commutes' \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu>)
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ qed
	+
	+ lemma chine_pentagon:
	+ shows "Chn ((\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> \<bullet> (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>)) =
	+ Chn (assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>)"
	+ proof -
	+ let ?LHS = "(\<mu> \<star> assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B \<mu> (\<nu> \<star> \<pi>) \<rho> \<bullet> (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi> \<star> \<rho>)"
	+ let ?RHS = "assoc\<^sub>S\<^sub>B \<mu> \<nu> (\<pi> \<star> \<rho>) \<bullet> assoc\<^sub>S\<^sub>B (\<mu> \<star> \<nu>) \<pi> \<rho>"
	+
	+ have LHS_in_hom: "\<guillemotleft>?LHS : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable hseqI' by auto
	+ have RHS_in_hom: "\<guillemotleft>?RHS : ((\<mu> \<star> \<nu>) \<star> \<pi>) \<star> \<rho> \<Rightarrow> \<mu> \<star> \<nu> \<star> \<pi> \<star> \<rho>\<guillemotright>"
	+ using \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable by auto
	+
	+ have "arrow_of_spans (\<cdot>) ?LHS"
	+ using arr_char assoc_in_homs(1) assoc_in_homs(2) assoc_in_homs(3) by blast
	+
	+ have L: "Chn ?LHS = chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ proof -
	+ have "seq (\<mu> \<star> \<lparr>Chn = \<nu>\<pi>\<rho>.chine_assoc, Dom = Dom ((\<nu> \<star> \<pi>) \<star> \<rho>),
	+ Cod = Cod (\<nu> \<star> \<pi> \<star> \<rho>)\<rparr>)
	+ (\<lparr>Chn = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc,
	+ Dom = Dom ((\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>), Cod = Cod (\<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>)\<rparr> \<bullet>
	+ (\<lparr>Chn = \<mu>\<nu>\<pi>.chine_assoc,
	+ Dom = Dom ((\<mu> \<star> \<nu>) \<star> \<pi>), Cod = Cod (\<mu> \<star> \<nu> \<star> \<pi>)\<rparr> \<star> \<rho>))"
	+ by (meson LHS_in_hom arrI)
	+ moreover have "seq \<lparr>Chn = \<mu>_\<nu>\<pi>_\<rho>.chine_assoc,
	+ Dom = Dom ((\<mu> \<star> \<nu> \<star> \<pi>) \<star> \<rho>), Cod = Cod (\<mu> \<star> (\<nu> \<star> \<pi>) \<star> \<rho>)\<rparr>
	+ (\<lparr>Chn = \<mu>\<nu>\<pi>.chine_assoc,
	+ Dom = Dom ((\<mu> \<star> \<nu>) \<star> \<pi>), Cod = Cod (\<mu> \<star> \<nu> \<star> \<pi>)\<rparr> \<star> \<rho>)"
	+ using assoc_in_homs(2) assoc_in_homs(3) by blast
	+ ultimately show ?thesis
	+ using Chn_vcomp chine_composites(1) chine_composites(2) chine_composites(3)
	+ by presburger
	+ qed
	+ have R: "Chn ?RHS = \<mu>_\<nu>_\<pi>\<rho>.chine_assoc \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using Chn_vcomp assoc_in_homs(4) assoc_in_homs(5) seqI' by auto
	+
	+ text \<open>
	+ The outline of the proof is to show that the compositions of \<open>?LHS\<close>
	+ and \<open>?RHS\<close> with the two projections \<open>\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> and
	+ \<open>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> are equal, and then apply \<open>\<nu>\<pi>\<rho>.prj'_joint_monic\<close>.
	+ \<close>
	+
	+ text \<open>
	+ The case for projection \<open>\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> does not have subcases,
	+ so we'll dispatch that one first.
	+ \<close>
	+
	+ have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS = \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
	+ proof -
	+ have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ proof -
	+ have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
	+ \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using L by simp
	+ also have "... = \<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ proof -
	+ have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) =
	+ \<mu>.chine \<cdot> \<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]"
	+ proof -
	+ have "C.commutative_square \<p>\<^sub>1[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] \<mu>.chine
	+ (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>1[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
	+ by blast
	+ thus ?thesis by auto
	+ qed
	+ thus ?thesis
	+ using C.comp_permute [of "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]" "chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)"
	+ \<mu>.chine "\<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]"
	+ "\<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
	+ by blast
	+ qed
	+ also have "... = \<mu>.chine \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using C.comp_reduce [of "\<p>\<^sub>1[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
	+ \<nu>\<pi>_\<rho>.leg1_composite
	+ by fastforce
	+ also have "... = \<mu>.chine \<cdot> \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ proof -
	+ have "\<mu>.chine \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ \<mu>.chine \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using C.comp_assoc by simp
	+ also have "... = \<mu>.chine \<cdot> (\<mu>_\<nu>\<pi>.prj\<^sub>1 \<cdot> assoc\<mu>\<nu>\<pi>.chine) \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
	+ proof -
	+ have "\<p>\<^sub>1[\<nu>\<pi>.leg0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0, \<rho>.leg1] \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
	+ using chine_hcomp_props(6) [of \<rho> "assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>"] hcomp_def [of \<mu> "hcomp \<nu> \<pi>"]
	+ \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
	+ hseq_char assoc_in_homs(3)
	+ by auto
	+ thus ?thesis
	+ using C.comp_assoc by auto
	+ qed
	+ also have "... = \<mu>.chine \<cdot> \<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
	+ using \<mu>\<nu>\<pi>.prj_chine_assoc(1) hcomp_def \<nu>\<pi>.composable by auto
	+ also have "... = \<mu>.chine \<cdot> \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ proof -
	+ have "\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ proof -
	+ have "\<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1] =
	+ (\<p>\<^sub>1[\<mu>.leg0, \<nu>.leg1] \<cdot> \<p>\<^sub>1[\<mu>\<nu>.leg0, \<pi>.leg1]) \<cdot> \<p>\<^sub>1[\<pi>.leg0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>0, \<rho>.leg1]"
	+ proof -
	+ have "\<mu>\<nu>.leg0 = \<nu>.leg0 \<cdot> \<mu>\<nu>.prj\<^sub>0"
	+ using hcomp_def \<mu>\<nu>.composable by simp
	+ moreover have "assoc\<mu>\<nu>\<pi>.dom.leg0 = \<pi>.leg0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>0"
	+ using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ using \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(1) C.comp_assoc by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ using \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(1) hcomp_def [of \<mu> \<nu>] chine_hcomp_ide_ide \<mu>\<nu>.cod.apex_def
	+ \<mu>\<nu>.composable \<mu>_\<nu>_\<pi>\<rho>.cospan_\<mu>\<nu> C.comp_ide_arr
	+ by auto
	+ finally show ?thesis by blast
	+ qed
	+ also have "... = \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
	+ proof -
	+ have "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS =
	+ \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>_\<pi>\<rho>.chine_assoc \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using R by simp
	+ also have "... = \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using C.comp_reduce [of "\<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]" \<mu>_\<nu>_\<pi>\<rho>.chine_assoc]
	+ hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<mu>_\<nu>_\<pi>\<rho>.chine_assoc_def \<nu>\<pi>.composable
	+ by fastforce
	+ also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ proof -
	+ have "\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc = (\<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1) \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using hcomp_def [of \<mu> \<nu>] hcomp_def [of \<pi> \<rho>] \<mu>\<nu>.composable \<pi>\<rho>.composable
	+ by simp
	+ also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using \<mu>\<nu>.dom.apex_def \<mu>\<nu>.dom.leg_simps(1) hcomp_def \<mu>\<nu>.composable
	+ \<mu>\<nu>.prj_in_hom(1) \<mu>\<nu>_\<pi>_\<rho>.prj_in_hom(4) C.comp_assoc
	+ by auto
	+ also have "... = \<mu>\<nu>.prj\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+
	+ text \<open>
	+ Now for the case of \<open>\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close>.
	+ We have to consider three sub-cases, involving the compositions with the projections
	+ \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<close>, \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0\<close>, and \<open>\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0\<close>.
	+ \<close>
	+
	+ moreover have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
	+ \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
	+ proof -
	+ (* Facts common to the three sub-cases. *)
	+ have A: "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc =
	+ \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
	+ using \<mu>_\<nu>\<pi>_\<rho>.chine_assoc_def \<nu>\<pi>_\<rho>.leg1_composite by auto
	+ have B: "\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ proof -
	+ have "\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ (\<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1]) \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using \<mu>_\<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow hcomp_def by auto
	+ also have "... = \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1] \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using C.comp_assoc by simp
	+ also have "... = \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ proof -
	+ have "HH\<mu>\<nu>\<pi>.leg0 = assoc\<mu>\<nu>\<pi>.dom.leg0"
	+ using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] by simp
	+ moreover have "C.commutative_square assoc\<mu>\<nu>\<pi>.cod.leg0 \<rho>.cod.leg1
	+ (assoc\<mu>\<nu>\<pi>.chine \<cdot> \<p>\<^sub>1[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])
	+ (\<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1])"
	+ by blast
	+ ultimately show ?thesis
	+ using chine_hcomp_def [of "assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>" \<rho>] by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ have *: "assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ text \<open>Subcase \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<close>:\<close>
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ \<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using \<nu>\<pi>\<rho>.chine_assoc_props(1) C.prj0_in_hom [of \<mu>.leg0 HH\<nu>\<pi>\<rho>.leg1] cospan_\<mu>0_H\<nu>H\<pi>\<rho>1
	+ C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>1 assoc\<nu>\<pi>\<rho>.chine \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1
	+ "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
	+ by auto
	+ also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using A C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
	+ by fastforce
	+ also have "... = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ proof -
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
	+ proof -
	+ have "\<nu>\<pi>.leg0 = \<pi>.leg0 \<cdot> \<nu>\<pi>.prj\<^sub>0"
	+ using hcomp_def \<nu>\<pi>.composable by simp
	+ thus ?thesis
	+ using commutative_squares(1) C.arrI \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(2) \<nu>\<pi>\<rho>.prj_in_hom(1)
	+ by (simp add: C.comp_assoc)
	+ qed
	+ moreover have "C.seq \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
	+ using chine_hcomp_ide_ide [of "hcomp \<nu> \<pi>" \<rho>] hcomp_def [of "hcomp \<nu> \<pi>" \<rho>]
	+ \<pi>\<rho>.composable \<nu>\<pi>\<rho>.prj_in_hom(1)
	+ by auto
	+ moreover have "C.seq \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>
	+ (chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>)"
	+ by fastforce
	+ ultimately show ?thesis
	+ using C.comp_permute by blast
	+ qed
	+ also have "... = \<nu>\<pi>.prj\<^sub>1 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ using B by simp
	+ also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ using hcomp_def [of \<nu> \<pi>] \<nu>\<pi>.composable C.comp_assoc
	+ C.comp_reduce [of \<mu>\<nu>\<pi>.Prj\<^sub>1\<^sub>0 \<mu>\<nu>\<pi>.chine_assoc \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1 "\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"]
	+ \<mu>\<nu>\<pi>.prj_in_hom(5) \<mu>\<nu>\<pi>.prj_chine_assoc(2)
	+ by auto
	+ also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot>
	+ \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ have 1: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
	+ by blast
	+ hence 2: "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
	+ HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] chine_hcomp_ide_ide \<nu>\<pi>.composable by auto
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc =
	+ \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using 1 2 \<pi>\<rho>.composable hcomp_def [of \<pi> \<rho>]
	+ C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>1 "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
	+ by fastforce
	+ also have "... = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>1"
	+ proof -
	+ have "\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1"
	+ using hcomp_def \<mu>\<nu>.composable \<pi>\<rho>.composable by simp
	+ thus ?thesis
	+ using C.comp_reduce C.comp_assoc by auto
	+ qed
	+ also have "... = \<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>1 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable by simp
	+ also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ proof -
	+ have 1: "\<mu>\<nu>.prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>.prj\<^sub>1 = \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>1"
	+ using hcomp_def \<mu>\<nu>.composable by simp
	+ moreover have 2: "C.seq \<mu>\<nu>.prj\<^sub>0 \<mu>\<nu>_\<pi>.prj\<^sub>1"
	+ using 1 by fastforce
	+ moreover have "C.seq \<mu>\<nu>_\<pi>.prj\<^sub>1 \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ by (metis 1 2 C.match_1 C.seqI' \<mu>\<nu>\<pi>.prj_in_hom(2) prj_in_homs(5))
	+ ultimately show ?thesis
	+ using C.comp_reduce by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ moreover
	+ text \<open>Subcase \<open>\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0\<close>:\<close>
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 "assoc\<nu>\<pi>\<rho>.chine" \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1
	+ "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
	+ by auto
	+ also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using A C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
	+ by fastforce
	+ also have "... = \<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ proof -
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> =
	+ \<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
	+ using commutative_squares(1) C.arrI \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(2) \<nu>\<pi>\<rho>.prj_in_hom(2)
	+ C.comp_assoc \<nu>\<pi>.leg0_composite
	+ by auto
	+ moreover have "C.seq \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
	+ using chine_hcomp_ide_ide [of "hcomp \<nu> \<pi>" \<rho>] hcomp_def [of "hcomp \<nu> \<pi>" \<rho>]
	+ \<pi>\<rho>.composable \<nu>\<pi>\<rho>.prj_in_hom(2)
	+ by auto
	+ moreover have "C.seq \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>
	+ (chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>)"
	+ by fastforce
	+ ultimately show ?thesis
	+ using C.comp_permute by blast
	+ qed
	+ also have "... = \<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>_\<nu>\<pi>.prj\<^sub>0 \<cdot> \<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ using B by simp
	+ also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ using hcomp_def [of \<nu> \<pi>] \<nu>\<pi>.composable \<mu>\<nu>\<pi>.prj_in_hom(6)
	+ C.comp_reduce [of \<nu>\<pi>.prj\<^sub>0 \<mu>_\<nu>\<pi>.prj\<^sub>0 \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0
	+ "\<mu>\<nu>\<pi>.chine_assoc \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"]
	+ C.comp_reduce [of \<mu>\<nu>\<pi>.Prj\<^sub>0\<^sub>0 \<mu>\<nu>\<pi>.chine_assoc \<mu>\<nu>\<pi>.Prj\<^sub>0
	+ "\<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"]
	+ by fastforce
	+ also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot>
	+ \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ have 1: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
	+ by blast
	+ hence 2: "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
	+ HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] chine_hcomp_ide_ide \<nu>\<pi>.composable by auto
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> = \<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
	+ proof -
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
	+ \<pi>\<rho>.prj\<^sub>1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ proof -
	+ have "\<pi>\<rho>.prj\<^sub>1 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 = \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0"
	+ using hcomp_def [of \<pi> \<rho>] \<pi>\<rho>.composable by simp
	+ moreover have "C.seq \<pi>\<rho>.prj\<^sub>1
	+ (\<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>)"
	+ using 2 hcomp_def [of \<pi> \<rho>] \<nu>\<pi>\<rho>.chine_composite(2) \<nu>\<pi>\<rho>.prj_in_hom(5)
	+ \<pi>\<rho>.composable
	+ by auto
	+ ultimately show ?thesis
	+ using 2 C.comp_reduce [of \<pi>\<rho>.prj\<^sub>1 \<nu>_\<pi>\<rho>.prj\<^sub>0 \<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0
	+ "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"]
	+ by auto
	+ qed
	+ also have "... = \<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
	+ using 1 by simp
	+ finally show ?thesis by blast
	+ qed
	+ hence "\<nu>\<pi>\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot>
	+ \<mu>\<nu>_\<pi>_\<rho>.chine_assoc =
	+ \<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using 2 C.comp_permute by blast
	+ also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ have "\<pi>\<rho>.prj\<^sub>1 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>0"
	+ using hcomp_def \<mu>\<nu>.composable \<pi>\<rho>.composable by simp
	+ thus ?thesis
	+ using 2 C.comp_reduce [of \<pi>\<rho>.prj\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>1\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
	+ by auto
	+ qed
	+ also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0\<^sub>1"
	+ by simp
	+ also have "... = \<mu>\<nu>\<pi>.Prj\<^sub>0 \<cdot> \<p>\<^sub>1[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] hcomp_def [of \<mu> \<nu>] \<mu>\<nu>.composite_is_arrow
	+ \<mu>\<nu>_\<pi>.composable
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ moreover
	+ text \<open>Subcase \<open>\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0\<close>:\<close>
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> =
	+ \<nu>\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 assoc\<nu>\<pi>\<rho>.chine \<nu>\<pi>\<rho>.Prj\<^sub>0
	+ "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
	+ by fastforce
	+ also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using A C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]" \<mu>_\<nu>\<pi>_\<rho>.chine_assoc]
	+ by fastforce
	+ also have "... = \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ proof -
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle> = \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0"
	+ proof -
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>0 = \<nu>\<pi>_\<rho>.prj\<^sub>0"
	+ using hcomp_def [of \<nu> \<pi>] \<nu>\<pi>.composable by simp
	+ thus ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using chine_hcomp_ide_ide [of "hcomp \<nu> \<pi>" \<rho>] hcomp_def [of "hcomp \<nu> \<pi>" \<rho>]
	+ \<pi>\<rho>.composable \<mu>_\<nu>\<pi>_\<rho>.prj_in_hom(3) calculation
	+ C.comp_reduce [of \<nu>\<pi>\<rho>.Prj\<^sub>0 "\<langle>\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>\<pi>.leg0, \<rho>.leg1\<rbrakk> \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0\<rangle>"
	+ \<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 "chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"]
	+ by fastforce
	+ qed
	+ also have "... = \<rho>.chine \<cdot> \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.dom.leg0, \<rho>.leg1]"
	+ proof -
	+ have "\<mu>_\<nu>\<pi>_\<rho>.Prj\<^sub>0 = \<p>\<^sub>0[assoc\<mu>\<nu>\<pi>.cod.leg0, \<rho>.cod.leg1]"
	+ using \<mu>_\<nu>\<pi>.composable \<nu>\<pi>.composite_is_arrow hcomp_def by auto
	+ thus ?thesis
	+ using chine_hcomp_props(5) [of \<rho> "assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>"]
	+ \<mu>\<nu>.composable \<nu>\<pi>.composable \<pi>\<rho>.composable
	+ by simp
	+ qed
	+ also have "... = \<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ proof -
	+ have "C.cospan HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1"
	+ using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable prj_in_homs(5) by blast
	+ hence "\<rho>.chine = C.cod \<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ using C.prj0_simps [of HH\<mu>\<nu>\<pi>.leg0 \<rho>.leg1] by simp
	+ thus ?thesis
	+ using C.comp_cod_arr hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] \<nu>\<pi>.composable
	+ HH\<mu>\<nu>\<pi>.dom.leg_simps(1) \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
	+ by simp
	+ qed
	+ also have "... = \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot>
	+ \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ have 1: "C.commutative_square \<nu>.leg0 \<pi>\<rho>.leg1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
	+ by blast
	+ hence 2: "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
	+ HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] chine_hcomp_ide_ide \<nu>\<pi>.composable by auto
	+ have
	+ "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc =
	+ \<pi>\<rho>.prj\<^sub>0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ have "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
	+ \<pi>\<rho>.prj\<^sub>0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
	+ proof -
	+ have
	+ "\<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> =
	+ \<pi>\<rho>.prj\<^sub>0 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ proof -
	+ have 3: "\<pi>\<rho>.prj\<^sub>0 \<cdot> \<nu>_\<pi>\<rho>.prj\<^sub>0 = \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0"
	+ using hcomp_def [of \<pi> \<rho>] \<pi>\<rho>.composable by simp
	+ moreover have "C.seq \<pi>\<rho>.prj\<^sub>0
	+ (\<nu>_\<pi>\<rho>.prj\<^sub>0 \<cdot> \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>)"
	+ using 1 2 3 hcomp_def [of \<pi> \<rho>] \<nu>\<pi>\<rho>.chine_composite(2)
	+ \<pi>\<rho>.composable
	+ by (metis C.arrI C.match_4 C.prj_tuple(1) \<mu>_\<nu>_\<pi>\<rho>.prj_in_hom(3)
	+ \<nu>\<pi>\<rho>.prj_in_hom(6))
	+ ultimately show ?thesis
	+ using 2 C.comp_reduce [of \<pi>\<rho>.prj\<^sub>0 \<nu>_\<pi>\<rho>.prj\<^sub>0 \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0
	+ "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"]
	+ by auto
	+ qed
	+ also have "... = \<pi>\<rho>.prj\<^sub>0 \<cdot> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0"
	+ using 1 by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using 2 C.comp_permute [of \<nu>\<pi>\<rho>.Prj\<^sub>0\<^sub>0 "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ \<pi>\<rho>.prj\<^sub>0 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
	+ by blast
	+ qed
	+ also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0\<^sub>0 \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using hcomp_def \<mu>\<nu>.composable \<pi>\<rho>.composable C.comp_assoc \<nu>\<pi>\<rho>.cospan_\<nu>\<pi>
	+ C.comp_reduce [of \<pi>\<rho>.prj\<^sub>0 \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0\<^sub>0 \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
	+ by auto
	+ also have "... = \<mu>\<nu>_\<pi>_\<rho>.Prj\<^sub>0"
	+ by simp
	+ also have "... = \<p>\<^sub>0[HH\<mu>\<nu>\<pi>.leg0, \<rho>.leg1]"
	+ using hcomp_def [of "hcomp \<mu> \<nu>" \<pi>] hcomp_def [of \<mu> \<nu>]
	+ \<mu>\<nu>.composite_is_arrow \<mu>\<nu>_\<pi>.composable
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "\<guillemotleft>assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho> : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ using \<nu>\<pi>\<rho>.chine_assoc_props(1) by fast
	+ moreover have "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc :
	+ HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>\<mu>\<nu>_\<pi>_\<rho>.chine_assoc : HHH\<mu>\<nu>\<pi>\<rho>.chine \<rightarrow>\<^sub>C HH\<mu>\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ using \<mu>\<nu>_\<pi>_\<rho>.chine_assoc_props(1) by blast
	+ moreover have "\<guillemotleft>\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> :
	+ HH\<mu>\<nu>H\<pi>\<rho>.chine \<rightarrow>\<^sub>C H\<nu>H\<pi>\<rho>.chine\<guillemotright>"
	+ using chine_hcomp_ide_ide hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<nu>\<pi>.composable by auto
	+ ultimately show ?thesis by blast
	+ qed
	+ ultimately show ?thesis
	+ using \<nu>\<pi>\<rho>.prj'_joint_monic
	+ [of "assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ HHH\<mu>\<nu>\<pi>\<rho>.chine
	+ "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"]
	+ by simp
	+ qed
	+
	+ text \<open>
	+ Now use fact \<open>*\<close> to finish off the \<open>\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]\<close> case.
	+ \<close>
	+ have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
	+ assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ proof -
	+ have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?LHS =
	+ \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ using L by simp
	+ also have "... = assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot>
	+ chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>"
	+ proof -
	+ have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>) =
	+ assoc\<nu>\<pi>\<rho>.chine \<cdot> \<p>\<^sub>0[\<mu>.leg0, HH\<nu>\<pi>\<rho>.leg1]"
	+ proof -
	+ have "C.commutative_square \<p>\<^sub>0[\<mu>.cod.leg0, assoc\<nu>\<pi>\<rho>.cod.leg1] assoc\<nu>\<pi>\<rho>.chine
	+ (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>)) \<p>\<^sub>0[\<mu>.leg0, assoc\<nu>\<pi>\<rho>.dom.leg1]"
	+ by blast
	+ thus ?thesis
	+ using \<nu>\<pi>\<rho>.chine_assoc_props(1) by auto
	+ qed
	+ moreover have "C.seq \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>))"
	+ using cospan_\<mu>0_H\<nu>H\<pi>\<rho>1 prj_in_homs(2) by fastforce
	+ moreover have "C.seq (chine_hcomp \<mu> (assoc\<^sub>S\<^sub>B \<nu> \<pi> \<rho>))
	+ (\<mu>_\<nu>\<pi>_\<rho>.chine_assoc \<cdot> chine_hcomp (assoc\<^sub>S\<^sub>B \<mu> \<nu> \<pi>) \<rho>)"
	+ by blast
	+ ultimately show ?thesis
	+ using chine_hcomp_props(4) C.comp_permute by auto
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ also have "... = \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using * by simp
	+ also have "... = \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS"
	+ proof -
	+ have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> Chn ?RHS =
	+ \<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>_\<pi>\<rho>.chine_assoc \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ using R by simp
	+ also have "... = \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle> \<cdot> \<mu>\<nu>_\<pi>_\<rho>.chine_assoc"
	+ proof -
	+ have "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] \<cdot> \<mu>_\<nu>_\<pi>\<rho>.chine_assoc =
	+ \<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ using hcomp_def [of \<nu> "hcomp \<pi> \<rho>"] \<nu>\<pi>.composable \<mu>_\<nu>_\<pi>\<rho>.chine_assoc_def by auto
	+ thus ?thesis
	+ using C.comp_reduce [of "\<p>\<^sub>0[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1]" \<mu>_\<nu>_\<pi>\<rho>.chine_assoc
	+ "\<langle>\<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<^sub>1 \<lbrakk>\<nu>.leg0, \<pi>\<rho>.leg1\<rbrakk> \<mu>_\<nu>_\<pi>\<rho>.Prj\<^sub>0\<rangle>"
	+ \<mu>\<nu>_\<pi>_\<rho>.chine_assoc]
	+ by fastforce
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "C.seq \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] (Chn ?LHS)"
	+ using LHS_in_hom Chn_in_hom by blast
	+ moreover have "C.seq \<p>\<^sub>1[\<mu>.leg0, H\<nu>H\<pi>\<rho>.leg1] (Chn ?RHS)"
	+ using RHS_in_hom Chn_in_hom by blast
	+ ultimately show "Chn ?LHS = Chn ?RHS"
	+ using cospan_\<mu>0_H\<nu>H\<pi>\<rho>1 C.prj_joint_monic by blast
	+ qed
	+
	+ end
	+
	+ context span_bicategory
	+ begin
	+
	+ interpretation VxV: product_category vcomp vcomp ..
	+ interpretation VV: subcategory VxV.comp \<open>\<lambda>\<nu>\<mu>. arr (fst \<nu>\<mu>) \<and> arr (snd \<nu>\<mu>) \<and>
	+ src (fst \<nu>\<mu>) = trg (snd \<nu>\<mu>)\<close>
	+ by (unfold_locales, simp_all)
	+ interpretation VxVxV: product_category vcomp VxV.comp ..
	+ interpretation VVV: subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using subcategory_VVV by auto
	+
	+ interpretation H: horizontal_composition vcomp hcomp src trg
	+ using has_horizontal_composition by auto
	+
	+ interpretation HoHV: "functor" VVV.comp vcomp HoHV
	+ using functor_HoHV by blast
	+ interpretation HoVH: "functor" VVV.comp vcomp HoVH
	+ using functor_HoVH by blast
	+
	+ interpretation L: equivalence_functor vcomp vcomp L
	+ using equivalence_functor_L by auto
	+ interpretation R: equivalence_functor vcomp vcomp R
	+ using equivalence_functor_R by auto
	+
	+ interpretation \<alpha>: natural_isomorphism VVV.comp vcomp HoHV HoVH \<alpha>\<^sub>S\<^sub>B
	+ using natural_isomorphism_\<alpha> by blast
	+
	+ lemma pentagon:
	+ assumes "ide f" and "ide g" and "ide h" and "ide k"
	+ and "src f = trg g" and "src g = trg h" and "src h = trg k"
	+ shows "(f \<star> \<alpha>\<^sub>S\<^sub>B (g, h, k)) \<bullet> \<alpha>\<^sub>S\<^sub>B (f, g \<star> h, k) \<bullet> (\<alpha>\<^sub>S\<^sub>B (f, g, h) \<star> k) =
	+ \<alpha>\<^sub>S\<^sub>B (f, g, h \<star> k) \<bullet> \<alpha>\<^sub>S\<^sub>B (f \<star> g, h, k)"
	+ proof -
	+ interpret f: identity_arrow_of_spans C f
	+ using assms ide_char' by auto
	+ interpret g: identity_arrow_of_spans C g
	+ using assms ide_char' by auto
	+ interpret h: identity_arrow_of_spans C h
	+ using assms ide_char' by auto
	+ interpret k: identity_arrow_of_spans C k
	+ using assms ide_char' by auto
	+
	+ interpret fghk: four_composable_identity_arrows_of_spans C prj0 prj1 f g h k
	+ using assms by (unfold_locales, auto)
	+
	+ let ?LHS = "(f \<star> assoc\<^sub>S\<^sub>B g h k) \<bullet> (assoc\<^sub>S\<^sub>B f (g \<star> h) k) \<bullet> (assoc\<^sub>S\<^sub>B f g h \<star> k)"
	+ let ?RHS = "assoc\<^sub>S\<^sub>B f g (h \<star> k) \<bullet> assoc\<^sub>S\<^sub>B (f \<star> g) h k"
	+
	+ have "(f \<star> \<alpha>\<^sub>S\<^sub>B (g, h, k)) \<bullet> \<alpha>\<^sub>S\<^sub>B (f, g \<star> h, k) \<bullet> (\<alpha>\<^sub>S\<^sub>B (f, g, h) \<star> k) = ?LHS"
	+ using assms \<alpha>_ide ide_hcomp src_hcomp trg_hcomp by simp
	+ also have "... = ?RHS"
	+ using fghk.\<mu>\<nu>.composable fghk.\<nu>\<pi>.composable fghk.\<pi>\<rho>.composable fghk.chine_pentagon
	+ hseqI'
	+ by (intro arr_eqI, auto)
	+ also have "... = \<alpha>\<^sub>S\<^sub>B (f, g, h \<star> k) \<bullet> \<alpha>\<^sub>S\<^sub>B (f \<star> g, h, k)"
	+ using assms \<alpha>_ide ide_hcomp src_hcomp trg_hcomp by simp
	+ finally show ?thesis by blast
	+ qed
	+
	+ lemma extends_to_bicategory:
	+ shows "bicategory vcomp hcomp assoc unit src trg"
	+ using unit_in_hom obj_char iso_unit assoc_def pentagon
	+ by (unfold_locales, auto)
	+
	+ sublocale bicategory vcomp hcomp assoc unit src trg
	+ using extends_to_bicategory by auto
	+
	+ end
	+
	+ subsection "Miscellaneous Formulas"
	+
	+ context span_bicategory
	+ begin
	+
	+ no_notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+ notation in_hom ("\<guillemotleft>_ : _ \<Rightarrow> _\<guillemotright>")
	+
	+ notation lunit ("\<l>[_]")
	+ notation runit ("\<r>[_]")
	+ notation lunit' ("\<l>\<^sup>-\<^sup>1[_]")
	+ notation runit' ("\<r>\<^sup>-\<^sup>1[_]")
	+ notation assoc ("\<a>[_, _, _]")
	+ notation \<a>' ("\<a>\<^sup>-\<^sup>1[_, _, _]")
	+
	+ lemma \<alpha>'_ide:
	+ assumes "ide f" and "ide g" and "ide h"
	+ and "src f = trg g" and "src g = trg h"
	+ shows "\<alpha>' (f, g, h) = assoc'\<^sub>S\<^sub>B f g h"
	+ proof -
	+ have fgh: "VVV.ide (f, g, h)"
	+ using assms VVV.ide_char VVV.arr_char VV.arr_char by simp
	+ interpret f: arrow_of_spans C f
	+ using assms arr_char [of f] by auto
	+ interpret g: arrow_of_spans C g
	+ using assms arr_char [of g] by auto
	+ interpret h: arrow_of_spans C h
	+ using assms arr_char [of h] by auto
	+ interpret fgh: three_composable_arrows_of_spans C prj0 prj1 f g h
	+ using assms by (unfold_locales, auto)
	+ interpret fgh: three_composable_identity_arrows_of_spans C prj0 prj1 f g h
	+ using assms ide_char by (unfold_locales, auto)
	+ have "\<alpha>' (f, g, h) = inv (\<alpha> (f, g, h))"
	+ using fgh \<alpha>'.inverts_components
	+ by (simp add: \<alpha>_def)
	+ moreover have "inv (\<alpha> (f, g, h)) = \<lparr>Chn = C.inv (Chn (\<alpha> (f, g, h))),
	+ Dom = Cod (\<alpha> (f, g, h)),
	+ Cod = Dom (\<alpha> (f, g, h))\<rparr>"
	+ using fgh \<alpha>.components_are_iso inv_eq
	+ by (simp add: \<alpha>_def fgh.\<mu>\<nu>.composable fgh.\<nu>\<pi>.composable)
	+ moreover have "... = assoc'\<^sub>S\<^sub>B f g h"
	+ using assms fgh \<alpha>_ide [of f g h] fgh.chine_assoc_inverse C.inverse_unique
	+ by (simp add: \<alpha>_def)
	+ ultimately show ?thesis by simp
	+ qed
	+
	+ text \<open>
	+ The following give explicit expressions for the unitors,
	+ derived from their characterizing properties and the definition of the associators.
	+ \<close>
	+
	+ lemma runit_ide_eq:
	+ assumes "ide f"
	+ shows "\<r>[f] = \<lparr>Chn = \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
	+ Dom = \<lparr>Leg0 = \<p>\<^sub>0[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
	+ Leg1 = Leg1 (Dom f) \<cdot> \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))]\<rparr>,
	+ Cod = Cod f\<rparr>"
	+ proof -
	+ interpret f: identity_arrow_of_spans C f
	+ using assms ide_char' by auto
	+ interpret src: identity_arrow_of_spans C \<open>src f\<close>
	+ using assms ide_char' ide_src by auto
	+ interpret f_src: two_composable_identity_arrows_of_spans C prj0 prj1 f \<open>src f\<close>
	+ using assms by (unfold_locales, simp)
	+ interpret src_src: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>src f\<close> \<open>src f\<close>
	+ by (unfold_locales, simp)
	+ interpret f_src_src: three_composable_identity_arrows_of_spans C prj0 prj1 f \<open>src f\<close> \<open>src f\<close>
	+ ..
	+
	+ let ?rf = "\<lparr>Chn = \<p>\<^sub>1[f.leg0, f.dsrc],
	+ Dom = \<lparr>Leg0 = \<p>\<^sub>0[f.leg0, f.dsrc], Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rparr>,
	+ Cod = Cod f\<rparr>"
	+ have "?rf = \<r>[f]"
	+ proof (intro runit_eqI)
	+ show "ide f" by fact
	+ interpret rf: arrow_of_spans C ?rf
	+ proof -
	+ interpret dom_rf: span_in_category C
	+ \<open>\<lparr>Leg0 = \<p>\<^sub>0[f.leg0, f.dsrc], Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rparr>\<close>
	+ by (unfold_locales, simp_all)
	+ show "arrow_of_spans C ?rf"
	+ using dom_rf.apex_def C.comp_cod_arr C.pullback_commutes [of f.leg0 f.dsrc]
	+ apply unfold_locales by auto
	+ qed
	+ show rf_in_hom: "\<guillemotleft>?rf : f \<star> src f \<Rightarrow> f\<guillemotright>"
	+ proof
	+ show "arr ?rf"
	+ using rf.arrow_of_spans_axioms arr_char by simp
	+ show "cod ?rf = f"
	+ using cod_char rf.arrow_of_spans_axioms arr_char by simp
	+ show "dom ?rf = f \<star> src f"
	+ using dom_char rf.arrow_of_spans_axioms src.arrow_of_spans_axioms arr_char hcomp_def
	+ f.arrow_of_spans_axioms f_src.composable chine_hcomp_ide_ide src_def ide_char
	+ C.comp_cod_arr rf.dom.apex_def
	+ by simp
	+ qed
	+ show "?rf \<star> src f = (f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f]"
	+ proof (intro arr_eqI)
	+ show par: "par (?rf \<star> src f) ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f])"
	+ proof -
	+ have "\<guillemotleft>?rf \<star> src f : (f \<star> src f) \<star> src f \<Rightarrow> f \<star> src f\<guillemotright>"
	+ proof -
	+ have "?rf \<star> src f = R ?rf"
	+ using assms rf_in_hom src_def trg_def arr_char rf.arrow_of_spans_axioms
	+ f.arrow_of_spans_axioms
	+ by simp
	+ moreover have "\<guillemotleft>R ?rf : (f \<star> src f) \<star> src f \<Rightarrow> f \<star> src f\<guillemotright>"
	+ using rf_in_hom R.preserves_hom [of ?rf "f \<star> src f" f] by simp
	+ ultimately show ?thesis by auto
	+ qed
	+ thus ?thesis
	+ using hseqI' by auto
	+ qed
	+ show "Chn (?rf \<star> src f) = Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f])"
	+ proof -
	+ have "Chn (?rf \<star> src f) = \<langle>f_src_src.Prj\<^sub>1\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>0\<^sub>1\<rangle>"
	+ proof -
	+ have "Chn (?rf \<star> src f) =
	+ \<langle>f_src_src.Prj\<^sub>1\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> \<p>\<^sub>0[f_src.prj\<^sub>0, src.leg1]\<rangle>"
	+ using assms src_def trg_def hcomp_def arr_char ide_char
	+ rf.arrow_of_spans_axioms src.identity_arrow_of_spans_axioms
	+ chine_hcomp_arr_ide C.comp_cod_arr
	+ by (simp add: f.arrow_of_spans_axioms identity_arrow_of_spans_def)
	+ moreover have "\<p>\<^sub>0[f_src.prj\<^sub>0, src.leg1] = f_src_src.Prj\<^sub>0\<^sub>1"
	+ proof -
	+ have "src f = \<lparr>Chn = f.dsrc,
	+ Dom = \<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>,
	+ Cod = \<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>\<rparr>"
	+ using assms src_def by simp
	+ thus ?thesis
	+ by (simp add: C.comp_cod_arr C.pullback_commutes')
	+ qed
	+ ultimately show ?thesis by auto
	+ qed
	+ also have "... = Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f])"
	+ proof -
	+ have "Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f]) =
	+ \<langle>f_src_src.Prj\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>1\<^sub>0\<rangle> \<cdot> f_src_src.chine_assoc"
	+ proof -
	+ have "Chn ((f \<star> \<i>[src f]) \<bullet> \<a>[f, src f, src f]) =
	+ Chn (f \<star> \<i>[src f]) \<cdot> Chn \<a>[f, src f, src f]"
	+ using par vcomp_eq [of "f \<star> \<i>[src f]" "\<a>[f, src f, src f]"]
	+ by simp
	+ moreover have "Chn (f \<star> \<i>[src f]) =
	+ \<langle>f_src_src.Prj\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>1\<^sub>0\<rangle>"
	+ proof -
	+ have "\<i>[src f] = \<lparr>Chn = \<p>\<^sub>1[f.dsrc, f.dsrc],
	+ Dom = \<lparr>Leg0 = \<p>\<^sub>1[f.dsrc, f.dsrc], Leg1 = \<p>\<^sub>1[f.dsrc, f.dsrc]\<rparr>,
	+ Cod = \<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>\<rparr>"
	+ using unit_def src_def trg_def hcomp_def src.arrow_of_spans_axioms arr_char
	+ f.arrow_of_spans_axioms C.comp_cod_arr
	+ by simp
	+ moreover have "arrow_of_spans C \<i>[src f]"
	+ using assms arr_char [of "\<i>[src f]"] by simp
	+ ultimately show ?thesis
	+ using assms unit_def hcomp_def chine_hcomp_ide_arr
	+ rf.arrow_of_spans_axioms src.arrow_of_spans_axioms
	+ f.arrow_of_spans_axioms arr_char C.comp_cod_arr
	+ src_def trg_def
	+ by simp
	+ qed
	+ ultimately show ?thesis
	+ using \<alpha>_ide by simp
	+ qed
	+ also have "... = \<langle>f_src_src.Prj\<^sub>1 \<cdot> f_src_src.chine_assoc
	+ \<lbrakk>f.leg0, src.leg1\<rbrakk>
	+ f_src_src.Prj\<^sub>1\<^sub>0 \<cdot> f_src_src.chine_assoc\<rangle>"
	+ proof -
	+ have "C.commutative_square f.leg0 src.leg1 f_src_src.Prj\<^sub>1 f_src_src.Prj\<^sub>1\<^sub>0"
	+ proof
	+ show "C.cospan f.leg0 src.leg1"
	+ using f_src.legs_form_cospan(1) by auto
	+ show "C.span f_src_src.Prj\<^sub>1 f_src_src.Prj\<^sub>1\<^sub>0"
	+ using f_src_src.prj_in_hom(5) by auto
	+ show "C.dom f.leg0 = C.cod f_src_src.Prj\<^sub>1"
	+ by simp
	+ show "f.leg0 \<cdot> f_src_src.Prj\<^sub>1 = src.leg1 \<cdot> f_src_src.Prj\<^sub>1\<^sub>0"
	+ using C.pullback_commutes' \<open>C.span f_src_src.Prj\<^sub>1 f_src_src.Prj\<^sub>1\<^sub>0\<close>
	+ C.comp_assoc
	+ by auto
	+ qed
	+ moreover have "C.seq f_src_src.Prj\<^sub>1 f_src_src.chine_assoc"
	+ by blast
	+ ultimately show ?thesis
	+ using C.comp_tuple_arr by auto
	+ qed
	+ also have "... = \<langle>f_src_src.Prj\<^sub>1\<^sub>1 \<lbrakk>f.leg0, src.leg1\<rbrakk> f_src_src.Prj\<^sub>0\<^sub>1\<rangle>"
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+ thus ?thesis by simp
	+ qed
	+
	+ lemma lunit_ide_eq:
	+ assumes "ide f"
	+ shows "\<l>[f] = \<lparr>Chn = \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
	+ Dom = \<lparr>Leg0 = Leg0 (Dom f) \<cdot> \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
	+ Leg1 = \<p>\<^sub>1[C.cod (Leg1 (Dom f)), Leg1 (Dom f)]\<rparr>,
	+ Cod = Cod f\<rparr>"
	+ proof -
	+ interpret f: identity_arrow_of_spans C f
	+ using assms ide_char' by auto
	+ interpret trg: identity_arrow_of_spans C \<open>trg f\<close>
	+ using assms ide_char' ide_trg by auto
	+ interpret trg_f: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>trg f\<close> f
	+ using assms by (unfold_locales, simp)
	+ interpret trg_trg: two_composable_identity_arrows_of_spans C prj0 prj1 \<open>trg f\<close> \<open>trg f\<close>
	+ by (unfold_locales, simp)
	+ interpret trg_trg_f: three_composable_identity_arrows_of_spans C prj0 prj1 \<open>trg f\<close> \<open>trg f\<close> f
	+ ..
	+
	+ let ?lf = "\<lparr>Chn = \<p>\<^sub>0[f.dtrg, f.leg1],
	+ Dom = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1], Leg1 = \<p>\<^sub>1[f.dtrg, f.leg1]\<rparr>,
	+ Cod = Cod f\<rparr>"
	+ have "?lf = \<l>[f]"
	+ proof (intro lunit_eqI)
	+ show "ide f" by fact
	+ interpret lf: arrow_of_spans C ?lf
	+ proof -
	+ interpret dom_lf: span_in_category C
	+ \<open>\<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1], Leg1 = \<p>\<^sub>1[f.dtrg, f.leg1]\<rparr>\<close>
	+ by (unfold_locales, simp_all)
	+ show "arrow_of_spans C ?lf"
	+ using dom_lf.apex_def C.comp_cod_arr C.pullback_commutes [of f.dtrg f.leg1]
	+ apply unfold_locales by auto
	+ qed
	+ show lf_in_hom: "\<guillemotleft>?lf : trg f \<star> f \<Rightarrow> f\<guillemotright>"
	+ proof
	+ show "arr ?lf"
	+ using lf.arrow_of_spans_axioms arr_char by simp
	+ show "cod ?lf = f"
	+ using cod_char lf.arrow_of_spans_axioms arr_char by simp
	+ show "dom ?lf = trg f \<star> f"
	+ using dom_char lf.arrow_of_spans_axioms trg.arrow_of_spans_axioms arr_char hcomp_def
	+ f.arrow_of_spans_axioms trg_f.composable chine_hcomp_ide_ide trg_def ide_char
	+ C.comp_cod_arr lf.dom.apex_def
	+ by simp
	+ qed
	+ show "trg f \<star> ?lf = (\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
	+ proof (intro arr_eqI)
	+ show par: "par (trg f \<star> ?lf) ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f])"
	+ proof -
	+ have "\<guillemotleft>trg f \<star> ?lf : trg f \<star> (trg f \<star> f) \<Rightarrow> trg f \<star> f\<guillemotright>"
	+ proof -
	+ have "trg f \<star> ?lf = L ?lf"
	+ using assms lf_in_hom src_def trg_def arr_char lf.arrow_of_spans_axioms
	+ f.arrow_of_spans_axioms
	+ by simp
	+ moreover have "\<guillemotleft>L ?lf : trg f \<star> (trg f \<star> f) \<Rightarrow> trg f \<star> f\<guillemotright>"
	+ using lf_in_hom L.preserves_hom [of ?lf "trg f \<star> f" f] by simp
	+ ultimately show ?thesis by auto
	+ qed
	+ thus ?thesis
	+ using hseqI' by auto
	+ qed
	+ show "Chn (trg f \<star> ?lf) = Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f])"
	+ proof -
	+ have "Chn (trg f \<star> ?lf) = \<langle>trg_trg_f.Prj\<^sub>1\<^sub>0 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<^sub>0\<rangle>"
	+ proof -
	+ have "Chn (trg f \<star> ?lf) =
	+ \<langle>\<p>\<^sub>1[trg.leg0, trg_f.prj\<^sub>1] \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<^sub>0\<rangle>"
	+ using assms src_def trg_def hcomp_def arr_char ide_char
	+ lf.arrow_of_spans_axioms trg.identity_arrow_of_spans_axioms
	+ chine_hcomp_ide_arr C.comp_cod_arr
	+ by (simp add: f.arrow_of_spans_axioms identity_arrow_of_spans_def)
	+ moreover have "\<p>\<^sub>1[trg.leg0, trg_f.prj\<^sub>1] = trg_trg_f.Prj\<^sub>1\<^sub>0"
	+ proof -
	+ have "trg f = \<lparr>Chn = f.dtrg,
	+ Dom = \<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>,
	+ Cod = \<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>\<rparr>"
	+ using assms trg_def by simp
	+ thus ?thesis
	+ apply (simp add: C.comp_cod_arr C.pullback_commutes')
	+ by (metis C.comp_cod_arr C.pullback_commutes' select_convs(1) select_convs(2)
	+ select_convs(3) f.cod_simps(3) lf.cod_trg_eq_dom_trg lf.dom.leg_simps(3)
	+ span_data.select_convs(1) span_data.select_convs(2) trg.chine_eq_apex
	+ trg_trg_f.cospan_\<nu>\<pi> trg_trg_f.prj_simps(10) trg_trg_f.prj_simps(16))
	+ qed
	+ ultimately show ?thesis by auto
	+ qed
	+ also have "... = Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f])"
	+ proof -
	+ have "Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]) =
	+ \<langle>trg_trg_f.Prj\<^sub>0\<^sub>1 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<rangle> \<cdot> trg_trg_f.chine_assoc'"
	+ proof -
	+ have "Chn ((\<i>[trg f] \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[trg f, trg f, f]) =
	+ Chn (\<i>[trg f] \<star> f) \<cdot> Chn \<a>\<^sup>-\<^sup>1[trg f, trg f, f]"
	+ using par vcomp_eq [of "\<i>[trg f] \<star> f" "\<a>\<^sup>-\<^sup>1[trg f, trg f, f]"]
	+ by simp
	+ moreover have "Chn (\<i>[trg f] \<star> f) =
	+ \<langle>trg_trg_f.Prj\<^sub>0\<^sub>1 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<rangle>"
	+ proof -
	+ have "\<i>[trg f] = \<lparr>Chn = \<p>\<^sub>1[f.dtrg, f.dtrg],
	+ Dom = \<lparr>Leg0 = \<p>\<^sub>1[f.dtrg, f.dtrg], Leg1 = \<p>\<^sub>1[f.dtrg, f.dtrg]\<rparr>,
	+ Cod = \<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>\<rparr>"
	+ using unit_def src_def trg_def hcomp_def trg.arrow_of_spans_axioms arr_char
	+ f.arrow_of_spans_axioms C.comp_cod_arr
	+ by simp
	+ moreover have "arrow_of_spans C \<i>[trg f]"
	+ using assms arr_char [of "\<i>[trg f]"] by simp
	+ ultimately show ?thesis
	+ using assms unit_def hcomp_def chine_hcomp_arr_ide
	+ lf.arrow_of_spans_axioms trg.arrow_of_spans_axioms
	+ f.arrow_of_spans_axioms arr_char C.comp_cod_arr
	+ src_def trg_def
	+ by simp
	+ qed
	+ moreover have "Chn \<a>\<^sup>-\<^sup>1[trg f, trg f, f] = trg_trg_f.chine_assoc'"
	+ proof -
	+ have "iso (\<alpha> (trg f, trg f, f))"
	+ proof -
	+ have "VVV.ide (trg f, trg f, f)"
	+ using assms VVV.ide_char VVV.arr_char VV.ide_char VV.arr_char
	+ by auto
	+ thus ?thesis
	+ using \<alpha>_def \<alpha>.components_are_iso [of "(trg f, trg f, f)"] by simp
	+ qed
	+ moreover have "C.inv trg_trg_f.chine_assoc = trg_trg_f.chine_assoc'"
	+ using trg_trg_f.chine_assoc_inverse C.inv_is_inverse C.inverse_arrow_unique
	+ by auto
	+ ultimately show ?thesis
	+ using assms by (simp add: \<a>'_def \<alpha>'_ide)
	+ qed
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+ also have "... = \<langle>trg_trg_f.Prj\<^sub>0\<^sub>1 \<cdot> trg_trg_f.chine_assoc'
	+ \<lbrakk>trg.leg0, f.leg1\<rbrakk>
	+ trg_trg_f.Prj\<^sub>0 \<cdot> trg_trg_f.chine_assoc'\<rangle>"
	+ proof -
	+ have "C.commutative_square trg.leg0 f.leg1 trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0"
	+ proof
	+ show "C.cospan trg.leg0 f.leg1"
	+ using trg_f.legs_form_cospan(1) by auto
	+ show "C.span trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0"
	+ using trg_trg_f.prj_in_hom by auto
	+ show "C.dom trg.leg0 = C.cod trg_trg_f.Prj\<^sub>0\<^sub>1"
	+ by simp
	+ show "trg.leg0 \<cdot> trg_trg_f.Prj\<^sub>0\<^sub>1 = f.leg1 \<cdot> trg_trg_f.Prj\<^sub>0"
	+ by (metis C.comp_assoc C.prj0_simps_arr C.pullback_commutes'
	+ \<open>C.span trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0\<close>)
	+ qed
	+ moreover have "C.seq trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.chine_assoc'"
	+ by blast
	+ ultimately show ?thesis
	+ using C.comp_tuple_arr [of trg.leg0 f.leg1 trg_trg_f.Prj\<^sub>0\<^sub>1 trg_trg_f.Prj\<^sub>0
	+ trg_trg_f.chine_assoc']
	+ by auto
	+ qed
	+ also have "... = \<langle>trg_trg_f.Prj\<^sub>1\<^sub>0 \<lbrakk>trg.leg0, f.leg1\<rbrakk> trg_trg_f.Prj\<^sub>0\<^sub>0\<rangle>"
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+ thus ?thesis by simp
	+ qed
	+
	+ lemma runit'_ide_eq:
	+ assumes "ide f"
	+ shows "\<r>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>Chn f \<lbrakk>Leg0 (Dom f), C.cod (Leg0 (Dom f))\<rbrakk> Leg0 (Dom f)\<rangle>,
	+ Dom = Cod f,
	+ Cod = \<lparr>Leg0 = \<p>\<^sub>0[Leg0 (Dom f), C.cod (Leg0 (Dom f))],
	+ Leg1 = Leg1 (Dom f) \<cdot> \<p>\<^sub>1[Leg0 (Dom f), C.cod (Leg0 (Dom f))]\<rparr>\<rparr>"
	+ proof -
	+ interpret f: identity_arrow_of_spans C f
	+ using assms ide_char' by auto
	+ show "\<r>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>, Dom = Cod f,
	+ Cod = \<lparr>Leg0 = \<p>\<^sub>0[f.leg0, f.dsrc], Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rparr>\<rparr>"
	+ proof -
	+ have "C.inverse_arrows \<p>\<^sub>1[f.leg0, f.dsrc] \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
	+ proof
	+ show "C.ide (\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle> \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc])"
	+ proof -
	+ have "\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle> \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] =
	+ \<langle>f.chine \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc]\<rangle>"
	+ using assms C.comp_tuple_arr [of f.leg0 f.dsrc f.chine f.leg0 "\<p>\<^sub>1[f.leg0, f.dsrc]"]
	+ C.comp_arr_dom C.comp_cod_arr
	+ by simp
	+ also have "... = \<langle>\<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, f.dsrc\<rbrakk> \<p>\<^sub>0[f.leg0, f.dsrc]\<rangle>"
	+ using C.pullback_commutes [of f.leg0 f.dsrc] C.comp_cod_arr by auto
	+ also have "... = f.leg0 \<down>\<down> f.dsrc"
	+ by simp
	+ finally have "\<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle> \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] = f.leg0 \<down>\<down> f.dsrc"
	+ by blast
	+ thus ?thesis by simp
	+ qed
	+ show "C.ide (\<p>\<^sub>1[f.leg0, f.dsrc] \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>)"
	+ using assms C.comp_arr_dom C.comp_cod_arr by auto
	+ qed
	+ hence "C.inv \<p>\<^sub>1[f.leg0, f.dsrc] = \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
	+ using C.inv_is_inverse C.inverse_arrow_unique by auto
	+ hence "\<r>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>,
	+ Dom = Cod \<r>[f], Cod = Dom \<r>[f]\<rparr>"
	+ using assms runit_ide_eq inv_eq [of "\<r>[f]"] iso_runit by simp
	+ thus ?thesis
	+ using assms runit_ide_eq by simp
	+ qed
	+ qed
	+
	+ lemma lunit'_ide_eq:
	+ assumes "ide f"
	+ shows "\<l>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>Leg1 (Dom f) \<lbrakk>C.cod (Leg1 (Dom f)), Leg1 (Dom f)\<rbrakk> Chn f\<rangle>,
	+ Dom = Cod f,
	+ Cod = \<lparr>Leg0 = Leg0 (Dom f) \<cdot> \<p>\<^sub>0[C.cod (Leg1 (Dom f)), Leg1 (Dom f)],
	+ Leg1 = \<p>\<^sub>1[C.cod (Leg1 (Dom f)), Leg1 (Dom f)]\<rparr>\<rparr>"
	+ proof -
	+ interpret f: identity_arrow_of_spans C f
	+ using assms ide_char' by auto
	+ show "\<l>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>, Dom = Cod f,
	+ Cod = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1], Leg1 = \<p>\<^sub>1[f.dtrg, f.leg1]\<rparr>\<rparr>"
	+ proof -
	+ have "C.inverse_arrows \<p>\<^sub>0[f.dtrg, f.leg1] \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>"
	+ proof
	+ show "C.ide (\<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle> \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1])"
	+ proof -
	+ have "\<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle> \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] =
	+ \<langle>f.leg1 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1]\<rangle>"
	+ using assms C.comp_tuple_arr C.comp_arr_dom C.comp_cod_arr
	+ by simp
	+ also have "... = \<langle>\<p>\<^sub>1[f.dtrg, f.leg1] \<lbrakk>f.dtrg, f.leg1\<rbrakk> \<p>\<^sub>0[f.dtrg, f.leg1]\<rangle>"
	+ proof -
	+ have "f.leg1 \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] = \<p>\<^sub>1[f.dtrg, f.leg1]"
	+ using C.pullback_commutes [of f.dtrg f.leg1] C.comp_cod_arr by auto
	+ thus ?thesis
	+ using C.comp_cod_arr by simp
	+ qed
	+ also have "... = f.dtrg \<down>\<down> f.leg1"
	+ by simp
	+ finally have "\<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle> \<cdot> \<p>\<^sub>0[f.dtrg, f.leg1] = f.dtrg \<down>\<down> f.leg1"
	+ by blast
	+ thus ?thesis by simp
	+ qed
	+ show "C.ide (\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>)"
	+ using assms C.comp_arr_dom C.comp_cod_arr by auto
	+ qed
	+ hence "C.inv \<p>\<^sub>0[f.dtrg, f.leg1] = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>"
	+ using C.inv_is_inverse C.inverse_arrow_unique by auto
	+ hence "\<l>\<^sup>-\<^sup>1[f] = \<lparr>Chn = \<langle>f.leg1 \<lbrakk>f.dtrg, f.leg1\<rbrakk> f.chine\<rangle>,
	+ Dom = Cod \<l>[f], Cod = Dom \<l>[f]\<rparr>"
	+ using assms lunit_ide_eq inv_eq [of "\<l>[f]"] iso_lunit by simp
	+ thus ?thesis
	+ using assms lunit_ide_eq by simp
	+ qed
	+ qed
	+
	+ end
	+
	+ locale adjunction_data_in_span_bicategory =
	+ span_bicategory C prj0 prj1 +
	+ adjunction_data_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
	+ for C :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<cdot>" 55)
	+ and prj0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>0[_, _]")
	+ and prj1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<p>\<^sub>1[_, _]")
	+ and f :: "'a arrow_of_spans_data"
	+ and g :: "'a arrow_of_spans_data"
	+ and \<eta> :: "'a arrow_of_spans_data"
	+ and \<epsilon> :: "'a arrow_of_spans_data"
	+ begin
	+
	+ interpretation f: identity_arrow_of_spans C f
	+ using ide_char' [of f] by auto
	+ interpretation g: identity_arrow_of_spans C g
	+ using ide_char' [of g] by auto
	+
	+ interpretation gf: two_composable_identity_arrows_of_spans C prj0 prj1 g f
	+ using antipar by (unfold_locales, auto)
	+ interpretation fg: two_composable_identity_arrows_of_spans C prj0 prj1 f g
	+ using antipar by (unfold_locales, auto)
	+
	+ interpretation fgf: three_composable_identity_arrows_of_spans C prj0 prj1 f g f ..
	+ interpretation gfg: three_composable_identity_arrows_of_spans C prj0 prj1 g f g ..
	+
	+ interpretation \<eta>: arrow_of_spans C \<eta>
	+ using arr_char unit_in_hom by auto
	+ interpretation \<epsilon>: arrow_of_spans C \<epsilon>
	+ using arr_char counit_in_hom by auto
	+
	+ lemma chine_unit_in_hom:
	+ shows "\<guillemotleft>\<eta>.chine : f.dsrc \<rightarrow>\<^sub>C g.leg0 \<down>\<down> f.leg1\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>\<eta>.chine : \<eta>.dom.apex \<rightarrow>\<^sub>C \<eta>.cod.apex\<guillemotright>"
	+ using \<eta>.chine_in_hom by simp
	+ moreover have "\<eta>.dom.apex = f.dsrc"
	+ using \<eta>.dom.apex_def dom_char unit_simps src_def by auto
	+ moreover have "\<eta>.cod.apex = g.leg0 \<down>\<down> f.leg1"
	+ proof -
	+ have "\<eta>.cod.apex = C.dom \<eta>.cod.leg0" by simp
	+ also have "... = C.dom (f.leg0 \<cdot> \<p>\<^sub>0[g.leg0, f.leg1])"
	+ using cod_char unit_simps hcomp_def gf.composable by simp
	+ also have "... = g.leg0 \<down>\<down> f.leg1"
	+ using fgf.cospan_\<nu>\<pi> by simp
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+
	+ lemma chine_counit_in_hom:
	+ shows "\<guillemotleft>\<epsilon>.chine : f.leg0 \<down>\<down> g.leg1 \<rightarrow>\<^sub>C f.dtrg\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>\<epsilon>.chine : \<epsilon>.dom.apex \<rightarrow>\<^sub>C \<epsilon>.cod.apex\<guillemotright>"
	+ using \<epsilon>.chine_in_hom by simp
	+ moreover have "\<epsilon>.cod.apex = f.dtrg"
	+ using \<epsilon>.cod.apex_def cod_char counit_simps trg_def gf.composable by auto
	+ moreover have "\<epsilon>.dom.apex = f.leg0 \<down>\<down> g.leg1"
	+ proof -
	+ have "\<epsilon>.dom.apex = C.dom \<epsilon>.dom.leg0" by simp
	+ also have "... = C.dom (g.leg0 \<cdot> fg.prj\<^sub>0)"
	+ using dom_char counit_simps hcomp_def fg.composable by simp
	+ also have "... = f.leg0 \<down>\<down> g.leg1"
	+ using fg.prj_in_hom(2) by auto
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+
	+ lemma \<eta>_leg_simps:
	+ shows "\<eta>.dom.leg0 = f.dsrc" and "\<eta>.dom.leg1 = f.dsrc"
	+ and "\<eta>.cod.leg0 = gf.leg0" and "\<eta>.cod.leg1 = gf.leg1"
	+ proof -
	+ show "\<eta>.dom.leg0 = f.dsrc"
	+ using dom_char unit_simps(2) src_def by auto
	+ show "\<eta>.dom.leg1 = f.dsrc"
	+ using dom_char unit_simps(2) src_def by auto
	+ show "\<eta>.cod.leg0 = gf.leg0"
	+ using cod_char unit_simps(1,3)
	+ by (metis (no_types, lifting) arrow_of_spans_data.select_convs(2))
	+ show "\<eta>.cod.leg1 = gf.leg1"
	+ using cod_char unit_simps(1,3)
	+ by (metis (no_types, lifting) arrow_of_spans_data.select_convs(2))
	+ qed
	+
	+ lemma \<epsilon>_leg_simps:
	+ shows "\<epsilon>.cod.leg0 = f.dtrg" and "\<epsilon>.cod.leg1 = f.dtrg"
	+ and "\<epsilon>.dom.leg0 = fg.leg0" and "\<epsilon>.dom.leg1 = fg.leg1"
	+ proof -
	+ show "\<epsilon>.cod.leg0 = f.dtrg"
	+ using cod_char counit_simps(3) trg_def gf.composable by auto
	+ show "\<epsilon>.cod.leg1 = f.dtrg"
	+ using cod_char counit_simps(3) trg_def gf.composable by auto
	+ show "\<epsilon>.dom.leg0 = fg.leg0"
	+ using dom_char counit_simps hcomp_def fg.composable by simp
	+ show "\<epsilon>.dom.leg1 = fg.leg1"
	+ using dom_char counit_simps hcomp_def fg.composable by simp
	+ qed
	+
	+ lemma Chn_triangle_eq:
	+ shows "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> f.leg0"
	+ and "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> g.leg1"
	+ proof -
	+ have "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) =
	+ \<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot>
	+ \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
	+ proof -
	+ have "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) =
	+ Chn \<l>[f] \<cdot> Chn (\<epsilon> \<star> f) \<cdot> Chn \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> Chn (f \<star> \<eta>) \<cdot> Chn \<r>\<^sup>-\<^sup>1[f]"
	+ using antipar Chn_vcomp hseqI' by auto
	+ also have "... = \<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot>
	+ chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
	+ using \<alpha>_ide fg.composable gf.composable fgf.chine_assoc_inverse
	+ C.inverse_unique inv_eq iso_assoc lunit_ide_eq hcomp_def [of \<epsilon> f]
	+ gf.composable hcomp_def [of f \<eta>] fg.composable runit'_ide_eq
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "C.arr (Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]))"
	+ proof -
	+ have "\<guillemotleft>\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f\<guillemotright>"
	+ using ide_left ide_right antipar triangle_in_hom(1) by blast
	+ thus ?thesis
	+ using Chn_in_hom by blast
	+ qed
	+ ultimately have *: "C.arr (\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot>
	+ chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>)"
	+ by simp
	+
	+ have "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) =
	+ \<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot>
	+ \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
	+ by fact
	+ also have
	+ 1: "... = fgf.Prj\<^sub>0 \<cdot> fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
	+ proof -
	+ have "\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f = \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
	+ proof -
	+ have "chine_hcomp \<epsilon> f = \<langle>\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1]
	+ \<lbrakk>\<epsilon>.cod.leg0, f.leg1\<rbrakk>
	+ \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]\<rangle>"
	+ using chine_hcomp_arr_ide gf.composable by simp
	+ moreover have 1: "f.dtrg = \<epsilon>.cod.leg0"
	+ using cod_char trg_def counit_simps gf.composable by simp
	+ moreover have "C.commutative_square f.dtrg f.leg1
	+ (\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1]) \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
	+ proof
	+ show "C.cospan f.dtrg f.leg1" by simp
	+ show 2: "C.span (\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1]) \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
	+ using 1 \<open>C.cospan f.dtrg f.leg1\<close> chine_counit_in_hom by simp
	+ show 3: "C.dom f.dtrg = C.cod (\<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1])"
	+ using 1 2 dom_char counit_simps by simp
	+ show "f.dtrg \<cdot> \<epsilon>.chine \<cdot> \<p>\<^sub>1[\<epsilon>.dom.leg0, f.leg1] = f.leg1 \<cdot> \<p>\<^sub>0[\<epsilon>.dom.leg0, f.leg1]"
	+ using 1 2 3 C.comp_cod_arr dom_char counit_simps C.pullback_commutes'
	+ by (metis (no_types, lifting) C.prj1_simps_arr C.seqE \<epsilon>.leg0_commutes)
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = fgf.Prj\<^sub>0"
	+ using dom_char counit_simps hcomp_def fg.composable by simp
	+ finally have "\<p>\<^sub>0[f.dtrg, f.leg1] \<cdot> chine_hcomp \<epsilon> f = fgf.Prj\<^sub>0"
	+ by simp
	+ moreover have "C.seq \<p>\<^sub>0[f.dtrg, f.leg1] (chine_hcomp \<epsilon> f)"
	+ using chine_hcomp_props(1) fg.composable calculation(1) fgf.prj_in_hom(3)
	+ by auto
	+ moreover have "C.seq (chine_hcomp \<epsilon> f)
	+ (fgf.chine_assoc' \<cdot> chine_hcomp f \<eta> \<cdot>
	+ \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>)"
	+ using chine_hcomp_props(1) fg.composable by (metis "*" C.seqE)
	+ ultimately show ?thesis
	+ using C.comp_reduce by simp
	+ qed
	+ also have 3: "... = fgf.Prj\<^sub>0\<^sub>0 \<cdot> chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
	+ using C.comp_reduce [of fgf.Prj\<^sub>0 fgf.chine_assoc' fgf.Prj\<^sub>0\<^sub>0
	+ "chine_hcomp f \<eta> \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"]
	+ * fgf.prj_chine_assoc'(3)
	+ by blast
	+ also have 4: "... = (gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]) \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
	+ proof -
	+ have "fgf.Prj\<^sub>0\<^sub>0 \<cdot> chine_hcomp f \<eta> = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
	+ proof -
	+ have "fgf.Prj\<^sub>0\<^sub>0 \<cdot> chine_hcomp f \<eta> =
	+ (gf.prj\<^sub>0 \<cdot> \<p>\<^sub>0[f.leg0, gf.leg1]) \<cdot>
	+ \<langle>\<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, gf.leg1\<rbrakk> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]\<rangle>"
	+ using hcomp_def fg.composable gf.composable chine_hcomp_ide_arr \<eta>_leg_simps by auto
	+ also have "... = gf.prj\<^sub>0 \<cdot> \<p>\<^sub>0[f.leg0, gf.leg1] \<cdot>
	+ \<langle>\<p>\<^sub>1[f.leg0, f.dsrc] \<lbrakk>f.leg0, gf.leg1\<rbrakk> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]\<rangle>"
	+ using C.comp_assoc by simp
	+ also have "... = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
	+ proof -
	+ have "C.commutative_square f.leg0 gf.leg1 \<p>\<^sub>1[f.leg0, f.dsrc] (\<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc])"
	+ proof
	+ show "C.cospan f.leg0 gf.leg1"
	+ using hcomp_def gf.composable fgf.prj_in_hom(5) by auto
	+ show "C.span \<p>\<^sub>1[f.leg0, f.dsrc] (\<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc])"
	+ using chine_unit_in_hom by auto
	+ show "C.dom f.leg0 = C.cod \<p>\<^sub>1[f.leg0, f.dsrc]" by simp
	+ show "f.leg0 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] = gf.leg1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
	+ proof -
	+ have "f.leg0 \<cdot> \<p>\<^sub>1[f.leg0, f.dsrc] = \<p>\<^sub>0[f.leg0, f.dsrc]"
	+ using C.comp_cod_arr C.pullback_commutes [of f.leg0 f.dsrc] by auto
	+ also have "... = gf.leg1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc]"
	+ using unit_simps cod_char hcomp_def gf.composable \<eta>.leg1_commutes \<eta>_leg_simps
	+ C.comp_cod_arr chine_unit_in_hom C.comp_reduce
	+ by auto
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "C.seq fgf.Prj\<^sub>0\<^sub>0 (chine_hcomp f \<eta>)"
	+ using chine_hcomp_props(1) by (metis "*" 1 3 C.match_2 C.seqE)
	+ moreover have "C.seq (chine_hcomp f \<eta>) \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
	+ using chine_hcomp_props(1) by (metis "*" C.seqE)
	+ ultimately show ?thesis
	+ using C.comp_reduce by simp
	+ qed
	+ also have "... = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>0[f.leg0, f.dsrc] \<cdot> \<langle>f.chine \<lbrakk>f.leg0, f.dsrc\<rbrakk> f.leg0\<rangle>"
	+ using C.comp_assoc by simp
	+ also have "... = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> f.leg0"
	+ using C.comp_cod_arr f.leg0_commutes by simp
	+ finally show "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) = gf.prj\<^sub>0 \<cdot> \<eta>.chine \<cdot> f.leg0"
	+ by simp
	+
	+ have "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) =
	+ \<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
	+ \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
	+ proof -
	+ have "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) =
	+ Chn \<r>[g] \<cdot> Chn (g \<star> \<epsilon>) \<cdot> Chn \<a>[g, f, g] \<cdot> Chn (\<eta> \<star> g) \<cdot> Chn \<l>\<^sup>-\<^sup>1[g]"
	+ using antipar Chn_vcomp hseqI' by auto
	+ also have "... = \<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
	+ \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
	+ using \<alpha>_ide gf.composable fg.composable runit_ide_eq hcomp_def [of g \<epsilon>]
	+ fg.composable hcomp_def [of \<eta> g] gf.composable lunit'_ide_eq
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "C.arr (Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]))"
	+ proof -
	+ have "\<guillemotleft>\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g] : g \<Rightarrow> g\<guillemotright>"
	+ using ide_left ide_right antipar triangle_in_hom(2) by blast
	+ thus ?thesis
	+ using Chn_in_hom by blast
	+ qed
	+ ultimately have *: "C.arr (\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
	+ \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>)"
	+ by simp
	+
	+ have "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) =
	+ \<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot>
	+ \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
	+ by fact
	+ also have
	+ 1: "... = gfg.Prj\<^sub>1 \<cdot> gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
	+ proof -
	+ have "\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> = \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]"
	+ proof -
	+ have "chine_hcomp g \<epsilon> = \<langle>\<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]
	+ \<lbrakk>g.leg0, \<epsilon>.cod.leg1\<rbrakk>
	+ \<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1]\<rangle>"
	+ using chine_hcomp_ide_arr gf.composable by simp
	+ moreover have 1: "g.dsrc = \<epsilon>.cod.leg1"
	+ using gfg.cospan_\<mu>\<nu> by (simp add: \<epsilon>_leg_simps(2))
	+ moreover have "C.commutative_square g.leg0 g.dsrc \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]
	+ (\<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1])"
	+ proof
	+ show "C.cospan g.leg0 g.dsrc" by simp
	+ show 2: "C.span \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1] (\<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1])"
	+ using 1 \<open>C.cospan g.leg0 g.dsrc\<close> chine_counit_in_hom by simp
	+ show 3: "C.dom g.leg0 = C.cod \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1]"
	+ using 1 2 dom_char counit_simps by simp
	+ show "g.leg0 \<cdot> \<p>\<^sub>1[g.leg0, \<epsilon>.dom.leg1] = g.dsrc \<cdot> \<epsilon>.chine \<cdot> \<p>\<^sub>0[g.leg0, \<epsilon>.dom.leg1]"
	+ using 1 2 3 C.comp_cod_arr dom_char counit_simps C.pullback_commutes'
	+ by (metis (no_types, lifting) C.cod_comp C.prj0_simps_arr C.seqE \<epsilon>.leg1_commutes)
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = gfg.Prj\<^sub>1"
	+ using dom_char counit_simps hcomp_def fg.composable by simp
	+ finally have "\<p>\<^sub>1[g.leg0, g.dsrc] \<cdot> chine_hcomp g \<epsilon> = gfg.Prj\<^sub>1"
	+ by simp
	+ moreover have "C.seq \<p>\<^sub>1[g.leg0, g.dsrc] (chine_hcomp g \<epsilon>)"
	+ using chine_hcomp_props(1) [of g \<epsilon>] gf.composable calculation gfg.prj_in_hom(4)
	+ by auto
	+ moreover have "C.seq (chine_hcomp g \<epsilon>)
	+ (gfg.chine_assoc \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>)"
	+ using chine_hcomp_props(1) gf.composable * by (metis C.seqE)
	+ ultimately show ?thesis
	+ using C.comp_reduce by simp
	+ qed
	+ also have 3: "... = gfg.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
	+ using C.comp_reduce [of gfg.Prj\<^sub>1 gfg.chine_assoc gfg.Prj\<^sub>1\<^sub>1
	+ "chine_hcomp \<eta> g \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"]
	+ * gfg.prj_chine_assoc(1)
	+ by blast
	+ also have 4: "... = (gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
	+ proof -
	+ have "gfg.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp \<eta> g = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]"
	+ proof -
	+ have "gfg.Prj\<^sub>1\<^sub>1 \<cdot> chine_hcomp \<eta> g =
	+ (gf.prj\<^sub>1 \<cdot> \<p>\<^sub>1[gf.leg0, g.leg1]) \<cdot>
	+ \<langle>\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] \<lbrakk>gf.leg0, g.leg1\<rbrakk> \<p>\<^sub>0[g.dtrg, g.leg1]\<rangle>"
	+ using hcomp_def fg.composable gf.composable chine_hcomp_arr_ide trg_def unit_simps(5)
	+ \<eta>_leg_simps
	+ by auto
	+ also have "... = gf.prj\<^sub>1 \<cdot> \<p>\<^sub>1[gf.leg0, g.leg1] \<cdot>
	+ \<langle>\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] \<lbrakk>gf.leg0, g.leg1\<rbrakk> \<p>\<^sub>0[g.dtrg, g.leg1]\<rangle>"
	+ using C.comp_assoc by simp
	+ also have "... = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]"
	+ proof -
	+ have "C.commutative_square gf.leg0 g.leg1 (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<p>\<^sub>0[g.dtrg, g.leg1]"
	+ proof
	+ show "C.cospan gf.leg0 g.leg1"
	+ using hcomp_def [of g f] gf.composable gfg.prj_in_hom(3) by auto
	+ show "C.span (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<p>\<^sub>0[g.dtrg, g.leg1]"
	+ using chine_unit_in_hom fg.composable src_def trg_def by auto
	+ show "C.dom gf.leg0 = C.cod (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1])"
	+ using chine_unit_in_hom \<eta>_leg_simps
	+ by (simp add: \<eta>.cod.apex_def
	+ \<open>C.span (\<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]) \<p>\<^sub>0[g.dtrg, g.leg1]\<close>)
	+ show "gf.leg0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] = g.leg1 \<cdot> \<p>\<^sub>0[g.dtrg, g.leg1]"
	+ proof -
	+ have "g.leg1 \<cdot> \<p>\<^sub>0[g.dtrg, g.leg1] = \<p>\<^sub>1[g.dtrg, g.leg1]"
	+ using C.comp_cod_arr C.pullback_commutes [of g.dtrg g.leg1] by auto
	+ also have "... = gf.leg0 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1]"
	+ proof -
	+ have "gf.leg0 \<cdot> \<eta>.chine = g.dtrg"
	+ using unit_simps cod_char hcomp_def gf.composable \<eta>.leg0_commutes
	+ dom_char trg_def fg.composable
	+ by simp
	+ moreover have "C.seq \<eta>.chine \<p>\<^sub>1[g.dtrg, g.leg1]"
	+ using chine_unit_in_hom fg.composable src_def trg_def by auto
	+ ultimately show ?thesis
	+ using C.comp_cod_arr C.comp_reduce by auto
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "C.seq gfg.Prj\<^sub>1\<^sub>1 (chine_hcomp \<eta> g)"
	+ using chine_hcomp_props(1) [of \<eta> g] by (metis "*" 1 "3" C.match_2 C.seqE)
	+ moreover have "C.seq (chine_hcomp \<eta> g) \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
	+ using chine_hcomp_props(1) by (metis "*" C.seqE)
	+ ultimately show ?thesis
	+ using C.comp_reduce by simp
	+ qed
	+ also have "... = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> \<p>\<^sub>1[g.dtrg, g.leg1] \<cdot> \<langle>g.leg1 \<lbrakk>g.dtrg, g.leg1\<rbrakk> g.chine\<rangle>"
	+ using C.comp_assoc by simp
	+ also have "... = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> g.leg1"
	+ using C.comp_cod_arr g.leg1_commutes by simp
	+ finally show "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) = gf.prj\<^sub>1 \<cdot> \<eta>.chine \<cdot> g.leg1"
	+ by simp
	+ qed
	+
	+ end
	+
	+ subsection "Maps in Span(C)"
	+
	+ text \<open>
	+ In this section, we chararacterize the maps (\emph{i.e}~the left adjoints)
	+ in a span bicategory. This is Proposition 2 of \cite{carboni-et-al}.
	+ \<close>
	+
	+ context span_bicategory
	+ begin
	+
	+ abbreviation adjoint_of_map
	+ where "adjoint_of_map f \<equiv> \<lparr>Chn = Chn f,
	+ Dom = \<lparr>Leg0 = Leg1 (Dom f), Leg1 = Leg0 (Dom f)\<rparr>,
	+ Cod = \<lparr>Leg0 = Leg1 (Dom f), Leg1 = Leg0 (Dom f)\<rparr>\<rparr>"
	+
	+ abbreviation unit_for_map
	+ where "unit_for_map f \<equiv> \<lparr>Chn = \<langle>C.inv (Leg0 (Dom f))
	+ \<lbrakk>Leg1 (Dom f), Leg1 (Dom f)\<rbrakk>
	+ C.inv (Leg0 (Dom f))\<rangle>,
	+ Dom = Dom (src f),
	+ Cod = Dom (hcomp (adjoint_of_map f) f)\<rparr>"
	+
	+ abbreviation counit_for_map
	+ where "counit_for_map f \<equiv> \<lparr>Chn = Leg1 (Dom f) \<cdot> \<p>\<^sub>0[Leg0 (Dom f), Leg0 (Dom f)],
	+ Dom = Dom (hcomp f (adjoint_of_map f)),
	+ Cod = Dom (trg f)\<rparr>"
	+
	+ lemma is_left_adjoint_char:
	+ shows "is_left_adjoint f \<longleftrightarrow> ide f \<and> C.iso (Leg0 (Dom f))"
	+ and "is_left_adjoint f \<Longrightarrow>
	+ adjunction_in_bicategory vcomp hcomp assoc unit src trg f
	+ (adjoint_of_map f) (unit_for_map f) (counit_for_map f)"
	+ proof
	+ show 1: "is_left_adjoint f \<Longrightarrow> ide f \<and> C.iso (Leg0 (Dom f))"
	+ proof
	+ assume f: "is_left_adjoint f"
	+ obtain g \<eta> \<epsilon> where adj: "adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>"
	+ using f adjoint_pair_def by blast
	+ interpret adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
	+ using adj by auto
	+ show "ide f" by simp
	+
	+ interpret f: identity_arrow_of_spans C f
	+ using ide_char' [of f] by auto
	+ interpret g: identity_arrow_of_spans C g
	+ using ide_char' [of g] by auto
	+
	+ interpret gf: two_composable_identity_arrows_of_spans C prj0 prj1 g f
	+ using antipar by (unfold_locales, auto)
	+ interpret fg: two_composable_identity_arrows_of_spans C prj0 prj1 f g
	+ using antipar by (unfold_locales, auto)
	+
	+ interpret fgf: three_composable_identity_arrows_of_spans C prj0 prj1 f g f ..
	+
	+ interpret src_f: arrow_of_spans C \<open>src f\<close>
	+ using arr_char gf.are_arrows(2) by blast
	+ interpret src_f: identity_arrow_of_spans C \<open>src f\<close>
	+ using ide_char ide_src src_def by (unfold_locales, simp)
	+
	+ interpret \<eta>: arrow_of_spans C \<eta>
	+ using arr_char unit_in_hom by auto
	+ interpret \<epsilon>: arrow_of_spans C \<epsilon>
	+ using arr_char counit_in_hom by auto
	+
	+ interpret adjunction_data_in_span_bicategory C prj0 prj1 f g \<eta> \<epsilon>
	+ ..
	+ show "C.iso f.leg0"
	+ proof -
	+ have "C.section f.leg0"
	+ proof -
	+ have "f.chine = (gf.prj\<^sub>0 \<cdot> \<eta>.chine) \<cdot> f.leg0"
	+ using triangle_left' Chn_triangle_eq(1) C.comp_assoc by simp
	+ thus ?thesis
	+ using f.chine_is_identity by auto
	+ qed
	+ moreover have "C.retraction f.leg0"
	+ using C.retractionI [of f.leg0 "gf.prj\<^sub>0 \<cdot> \<eta>.chine"] hcomp_def C.comp_assoc
	+ \<eta>.leg0_commutes gf.leg0_composite \<eta>_leg_simps
	+ by auto
	+ ultimately show ?thesis
	+ by (simp add: C.iso_iff_section_and_retraction)
	+ qed
	+ qed
	+ have 2: "ide f \<and> C.iso (Leg0 (Dom f)) \<Longrightarrow>
	+ adjunction_in_bicategory vcomp hcomp assoc unit src trg f
	+ (adjoint_of_map f) (unit_for_map f) (counit_for_map f)"
	+
	+ text \<open>
	+ The right adjoint \<open>g\<close> is obtained by exchanging the legs of \<open>f\<close>.
	+ The unit is obtained by tupling \<open>C.inv f.leg0\<close> with itself,
	+ via the pullback of \<open>f.leg1\<close> with itself.
	+ The counit is given by the legs of \<open>f \<star> g\<close>, which are equal,
	+ because the two legs of a pullback of the isomorphism \<open>f.leg0\<close>
	+ with itself must be equal.
	+ It then remains to verify the triangle identities.
	+ \<close>
	+
	+ proof -
	+ assume f: "ide f \<and> C.iso (Leg0 (Dom f))"
	+ interpret f: identity_arrow_of_spans C f
	+ using f ide_char' by auto
	+ interpret Dom_src: span_in_category C \<open>\<lparr>Leg0 = f.dsrc, Leg1 = f.dsrc\<rparr>\<close>
	+ using f by (unfold_locales, auto)
	+ interpret Dom_trg: span_in_category C \<open>\<lparr>Leg0 = f.dtrg, Leg1 = f.dtrg\<rparr>\<close>
	+ using f by (unfold_locales, auto)
	+
	+ define g where "g = adjoint_of_map f"
	+ interpret Dom_g: span_in_category C \<open>\<lparr>Leg0 = f.leg1, Leg1 = f.leg0\<rparr>\<close>
	+ by (unfold_locales, simp)
	+ interpret g: arrow_of_spans C g
	+ unfolding g_def
	+ using Dom_g.apex_def f.leg0_commutes f.leg1_commutes
	+ by (unfold_locales, auto)
	+ interpret g: identity_arrow_of_spans C g
	+ using g_def
	+ by (unfold_locales, auto)
	+ have ide_g: "ide g"
	+ using f ide_char g.arrow_of_spans_axioms by simp
	+
	+ interpret fg: two_composable_arrows_of_spans C prj0 prj1 f g
	+ apply unfold_locales
	+ using g_def src_def trg_def arr_char f.arrow_of_spans_axioms g.arrow_of_spans_axioms
	+ by auto
	+ interpret fg: two_composable_identity_arrows_of_spans C prj0 prj1 f g
	+ ..
	+ interpret gf: two_composable_arrows_of_spans C prj0 prj1 g f
	+ apply unfold_locales
	+ using g_def src_def trg_def arr_char f.arrow_of_spans_axioms g.arrow_of_spans_axioms
	+ by auto
	+ interpret gf: two_composable_identity_arrows_of_spans C prj0 prj1 g f
	+ ..
	+ have hcomp_fg_eq: "hcomp f g = \<lparr>Chn = f.leg0 \<down>\<down> f.leg0,
	+ Dom = \<lparr>Leg0 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0],
	+ Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0]\<rparr>,
	+ Cod = \<lparr>Leg0 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0],
	+ Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0]\<rparr>\<rparr>"
	+ using f g_def hcomp_def fg.composable src_def trg_def arr_char f.arrow_of_spans_axioms
	+ g.arrow_of_spans_axioms chine_hcomp_def gf.are_identities(1) chine_hcomp_ide_ide
	+ C.pullback_iso_self
	+ by auto
	+ have hcomp_gf_eq: "hcomp g f = \<lparr>Chn = f.leg1 \<down>\<down> f.leg1,
	+ Dom = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.leg1, f.leg1],
	+ Leg1 = f.leg0 \<cdot> \<p>\<^sub>1[f.leg1, f.leg1]\<rparr>,
	+ Cod = \<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.leg1, f.leg1],
	+ Leg1 = f.leg0 \<cdot> \<p>\<^sub>1[f.leg1, f.leg1]\<rparr>\<rparr>"
	+ using g_def hcomp_def gf.composable src_def trg_def chine_hcomp_ide_ide
	+ arr_char f.arrow_of_spans_axioms g.arrow_of_spans_axioms ide_char
	+ by simp
	+
	+ define \<eta> where "\<eta> = unit_for_map f"
	+ interpret Dom_gf: span_in_category C \<open>\<lparr>Leg0 = f.leg0 \<cdot> \<p>\<^sub>0[f.leg1, f.leg1],
	+ Leg1 = f.leg0 \<cdot> \<p>\<^sub>1[f.leg1, f.leg1]\<rparr>\<close>
	+ by (unfold_locales, simp_all)
	+ interpret \<eta>: arrow_of_spans C \<eta>
	+ using f g_def \<eta>_def hcomp_def src_def trg_def f.arrow_of_spans_axioms
	+ g.arrow_of_spans_axioms arr_char C.comp_arr_inv'
	+ C.tuple_in_hom [of f.leg1 f.leg1 "C.inv f.leg0" "C.inv f.leg0"]
	+ Dom_src.apex_def Dom_gf.apex_def
	+ apply unfold_locales by (simp_all add: C.comp_assoc)
	+ have unit_in_hom: "\<guillemotleft>\<eta> : src f \<Rightarrow> hcomp g f\<guillemotright>"
	+ proof
	+ show 1: "arr \<eta>"
	+ using arr_char \<eta>.arrow_of_spans_axioms by simp
	+ show "dom \<eta> = src f"
	+ using 1 \<eta>_def dom_char src_def Dom_src.apex_def by simp
	+ show "cod \<eta> = hcomp g f"
	+ using 1 \<eta>_def g_def cod_char hcomp_gf_eq Dom_gf.apex_def by simp
	+ qed
	+
	+ define \<epsilon> where "\<epsilon> = counit_for_map f"
	+ interpret Dom_fg: span_in_category C \<open>\<lparr>Leg0 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0],
	+ Leg1 = f.leg1 \<cdot> \<p>\<^sub>1[f.leg0, f.leg0]\<rparr>\<close>
	+ by (unfold_locales, simp_all)
	+ interpret \<epsilon>: arrow_of_spans C \<epsilon>
	+ using f g_def \<epsilon>_def hcomp_def src_def trg_def f.arrow_of_spans_axioms
	+ g.arrow_of_spans_axioms arr_char C.comp_cod_arr C.pullback_iso_self
	+ Dom_trg.apex_def Dom_fg.apex_def
	+ apply unfold_locales by auto
	+ have counit_in_hom: "\<guillemotleft>\<epsilon> : hcomp f g \<Rightarrow> trg f\<guillemotright>"
	+ proof
	+ show 1: "arr \<epsilon>"
	+ using arr_char \<epsilon>.arrow_of_spans_axioms by simp
	+ show "cod \<epsilon> = trg f"
	+ using 1 \<epsilon>_def cod_char trg_def Dom_trg.apex_def by simp
	+ show "dom \<epsilon> = hcomp f g"
	+ using 1 g_def \<epsilon>_def dom_char hcomp_fg_eq Dom_fg.apex_def by simp
	+ qed
	+ interpret adj: adjunction_data_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
	+ using f ide_g unit_in_hom counit_in_hom gf.composable
	+ by (unfold_locales, simp_all)
	+ interpret adjunction_data_in_span_bicategory C prj0 prj1 f g \<eta> \<epsilon>
	+ ..
	+ have triangle_left: "(\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<bullet> \<r>[f]"
	+ proof -
	+ have "\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f] = f"
	+ proof (intro arr_eqI)
	+ show "par (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) f"
	+ using f ide_in_hom [of f] adj.triangle_in_hom(3)
	+ by (metis (no_types, lifting) in_homE)
	+ show "Chn (\<l>[f] \<bullet> (\<epsilon> \<star> f) \<bullet> \<a>\<^sup>-\<^sup>1[f, g, f] \<bullet> (f \<star> \<eta>) \<bullet> \<r>\<^sup>-\<^sup>1[f]) = f.chine"
	+ using f g_def \<eta>_def Chn_triangle_eq(1) C.comp_tuple_arr C.comp_inv_arr' by simp
	+ qed
	+ thus ?thesis
	+ using adj.triangle_equiv_form by simp
	+ qed
	+ have triangle_right: "(g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<bullet> \<l>[g]"
	+ proof -
	+ have "\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g] = g"
	+ proof (intro arr_eqI)
	+ show "par (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) g"
	+ using adj.ide_right ide_in_hom [of g] adj.triangle_in_hom(4)
	+ by (metis (no_types, lifting) in_homE)
	+ show "Chn (\<r>[g] \<bullet> (g \<star> \<epsilon>) \<bullet> \<a>[g, f, g] \<bullet> (\<eta> \<star> g) \<bullet> \<l>\<^sup>-\<^sup>1[g]) = g.chine"
	+ using f g_def \<eta>_def Chn_triangle_eq(2) C.comp_tuple_arr C.comp_inv_arr' by simp
	+ qed
	+ thus ?thesis
	+ using adj.triangle_equiv_form by simp
	+ qed
	+ interpret adj: adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>
	+ using triangle_left triangle_right by (unfold_locales, simp_all)
	+ show "adjunction_in_bicategory vcomp hcomp assoc unit src trg f g \<eta> \<epsilon>" ..
	+ qed
	+ show "ide f \<and> C.iso (Leg0 (Dom f)) \<Longrightarrow> is_left_adjoint f"
	+ using 2 adjoint_pair_def by blast
	+ show "is_left_adjoint f \<Longrightarrow> adjunction_in_bicategory vcomp hcomp assoc unit src trg f
	+ (adjoint_of_map f) (unit_for_map f) (counit_for_map f)"
	+ using 1 2 by blast
	+ qed
	+
	+ end
	+
	+end
	diff --git a/thys/Bicategory/Strictness.thy b/thys/Bicategory/Strictness.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/Strictness.thy
	@@ -0,0 +1,4492 @@
	+(* Title: Strictness
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Strictness"
	+
	+theory Strictness
	+imports ConcreteCategory Pseudofunctor CanonicalIsos
	+begin
	+
	+ text \<open>
	+ In this section we consider bicategories in which some or all of the canonical isomorphisms
	+ are assumed to be identities. A \emph{normal} bicategory is one in which the unit
	+ isomorphisms are identities, so that unit laws for horizontal composition are satisfied
	+ ``on the nose''.
	+ A \emph{strict} bicategory (also known as a \emph{2-category}) is a bicategory in which both
	+ the unit and associativity isomoprhisms are identities, so that horizontal composition is
	+ strictly associative as well as strictly unital.
	+
	+ From any given bicategory \<open>B\<close> we may construct a related strict bicategory \<open>S\<close>,
	+ its \emph{strictification}, together with a pseudofunctor that embeds \<open>B\<close> in \<open>S\<close>.
	+ The Strictness Theorem states that this pseudofunctor is an equivalence pseudofunctor,
	+ so that bicategory \<open>B\<close> is biequivalent to its strictification.
	+ The Strictness Theorem is often used informally to justify suppressing canonical
	+ isomorphisms; which amounts to proving a theorem about 2-categories and asserting that
	+ it holds for all bicategories. Here we are working formally, so we can't just wave
	+ our hands and mutter something about the Strictness Theorem when we want to avoid
	+ dealing with units and associativities. However, in cases where we can establish that the
	+ property we would like to prove is reflected by the embedding of a bicategory in its
	+ strictification, then we can formally apply the Strictness Theorem to generalize to all
	+ bicategories a result proved for 2-categories. We will apply this approach here to
	+ simplify the proof of some facts about internal equivalences in a bicategory.
	+ \<close>
	+
	+ subsection "Normal and Strict Bicategories"
	+
	+ text \<open>
	+ A \emph{normal} bicategory is one in which the unit isomorphisms are identities,
	+ so that unit laws for horizontal composition are satisfied ``on the nose''.
	+ \<close>
	+
	+ locale normal_bicategory =
	+ bicategory +
	+ assumes strict_lunit: "\<And>f. ide f \<Longrightarrow> \<l>[f] = f"
	+ and strict_runit: "\<And>f. ide f \<Longrightarrow> \<r>[f] = f"
	+ begin
	+
	+ lemma strict_unit:
	+ assumes "obj a"
	+ shows "ide \<i>[a]"
	+ using assms strict_runit unitor_coincidence(2) [of a] by auto
	+
	+ lemma strict_lunit':
	+ assumes "ide f"
	+ shows "\<l>\<^sup>-\<^sup>1[f] = f"
	+ using assms strict_lunit by simp
	+
	+ lemma strict_runit':
	+ assumes "ide f"
	+ shows "\<r>\<^sup>-\<^sup>1[f] = f"
	+ using assms strict_runit by simp
	+
	+ lemma hcomp_obj_arr:
	+ assumes "obj b" and "arr f" and "b = trg f"
	+ shows "b \<star> f = f"
	+ using assms strict_lunit
	+ by (metis comp_arr_dom comp_ide_arr ide_cod ide_dom lunit_naturality)
	+
	+ lemma hcomp_arr_obj:
	+ assumes "arr f" and "obj a" and "src f = a"
	+ shows "f \<star> a = f"
	+ using assms strict_runit
	+ by (metis comp_arr_dom comp_ide_arr ide_cod ide_dom runit_naturality)
	+
	+ end
	+
	+ text \<open>
	+ A \emph{strict} bicategory is a normal bicategory in which the associativities are also
	+ identities, so that associativity of horizontal composition holds ``on the nose''.
	+ \<close>
	+
	+ locale strict_bicategory =
	+ normal_bicategory +
	+ assumes strict_assoc: "\<And>f g h. \<lbrakk>ide f; ide g; ide h; src f = trg g; src g = trg h\<rbrakk> \<Longrightarrow>
	+ ide \<a>[f, g, h]"
	+ begin
	+
	+ lemma strict_assoc':
	+ assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
	+ shows "ide \<a>\<^sup>-\<^sup>1[f, g, h]"
	+ using assms strict_assoc by simp
	+
	+ lemma hcomp_assoc:
	+ shows "(\<mu> \<star> \<nu>) \<star> \<tau> = \<mu> \<star> \<nu> \<star> \<tau>"
	+ proof (cases "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>")
	+ show "\<not> (hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>) \<Longrightarrow> ?thesis"
	+ by (metis hseqE hseq_char' match_1 match_2)
	+ show "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau> \<Longrightarrow> ?thesis"
	+ proof -
	+ assume 1: "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>"
	+ have 2: "arr \<mu> \<and> arr \<nu> \<and> arr \<tau> \<and> src \<mu> = trg \<nu> \<and> src \<nu> = trg \<tau>"
	+ using 1 by blast
	+ have "(\<mu> \<star> \<nu>) \<star> \<tau> = \<a>[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> ((\<mu> \<star> \<nu>) \<star> \<tau>)"
	+ using 1 assoc_in_hom strict_assoc comp_cod_arr assoc_simps(4) hseq_char
	+ by simp
	+ also have "... = (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]"
	+ using 1 assoc_naturality by auto
	+ also have "... = \<mu> \<star> \<nu> \<star> \<tau>"
	+ using 2 assoc_in_hom [of "dom \<mu>" "dom \<nu>" "dom \<tau>"] strict_assoc comp_arr_dom hseqI'
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ text \<open>
	+ In a strict bicategory, every canonical isomorphism is an identity.
	+ \<close>
	+
	+ interpretation bicategorical_language ..
	+ interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ lemma ide_eval_Can:
	+ assumes "Can t"
	+ shows "ide \<lbrace>t\<rbrace>"
	+ proof -
	+ have 1: "\<And>u1 u2. \<lbrakk> ide \<lbrace>u1\<rbrace>; ide \<lbrace>u2\<rbrace>; Arr u1; Arr u2; Dom u1 = Cod u2 \<rbrakk>
	+ \<Longrightarrow> ide (\<lbrace>u1\<rbrace> \<cdot> \<lbrace>u2\<rbrace>)"
	+ by (metis (no_types, lifting) E.eval_simps'(4-5) comp_ide_self ide_char)
	+ have "\<And>u. Can u \<Longrightarrow> ide \<lbrace>u\<rbrace>"
	+ proof -
	+ fix u
	+ show "Can u \<Longrightarrow> ide \<lbrace>u\<rbrace>"
	+ (* TODO: Rename \<ll>_ide_simp \<rr>_ide_simp to \<ll>_ide_eq \<rr>_ide_eq *)
	+ using 1 \<alpha>_def \<a>'_def strict_lunit strict_runit strict_assoc strict_assoc'
	+ \<ll>_ide_simp \<rr>_ide_simp Can_implies_Arr comp_ide_arr E.eval_simps'(2-3)
	+ apply (induct u) by auto
	+ qed
	+ thus ?thesis
	+ using assms by simp
	+ qed
	+
	+ lemma ide_can:
	+ assumes "Ide f" and "Ide g" and "\<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>g\<^bold>\<rfloor>"
	+ shows "ide (can g f)"
	+ proof -
	+ have "Can (Inv (g\<^bold>\<down>) \<^bold>\<cdot> f\<^bold>\<down>)"
	+ using assms Can_red Can_Inv red_in_Hom Inv_in_Hom by simp
	+ thus ?thesis
	+ using assms can_def ide_eval_Can by presburger
	+ qed
	+
	+ end
	+
	+ subsection "Strictification"
	+
	+ (*
	+ * TODO: Perhaps change the typeface used for a symbol that stands for a bicategory;
	+ * for example, to avoid the clashes here between B used as the name of a bicategory
	+ * and B used to denote a syntactic identity term.
	+ *)
	+
	+ text \<open>
	+ The Strictness Theorem asserts that every bicategory is biequivalent to a
	+ strict bicategory. More specifically, it shows how to construct, given an arbitrary
	+ bicategory, a strict bicategory (its \emph{strictification}) that is biequivalent to it.
	+ Consequently, given a property \<open>P\<close> of bicategories that is ``bicategorical''
	+ (\emph{i.e.}~respects biequivalence), if we want to show that \<open>P\<close> holds for a bicategory \<open>B\<close>
	+ then it suffices to show that \<open>P\<close> holds for the strictification of \<open>B\<close>, and if we want to show
	+ that \<open>P\<close> holds for all bicategories, it is sufficient to show that it holds for all
	+ strict bicategories. This is very useful, because it becomes quite tedious, even
	+ with the aid of a proof assistant, to do ``diagram chases'' with all the units and
	+ associativities fully spelled out.
	+
	+ Given a bicategory \<open>B\<close>, the strictification \<open>S\<close> of \<open>B\<close> may be constructed as the bicategory
	+ whose arrows are triples \<open>(A, B, \<mu>)\<close>, where \<open>X\<close> and \<open>Y\<close> are ``normal identity terms''
	+ (essentially, nonempty horizontally composable lists of 1-cells of \<open>B\<close>) having the same
	+ syntactic source and target, and \<open>\<guillemotleft>\<mu> : \<lbrace>X\<rbrace> \<Rightarrow> \<lbrace>Y\<rbrace>\<guillemotright>\<close> in \<open>B\<close>.
	+ Vertical composition in \<open>S\<close> is given by composition of the underlying arrows in \<open>B\<close>.
	+ Horizontal composition in \<open>S\<close> is given by \<open>(A, B, \<mu>) \<star> (A', B', \<mu>') = (AA', BB', \<nu>)\<close>,
	+ where \<open>AA'\<close> and \<open>BB'\<close> denote concatenations of lists and where \<open>\<nu>\<close> is defined as the
	+ composition \<open>can BB' (B \<^bold>\<star> B') \<cdot> (\<mu> \<star> \<mu>') \<cdot> can (A \<^bold>\<star> A') AA'\<close>, where \<open>can (A \<^bold>\<star> A') AA'\<close> and
	+ \<open>can BB' (B \<^bold>\<star> B')\<close> are canonical isomorphisms in \<open>B\<close>. The canonical isomorphism
	+ \<open>can (A \<^bold>\<star> A') AA'\<close> corresponds to taking a pair of lists \<open>A \<^bold>\<star> A'\<close> and
	+ ``shifting the parentheses to the right'' to obtain a single list \<open>AA'\<close>.
	+ The canonical isomorphism can \<open>BB' (B \<^bold>\<star> B')\<close> corresponds to the inverse rearrangement.
	+
	+ The bicategory \<open>B\<close> embeds into its strictification \<open>S\<close> via the functor \<open>UP\<close> that takes
	+ each arrow \<open>\<mu>\<close> of \<open>B\<close> to \<open>(\<^bold>\<langle>dom \<mu>\<^bold>\<rangle>, \<^bold>\<langle>cod \<mu>\<^bold>\<rangle>, \<mu>)\<close>, where \<open>\<^bold>\<langle>dom \<mu>\<^bold>\<rangle>\<close> and \<open>\<^bold>\<langle>cod \<mu>\<^bold>\<rangle>\<close> denote
	+ one-element lists. This mapping extends to a pseudofunctor.
	+ There is also a pseudofunctor \<open>DN\<close>, which maps \<open>(A, B, \<mu>)\<close> in \<open>S\<close> to \<open>\<mu>\<close> in \<open>B\<close>;
	+ this is such that \<open>DN o UP\<close> is the identity on \<open>B\<close> and \<open>UP o DN\<close> is equivalent to the
	+ identity on \<open>S\<close>, so we obtain a biequivalence between \<open>B\<close> and \<open>S\<close>.
	+
	+ It seems difficult to find references that explicitly describe a strictification
	+ construction in elementary terms like this (in retrospect, it ought to have been relatively
	+ easy to rediscover such a construction, but my thinking got off on the wrong track).
	+ One reference that I did find useful was \cite{unapologetic-strictification},
	+ which discusses strictification for monoidal categories.
	+ \<close>
	+
	+ locale strictified_bicategory =
	+ B: bicategory V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
	+ for V\<^sub>B :: "'a comp" (infixr "\<cdot>\<^sub>B" 55)
	+ and H\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>\<^sub>B" 53)
	+ and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>\<^sub>B[_, _, _]")
	+ and \<i>\<^sub>B :: "'a \<Rightarrow> 'a" ("\<i>\<^sub>B[_]")
	+ and src\<^sub>B :: "'a \<Rightarrow> 'a"
	+ and trg\<^sub>B :: "'a \<Rightarrow> 'a"
	+ begin
	+
	+ sublocale E: self_evaluation_map V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B ..
	+
	+ notation B.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
	+ notation B.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>B _\<guillemotright>")
	+
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+ notation E.Nmlize ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
	+
	+ text \<open>
	+ The following gives the construction of a bicategory whose arrows are triples \<open>(A, B, \<mu>)\<close>,
	+ where \<open>Nml A \<and> Ide A\<close>, \<open>Nml B \<and> Ide B\<close>, \<open>Src A = Src B\<close>, \<open>Trg A = Trg B\<close>, and \<open>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow> \<lbrace>B\<rbrace>\<close>.
	+ We use @{locale concrete_category} to construct the vertical composition, so formally the
	+ arrows of the bicategory will be of the form \<open>MkArr A B \<mu>\<close>.
	+ \<close>
	+
	+ text \<open>
	+ The 1-cells of the bicategory correspond to normal, identity terms \<open>A\<close>
	+ in the bicategorical language associated with \<open>B\<close>.
	+ \<close>
	+
	+ abbreviation IDE
	+ where "IDE \<equiv> {A. E.Nml A \<and> E.Ide A}"
	+
	+ text \<open>
	+ If terms \<open>A\<close> and \<open>B\<close> determine 1-cells of the strictification and have a
	+ common source and target, then the 2-cells between these 1-cells correspond
	+ to arrows \<open>\<mu>\<close> of the underlying bicategory such that \<open>\<guillemotleft>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>B\<rbrace>\<guillemotright>\<close>.
	+ \<close>
	+
	+ abbreviation HOM
	+ where "HOM A B \<equiv> {\<mu>. E.Src A = E.Src B \<and> E.Trg A = E.Trg B \<and> \<guillemotleft>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>B\<rbrace>\<guillemotright>}"
	+
	+ text \<open>
	+ The map taking term \<open>A \<in> OBJ\<close> to its evaluation \<open>\<lbrace>A\<rbrace> \<in> HOM A A\<close> defines the
	+ embedding of 1-cells as identity 2-cells.
	+ \<close>
	+
	+ abbreviation EVAL
	+ where "EVAL \<equiv> E.eval"
	+
	+ sublocale concrete_category IDE HOM EVAL \<open>\<lambda>_ _ _ \<mu> \<nu>. \<mu> \<cdot>\<^sub>B \<nu>\<close>
	+ using E.ide_eval_Ide B.comp_arr_dom B.comp_cod_arr B.comp_assoc
	+ by (unfold_locales, auto)
	+
	+ lemma is_concrete_category:
	+ shows "concrete_category IDE HOM EVAL (\<lambda>_ _ _ \<mu> \<nu>. \<mu> \<cdot>\<^sub>B \<nu>)"
	+ ..
	+
	+ notation comp (infixr "\<cdot>" 55)
	+ abbreviation vcomp where "vcomp \<equiv> comp"
	+
	+ lemma arr_char:
	+ shows "arr F \<longleftrightarrow>
	+ E.Nml (Dom F) \<and> E.Ide (Dom F) \<and> E.Nml (Cod F) \<and> E.Ide (Cod F) \<and>
	+ E.Src (Dom F) = E.Src (Cod F) \<and> E.Trg (Dom F) = E.Trg (Cod F) \<and>
	+ \<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright> \<and> F \<noteq> Null"
	+ using arr_char by auto
	+
	+ lemma arrI (* [intro] *):
	+ assumes "E.Nml (Dom F)" and "E.Ide (Dom F)" and "E.Nml (Cod F)" and "E.Ide (Cod F)"
	+ and "E.Src (Dom F) = E.Src (Cod F)" and "E.Trg (Dom F) = E.Trg (Cod F)"
	+ and "\<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright>" and "F \<noteq> Null"
	+ shows "arr F"
	+ using assms arr_char by blast
	+
	+ lemma arrE [elim]:
	+ assumes "arr F"
	+ shows "(\<lbrakk> E.Nml (Dom F); E.Ide (Dom F); E.Nml (Cod F); E.Ide (Cod F);
	+ E.Src (Dom F) = E.Src (Cod F); E.Trg (Dom F) = E.Trg (Cod F);
	+ \<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright>; F \<noteq> Null \<rbrakk> \<Longrightarrow> T) \<Longrightarrow> T"
	+ using assms arr_char by simp
	+
	+ lemma ide_char:
	+ shows "ide F \<longleftrightarrow> endo F \<and> B.ide (Map F)"
	+ proof
	+ show "ide F \<Longrightarrow> endo F \<and> B.ide (Map F)"
	+ using ide_char by (simp add: E.ide_eval_Ide)
	+ show "endo F \<and> B.ide (Map F) \<Longrightarrow> ide F"
	+ by (metis (no_types, lifting) B.ide_char B.in_homE arr_char ide_char
	+ mem_Collect_eq seq_char)
	+ qed
	+
	+ lemma ideI [intro]:
	+ assumes "arr F" and "Dom F = Cod F" and "B.ide (Map F)"
	+ shows "ide F"
	+ using assms ide_char dom_char cod_char seq_char by presburger
	+
	+ lemma ideE [elim]:
	+ assumes "ide F"
	+ shows "(\<lbrakk> arr F; Dom F = Cod F; B.ide (Map F); Map F = \<lbrace>Dom F\<rbrace>;
	+ Map F = \<lbrace>Cod F\<rbrace> \<rbrakk> \<Longrightarrow> T) \<Longrightarrow> T"
	+ proof -
	+ assume 1: "\<lbrakk> arr F; Dom F = Cod F; B.ide (Map F); Map F = \<lbrace>Dom F\<rbrace>;
	+ Map F = \<lbrace>Cod F\<rbrace> \<rbrakk> \<Longrightarrow> T"
	+ show T
	+ proof -
	+ have "arr F"
	+ using assms by auto
	+ moreover have "Dom F = Cod F"
	+ using assms ide_char dom_char cod_char
	+ by (metis (no_types, lifting) Dom_cod calculation ideD(3))
	+ moreover have "B.ide (Map F)"
	+ using assms ide_char by blast
	+ moreover have "Map F = \<lbrace>Dom F\<rbrace>"
	+ using assms ide_char dom_char Map_ide(1) by blast
	+ ultimately show T
	+ using 1 by simp
	+ qed
	+ qed
	+
	+ text \<open>
	+ Source and target are defined by the corresponding syntactic operations on terms.
	+ \<close>
	+
	+ definition src
	+ where "src F \<equiv> if arr F then MkIde (E.Src (Dom F)) else null"
	+
	+ definition trg
	+ where "trg F \<equiv> if arr F then MkIde (E.Trg (Dom F)) else null"
	+
	+ lemma src_simps [simp]:
	+ assumes "arr F"
	+ shows "Dom (src F) = E.Src (Dom F)" and "Cod (src F) = E.Src (Dom F)"
	+ and "Map (src F) = \<lbrace>E.Src (Dom F)\<rbrace>"
	+ using assms src_def arr_char by auto
	+
	+ lemma trg_simps [simp]:
	+ assumes "arr F"
	+ shows "Dom (trg F) = E.Trg (Dom F)" and "Cod (trg F) = E.Trg (Dom F)"
	+ and "Map (trg F) = \<lbrace>E.Trg (Dom F)\<rbrace>"
	+ using assms trg_def arr_char by auto
	+
	+ interpretation src: endofunctor vcomp src
	+ using src_def comp_char
	+ apply (unfold_locales)
	+ apply auto[4]
	+ proof -
	+ show "\<And>g f. seq g f \<Longrightarrow> src (g \<cdot> f) = src g \<cdot> src f"
	+ proof -
	+ fix g f
	+ assume gf: "seq g f"
	+ have "src (g \<cdot> f) = MkIde (E.Src (Dom (g \<cdot> f)))"
	+ using gf src_def comp_char by simp
	+ also have "... = MkIde (E.Src (Dom f))"
	+ using gf by (simp add: seq_char)
	+ also have "... = MkIde (E.Src (Dom g)) \<cdot> MkIde (E.Src (Dom f))"
	+ using gf seq_char by auto
	+ also have "... = src g \<cdot> src f"
	+ using gf src_def comp_char by auto
	+ finally show "src (g \<cdot> f) = src g \<cdot> src f" by blast
	+ qed
	+ qed
	+
	+ interpretation trg: endofunctor vcomp trg
	+ using trg_def comp_char
	+ apply (unfold_locales)
	+ apply auto[4]
	+ proof -
	+ show "\<And>g f. seq g f \<Longrightarrow> trg (g \<cdot> f) = trg g \<cdot> trg f"
	+ proof -
	+ fix g f
	+ assume gf: "seq g f"
	+ have "trg (g \<cdot> f) = MkIde (E.Trg (Dom (comp g f)))"
	+ using gf trg_def comp_char by simp
	+ also have "... = MkIde (E.Trg (Dom f))"
	+ using gf by (simp add: seq_char)
	+ also have "... = MkIde (E.Trg (Dom g)) \<cdot> MkIde (E.Trg (Dom f))"
	+ using gf seq_char by auto
	+ also have "... = trg g \<cdot> trg f"
	+ using gf trg_def comp_char by auto
	+ finally show "trg (g \<cdot> f) = trg g \<cdot> trg f" by blast
	+ qed
	+ qed
	+
	+ interpretation horizontal_homs vcomp src trg
	+ using src_def trg_def Cod_in_Obj Map_in_Hom
	+ by (unfold_locales, auto)
	+
	+ notation in_hhom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
	+
	+ definition hcomp (infixr "\<star>" 53)
	+ where "\<mu> \<star> \<nu> \<equiv> if arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>
	+ then MkArr (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)
	+ (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))
	+ else null"
	+
	+ lemma arr_hcomp:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
	+ shows "arr (\<mu> \<star> \<nu>)"
	+ proof -
	+ have 1: "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<and> E.Nml (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<and>
	+ E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<and> E.Nml (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
	+ using assms arr_char src_def trg_def E.Ide_HcompNml E.Nml_HcompNml(1) by auto
	+ moreover
	+ have "\<guillemotleft>B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) :
	+ \<lbrace>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<rbrace>\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>Map \<mu> \<star>\<^sub>B Map \<nu> : \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace>\<guillemotright>"
	+ using assms arr_char dom_char cod_char src_def trg_def E.eval_simps'(2-3)
	+ by simp
	+ moreover
	+ have "\<guillemotleft>B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) :
	+ \<lbrace>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace>\<guillemotright> \<and>
	+ \<guillemotleft>B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) :
	+ \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<rbrace>\<guillemotright>"
	+ using assms 1 arr_char B.can_in_hom src_def trg_def E.Ide.simps(3) by auto
	+ ultimately show ?thesis by auto
	+ qed
	+ moreover have "E.Src (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Src (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<and>
	+ E.Trg (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Trg (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
	+ using assms arr_char src_def trg_def
	+ by (simp add: E.Src_HcompNml E.Trg_HcompNml)
	+ ultimately show ?thesis
	+ unfolding hcomp_def
	+ using assms by (intro arrI, auto)
	+ qed
	+
	+ lemma src_hcomp [simp]:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
	+ shows "src (\<mu> \<star> \<nu>) = src \<nu>"
	+ using assms arr_char hcomp_def src_def trg_def arr_hcomp E.Src_HcompNml by simp
	+
	+ lemma trg_hcomp [simp]:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
	+ shows "trg (hcomp \<mu> \<nu>) = trg \<mu>"
	+ using assms arr_char hcomp_def src_def trg_def arr_hcomp E.Trg_HcompNml by simp
	+
	+ lemma hseq_char:
	+ shows "arr (\<mu> \<star> \<nu>) \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>"
	+ using arr_hcomp hcomp_def by simp
	+
	+ lemma Dom_hcomp [simp]:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
	+ shows "Dom (\<mu> \<star> \<nu>) = Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>"
	+ using assms hcomp_def [of \<mu> \<nu>] by simp
	+
	+ lemma Cod_hcomp [simp]:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
	+ shows "Cod (\<mu> \<star> \<nu>) = Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>"
	+ using assms hcomp_def [of \<mu> \<nu>] by simp
	+
	+ lemma Map_hcomp [simp]:
	+ assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
	+ shows "Map (\<mu> \<star> \<nu>) = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)"
	+ using assms hcomp_def [of \<mu> \<nu>] by simp
	+
	+ interpretation VxV: product_category vcomp vcomp ..
	+ interpretation VV: subcategory VxV.comp
	+ \<open>\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and> src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)\<close>
	+ using subcategory_VV by simp
	+
	+ interpretation H: "functor" VV.comp vcomp \<open>\<lambda>\<mu>\<nu>. hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
	+ proof
	+ show "\<And>f. \<not> VV.arr f \<Longrightarrow> fst f \<star> snd f = null"
	+ using hcomp_def by auto
	+ show A: "\<And>f. VV.arr f \<Longrightarrow> arr (fst f \<star> snd f)"
	+ using VV.arrE hseq_char by blast
	+ show "\<And>f. VV.arr f \<Longrightarrow> dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
	+ proof -
	+ fix f
	+ assume f: "VV.arr f"
	+ have "dom (fst f \<star> snd f) = MkIde (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
	+ using f VV.arrE [of f] dom_char arr_hcomp hcomp_def by simp
	+ also have "... = fst (VV.dom f) \<star> snd (VV.dom f)"
	+ proof -
	+ have "hcomp (fst (VV.dom f)) (snd (VV.dom f)) =
	+ MkArr (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))
	+ (B.can (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<star> Dom (snd f)) \<cdot>\<^sub>B
	+ (\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
	+ using f VV.arrE [of f] arr_hcomp hcomp_def by simp
	+ moreover have "B.can (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<star> Dom (snd f)) \<cdot>\<^sub>B
	+ (\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) =
	+ \<lbrace>Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)\<rbrace>"
	+ proof -
	+ have 1: "E.Ide (Dom (fst f) \<^bold>\<star> Dom (snd f))"
	+ using f VV.arr_char arr_char dom_char
	+ apply simp
	+ by (metis (no_types, lifting) src_simps(1) trg_simps(1))
	+ have 2: "E.Ide (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
	+ using f VV.arr_char arr_char dom_char
	+ apply simp
	+ by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
	+ have 3: "\<^bold>\<lfloor>Dom (fst f) \<^bold>\<star> Dom (snd f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)\<^bold>\<rfloor>"
	+ using f VV.arr_char arr_char dom_char
	+ apply simp
	+ by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
	+ src_simps(1) trg_simps(1))
	+ have "(\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) =
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
	+ proof -
	+ have "B.in_hom (B.can (Dom (fst f) \<^bold>\<star> Dom (snd f))
	+ (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))
	+ \<lbrace>Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)\<rbrace> (\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>)"
	+ using 1 2 3 f VV.arr_char arr_char
	+ B.can_in_hom [of "Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)" "Dom (fst f) \<^bold>\<star> Dom (snd f)"]
	+ by simp
	+ thus ?thesis
	+ using B.comp_cod_arr by auto
	+ qed
	+ thus ?thesis
	+ using 1 2 3 f VV.arr_char B.can_Ide_self B.vcomp_can by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ finally show "dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
	+ by simp
	+ qed
	+ show "\<And>f. VV.arr f \<Longrightarrow> cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
	+ proof -
	+ fix f
	+ assume f: "VV.arr f"
	+ have "cod (fst f \<star> snd f) = MkIde (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
	+ using f VV.arrE [of f] cod_char arr_hcomp hcomp_def by simp
	+ also have "... = fst (VV.cod f) \<star> snd (VV.cod f)"
	+ proof -
	+ have "hcomp (fst (VV.cod f)) (snd (VV.cod f)) =
	+ MkArr (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))
	+ (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
	+ (\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)))"
	+ using f VV.arrE [of f] arr_hcomp hcomp_def by simp
	+ moreover have "B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
	+ (\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) =
	+ \<lbrace>Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)\<rbrace>"
	+ proof -
	+ have 1: "E.Ide (Cod (fst f) \<^bold>\<star> Cod (snd f))"
	+ using f VV.arr_char arr_char dom_char
	+ apply simp
	+ by (metis (no_types, lifting) src_simps(1) trg_simps(1))
	+ have 2: "E.Ide (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
	+ using f VV.arr_char arr_char dom_char
	+ apply simp
	+ by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
	+ have 3: "\<^bold>\<lfloor>Cod (fst f) \<^bold>\<star> Cod (snd f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)\<^bold>\<rfloor>"
	+ using f VV.arr_char arr_char dom_char
	+ apply simp
	+ by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
	+ src_simps(1) trg_simps(1))
	+ have "(\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) =
	+ B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
	+ proof -
	+ have "B.in_hom (B.can (Cod (fst f) \<^bold>\<star> Cod (snd f))
	+ (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)))
	+ \<lbrace>Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)\<rbrace> (\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>)"
	+ using 1 2 3 f VV.arr_char arr_char
	+ B.can_in_hom [of "Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)"
	+ "Cod (fst f) \<^bold>\<star> Cod (snd f)"]
	+ by simp
	+ thus ?thesis
	+ using B.comp_cod_arr by auto
	+ qed
	+ thus ?thesis
	+ using 1 2 3 f VV.arr_char B.can_Ide_self B.vcomp_can by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ finally show "cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
	+ by simp
	+ qed
	+ show "\<And>g f. VV.seq g f \<Longrightarrow>
	+ fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
	+ proof -
	+ fix f g
	+ assume fg: "VV.seq g f"
	+ have f: "arr (fst f) \<and> arr (snd f) \<and> src (fst f) = trg (snd f)"
	+ using fg VV.seq_char VV.arr_char by simp
	+ have g: "arr (fst g) \<and> arr (snd g) \<and> src (fst g) = trg (snd g)"
	+ using fg VV.seq_char VV.arr_char by simp
	+ have 1: "arr (fst (VV.comp g f)) \<and> arr (snd (VV.comp g f)) \<and>
	+ src (fst (VV.comp g f)) = trg (snd (VV.comp g f))"
	+ using fg VV.arrE by blast
	+ have 0: "VV.comp g f = (fst g \<cdot> fst f, snd g \<cdot> snd f)"
	+ using fg 1 VV.comp_char VxV.comp_char
	+ by (metis (no_types, lifting) VV.seq_char VxV.seqE)
	+ let ?X = "MkArr (Dom (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd (VV.comp g f)))
	+ (Cod (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd (VV.comp g f)))
	+ (B.can (Cod (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd (VV.comp g f)))
	+ (Cod (fst (VV.comp g f)) \<^bold>\<star> Cod (snd (VV.comp g f))) \<cdot>\<^sub>B
	+ (Map (fst (VV.comp g f)) \<star>\<^sub>B Map (snd (VV.comp g f))) \<cdot>\<^sub>B
	+ B.can (Dom (fst (VV.comp g f)) \<^bold>\<star> Dom (snd (VV.comp g f)))
	+ (Dom (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd (VV.comp g f))))"
	+ have 2: "fst (VV.comp g f) \<star> snd (VV.comp g f) = ?X"
	+ unfolding hcomp_def using 1 by simp
	+ also have "... = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
	+ proof -
	+ let ?GG = "MkArr (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g))
	+ (B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
	+ (Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
	+ B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)))"
	+ let ?FF = "MkArr (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))
	+ (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
	+ (Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
	+ have 4: "arr ?FF \<and> arr ?GG \<and> Dom ?GG = Cod ?FF"
	+ proof -
	+ have "arr ?FF \<and> arr ?GG"
	+ using f g fg VV.arr_char VV.seqE hcomp_def A by presburger
	+ thus ?thesis
	+ using 0 1 by (simp add: fg seq_char)
	+ qed
	+ have "(fst g \<star> snd g) \<cdot> (fst f \<star> snd f) = ?GG \<cdot> ?FF"
	+ unfolding hcomp_def
	+ using 1 f g fg VV.arr_char VV.seqE by simp
	+ also have "... = ?X"
	+ proof (intro arr_eqI)
	+ show "seq ?GG ?FF"
	+ using fg 4 seq_char by blast
	+ show "arr ?X"
	+ using fg 1 arr_hcomp hcomp_def by simp
	+ show "Dom (?GG \<cdot> ?FF) = Dom ?X"
	+ using fg 0 1 4 seq_char by simp
	+ show "Cod (?GG \<cdot> ?FF) = Cod ?X"
	+ using fg 0 1 4 seq_char by simp
	+ show "Map (?GG \<cdot> ?FF) = Map ?X"
	+ proof -
	+ have "Map (?GG \<cdot> ?FF) = Map ?GG \<cdot>\<^sub>B Map ?FF"
	+ using 4 by auto
	+ also have
	+ "... = (B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
	+ (Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
	+ B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
	+ (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
	+ (Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
	+ using fg by simp
	+ also have
	+ "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
	+ ((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
	+ proof -
	+ have "(B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
	+ (Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
	+ B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
	+ (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
	+ (Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))) =
	+ B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
	+ ((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
	+ (B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
	+ B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
	+ (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
	+ using B.comp_assoc by simp
	+ also have "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
	+ ((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
	+ proof -
	+ have "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
	+ (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) =
	+ \<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace>"
	+ proof -
	+ have "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
	+ (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) =
	+ B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Cod (fst f) \<^bold>\<star> Cod (snd f))"
	+ proof -
	+ have "E.Ide (Dom (fst g) \<^bold>\<star> Dom (snd g))"
	+ using g arr_char
	+ apply simp
	+ by (metis (no_types, lifting) src_simps(1) trg_simps(1))
	+ moreover have "E.Ide (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))"
	+ using g arr_char
	+ apply simp
	+ by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
	+ moreover have "E.Ide (Cod (fst f) \<^bold>\<star> Cod (snd f))"
	+ using f arr_char
	+ apply simp
	+ by (metis (no_types, lifting) src_simps(1) trg_simps(1))
	+ moreover have
	+ "\<^bold>\<lfloor>Dom (fst g) \<^bold>\<star> Dom (snd g)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)\<^bold>\<rfloor>"
	+ using g
	+ apply simp
	+ by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
	+ arrE src_simps(1) trg_simps(1))
	+ moreover have
	+ "\<^bold>\<lfloor>Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst f) \<^bold>\<star> Cod (snd f)\<^bold>\<rfloor>"
	+ using g
	+ apply simp
	+ by (metis (no_types, lifting) "0" "1" E.Nmlize.simps(3)
	+ calculation(4) fst_conv seq_char snd_conv)
	+ moreover have
	+ "Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g) = Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)"
	+ using 0 1 by (simp add: seq_char)
	+ ultimately show ?thesis
	+ using B.vcomp_can by simp
	+ qed
	+ also have "... = \<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace>"
	+ proof -
	+ have "Dom (fst g) \<^bold>\<star> Dom (snd g) = Cod (fst f) \<^bold>\<star> Cod (snd f)"
	+ using 0 f g fg seq_char VV.seq_char VV.arr_char
	+ by simp
	+ thus ?thesis
	+ using f B.can_Ide_self [of "Dom (fst f) \<^bold>\<star> Dom (snd f)"]
	+ apply simp
	+ by (metis (no_types, lifting) B.can_Ide_self E.eval.simps(3)
	+ E.Ide.simps(3) arr_char src_simps(2) trg_simps(2))
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ hence "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
	+ B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
	+ (Map (fst f) \<star>\<^sub>B Map (snd f)) =
	+ \<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace> \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))"
	+ by simp
	+ also have "... = Map (fst f) \<star>\<^sub>B Map (snd f)"
	+ proof -
	+ have 1: "\<forall>p. arr p \<longrightarrow> map (cod p) \<cdot> map p = map p"
	+ by blast
	+ have 3: "\<lbrace>Cod (fst f)\<rbrace> \<cdot>\<^sub>B Map (fst f) = Map (map (cod (fst f)) \<cdot> map (fst f))"
	+ by (simp add: f)
	+ have 4: "map (cod (fst f)) \<cdot> map (fst f) = fst f"
	+ using 1 f map_simp by simp
	+ show ?thesis
	+ proof -
	+ have 2: "\<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) = Map (snd f)"
	+ proof -
	+ have "\<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) =
	+ Map (map (cod (snd f)) \<cdot> map (snd f))"
	+ by (simp add: f)
	+ moreover have "map (cod (snd f)) \<cdot> map (snd f) = snd f"
	+ using 1 f map_simp by simp
	+ ultimately show ?thesis by presburger
	+ qed
	+ have "B.seq \<lbrace>Cod (snd f)\<rbrace> (Map (snd f))"
	+ using f 2 by auto
	+ moreover have "B.seq \<lbrace>Cod (fst f)\<rbrace> (Map (fst f))"
	+ using 4 f 3 by auto
	+ moreover have
	+ "\<lbrace>Cod (fst f)\<rbrace> \<cdot>\<^sub>B Map (fst f) \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) =
	+ Map (fst f) \<star>\<^sub>B Map (snd f)"
	+ using 2 3 4 by presburger
	+ ultimately show ?thesis
	+ by (simp add: B.interchange)
	+ qed
	+ qed
	+ finally have
	+ "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
	+ B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
	+ (Map (fst f) \<star>\<^sub>B Map (snd f)) =
	+ Map (fst f) \<star>\<^sub>B Map (snd f)"
	+ by simp
	+ thus ?thesis
	+ using fg B.comp_cod_arr by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
	+ (Map (fst g \<cdot> fst f) \<star>\<^sub>B Map (snd g \<cdot> snd f)) \<cdot>\<^sub>B
	+ B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
	+ proof -
	+ have 2: "Dom (fst g) = Cod (fst f)"
	+ using 0 f g fg VV.seq_char [of g f] VV.arr_char arr_char seq_char
	+ by (metis (no_types, lifting) fst_conv)
	+ hence "Map (fst g \<cdot> fst f) = Map (fst g) \<cdot>\<^sub>B Map (fst f)"
	+ using f g Map_comp [of "fst f" "fst g"] by simp
	+ moreover have "B.seq (Map (fst g)) (Map (fst f)) \<and>
	+ B.seq (Map (snd g)) (Map (snd f))"
	+ using f g 0 1 2 arr_char
	+ by (metis (no_types, lifting) B.seqI' prod.sel(2) seq_char)
	+ ultimately show ?thesis
	+ using 0 1 seq_char Map_comp B.interchange by auto
	+ qed
	+ also have "... = Map ?X"
	+ using fg 0 1 by (simp add: seq_char)
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ finally show "fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
	+ by simp
	+ qed
	+ qed
	+
	+ interpretation H: horizontal_composition vcomp hcomp src trg
	+ using hseq_char by (unfold_locales, auto)
	+
	+ lemma hcomp_assoc:
	+ assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>"
	+ and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
	+ shows "(\<mu> \<star> \<nu>) \<star> \<tau> = \<mu> \<star> \<nu> \<star> \<tau>"
	+ proof (intro arr_eqI)
	+ have \<mu>\<nu>: "\<guillemotleft>Map \<mu> \<star>\<^sub>B Map \<nu> : \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace>\<guillemotright>"
	+ using assms src_def trg_def arr_char
	+ by (auto simp add: E.eval_simps'(2-3) Pair_inject)
	+ have \<nu>\<tau>: "\<guillemotleft>Map \<nu> \<star>\<^sub>B Map \<tau> : \<lbrace>Dom \<nu> \<^bold>\<star> Dom \<tau>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<nu> \<^bold>\<star> Cod \<tau>\<rbrace>\<guillemotright>"
	+ using assms src_def trg_def arr_char
	+ by (auto simp add: E.eval_simps'(2-3) Pair_inject)
	+ show "H.hseq (\<mu> \<star> \<nu>) \<tau>"
	+ using assms \<mu>\<nu> \<nu>\<tau> by auto
	+ show "H.hseq \<mu> (\<nu> \<star> \<tau>)"
	+ using assms \<mu>\<nu> \<nu>\<tau> by auto
	+ show "Dom ((\<mu> \<star> \<nu>) \<star> \<tau>) = Dom (\<mu> \<star> \<nu> \<star> \<tau>)"
	+ unfolding hcomp_def
	+ using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc src_def trg_def arr_char
	+ E.Src_HcompNml E.Trg_HcompNml E.Nml_HcompNml E.Ide_HcompNml
	+ B.can_in_hom [of "Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>" "Dom \<mu> \<^bold>\<star> Dom \<nu>"]
	+ B.can_in_hom [of "Cod \<mu> \<^bold>\<star> Cod \<nu>" "Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>"]
	+ B.can_in_hom [of "Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>" "Dom \<nu> \<^bold>\<star> Dom \<tau>"]
	+ B.can_in_hom [of "Cod \<nu> \<^bold>\<star> Cod \<tau>" "Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>"]
	+ by simp
	+ show "Cod ((\<mu> \<star> \<nu>) \<star> \<tau>) = Cod (\<mu> \<star> \<nu> \<star> \<tau>)"
	+ unfolding hcomp_def
	+ using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc src_def trg_def arr_char
	+ E.Src_HcompNml E.Trg_HcompNml E.Nml_HcompNml E.Ide_HcompNml
	+ B.can_in_hom [of "Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>" "Dom \<mu> \<^bold>\<star> Dom \<nu>"]
	+ B.can_in_hom [of "Cod \<mu> \<^bold>\<star> Cod \<nu>" "Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>"]
	+ B.can_in_hom [of "Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>" "Dom \<nu> \<^bold>\<star> Dom \<tau>"]
	+ B.can_in_hom [of "Cod \<nu> \<^bold>\<star> Cod \<tau>" "Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>"]
	+ by simp
	+ show "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) = Map (\<mu> \<star> \<nu> \<star> \<tau>)"
	+ proof -
	+ have "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) =
	+ B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
	+ proof -
	+ have 1: "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) =
	+ B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
	+ unfolding hcomp_def
	+ using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc src_def trg_def arr_char
	+ E.Src_HcompNml E.Trg_HcompNml E.Nml_HcompNml E.Ide_HcompNml
	+ B.can_in_hom [of "Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>" "Dom \<mu> \<^bold>\<star> Dom \<nu>"]
	+ B.can_in_hom [of "Cod \<mu> \<^bold>\<star> Cod \<nu>" "Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>"]
	+ B.can_in_hom [of "Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>" "Dom \<nu> \<^bold>\<star> Dom \<tau>"]
	+ B.can_in_hom [of "Cod \<nu> \<^bold>\<star> Cod \<tau>" "Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>"]
	+ by simp
	+ also have
	+ "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)) \<cdot>\<^sub>B
	+ B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
	+ proof -
	+ have
	+ "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau> =
	+ B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
	+ proof -
	+ have "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)
	+ \<star>\<^sub>B Map \<tau> =
	+ (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
	+ ((Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau>)"
	+ proof -
	+ have "B.seq (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>))
	+ ((Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))"
	+ by (metis (no_types, lifting) B.arrI Map_hcomp arrE arr_hcomp
	+ assms(1) assms(2) assms(4))
	+ moreover have "B.seq (B.can (Cod \<tau>) (Cod \<tau>)) (Map \<tau>)"
	+ using B.can_in_hom assms(3) by blast
	+ moreover have "B.ide (B.can (Cod \<tau>) (Cod \<tau>))"
	+ using B.can_Ide_self E.ide_eval_Ide arr_char assms(3) by presburger
	+ ultimately show ?thesis
	+ by (metis (no_types) B.comp_ide_arr B.interchange)
	+ qed
	+ also have
	+ "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
	+ ((Map \<mu> \<star>\<^sub>B Map \<nu>) \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
	+ B.can (Dom \<tau>) (Dom \<tau>))"
	+ proof -
	+ have "B.seq (Map \<mu> \<star>\<^sub>B Map \<nu>) (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))"
	+ by (metis (no_types, lifting) B.arrI B.comp_null(2) B.ext Map_hcomp
	+ arrE arr_hcomp assms(1) assms(2) assms(4))
	+ moreover have "B.seq (Map \<tau>) (B.can (Dom \<tau>) (Dom \<tau>))"
	+ using assms(3) by fastforce
	+ ultimately show ?thesis
	+ using B.interchange
	+ by (metis (no_types, lifting) B.can_Ide_self B.comp_arr_ide E.ide_eval_Ide
	+ arrE assms(3))
	+ qed
	+ also have
	+ "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
	+ (B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)) \<cdot>\<^sub>B
	+ (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
	+ B.can (Dom \<tau>) (Dom \<tau>))"
	+ proof -
	+ have "(Map \<mu> \<star>\<^sub>B Map \<nu>) \<star>\<^sub>B Map \<tau> =
	+ B.\<a>' \<lbrace>Cod \<mu>\<rbrace> \<lbrace>Cod \<nu>\<rbrace> \<lbrace>Cod \<tau>\<rbrace> \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ \<a>\<^sub>B \<lbrace>Dom \<mu>\<rbrace> \<lbrace>Dom \<nu>\<rbrace> \<lbrace>Dom \<tau>\<rbrace>"
	+ using B.hcomp_reassoc(1)
	+ by (metis (no_types, lifting) B.hcomp_in_vhomE B.in_homE \<mu>\<nu> \<nu>\<tau> arrE
	+ assms(1) assms(2) assms(3))
	+ also have "... = B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
	+ using assms arr_char src_def trg_def arr_char B.canE_associator by simp
	+ finally show ?thesis by simp
	+ qed
	+ also have
	+ "... = ((B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
	+ (B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>))) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
	+ (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
	+ B.can (Dom \<tau>) (Dom \<tau>)))"
	+ using B.comp_assoc by simp
	+ also have
	+ "... = B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
	+ proof -
	+ have "(B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
	+ (B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)) =
	+ B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
	+ proof -
	+ have "E.Ide (Cod \<mu> \<^bold>\<star> Cod \<nu>)"
	+ by (metis (no_types, lifting) E.Ide.simps(3) arrE assms(1-2,4)
	+ src_simps(1) trg_simps(1))
	+ moreover have "E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
	+ using E.Ide_HcompNml assms(1) assms(2) calculation by auto
	+ moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu>\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<^bold>\<rfloor>"
	+ using E.Nml_HcompNml(1) assms(1) assms(2) calculation(1) by fastforce
	+ moreover have "E.Src (Cod \<mu> \<^bold>\<star> Cod \<nu>) = E.Trg (Cod \<tau>)"
	+ by (metis (no_types, lifting) E.Src.simps(3) arrE assms(2-3,5)
	+ src_simps(2) trg_simps(2))
	+ moreover have "E.Src (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) = E.Trg (Cod \<tau>)"
	+ using E.Src_HcompNml assms(1) assms(2) calculation(1) calculation(4)
	+ by fastforce
	+ moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor>"
	+ by (metis (no_types, lifting) E.Arr.simps(3) E.Nmlize_Hcomp_Hcomp
	+ E.Nmlize_Hcomp_Hcomp' E.Ide_implies_Arr E.Src.simps(3) arrE assms(3)
	+ calculation(1) calculation(4))
	+ ultimately show ?thesis
	+ using assms(3) B.hcomp_can B.vcomp_can by auto
	+ qed
	+ moreover have
	+ "B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
	+ (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B B.can (Dom \<tau>) (Dom \<tau>)) =
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
	+ proof -
	+ have "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)"
	+ by (metis (no_types, lifting) E.Ide_HcompNml arrE assms(1-2,4)
	+ src_simps(2) trg_simps(2))
	+ moreover have "E.Ide (Dom \<mu> \<^bold>\<star> Dom \<nu>)"
	+ by (metis (no_types, lifting) E.Ide.simps(3) arrE assms(1-2,4)
	+ src_simps(1) trg_simps(1))
	+ moreover have "\<^bold>\<lfloor>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu>\<^bold>\<rfloor>"
	+ using E.Nml_HcompNml(1) assms(1-2) calculation(2) by fastforce
	+ moreover have "E.Src (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Trg (Dom \<tau>)"
	+ by (metis (no_types, lifting) E.Ide.simps(3) E.Src_HcompNml arrE
	+ assms(1-3,5) calculation(2) src_simps(2) trg_simps(2))
	+ moreover have "E.Src (Dom \<mu> \<^bold>\<star> Dom \<nu>) = E.Trg (Dom \<tau>)"
	+ using E.Src_HcompNml assms(1-2) calculation(2) calculation(4)
	+ by fastforce
	+ moreover have "E.Ide ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
	+ using E.Ide.simps(3) assms(3) calculation(2) calculation(5) by blast
	+ moreover have "\<^bold>\<lfloor>(Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor>"
	+ using E.Nmlize_Hcomp_Hcomp calculation(6) by auto
	+ ultimately show ?thesis
	+ using assms(3) B.hcomp_can B.vcomp_can by auto
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have
	+ "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
	+ B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
	+ using B.comp_assoc by simp
	+ also have "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
	+ proof -
	+ have "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) =
	+ B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
	+ proof -
	+ have "E.Ide (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
	+ using assms src_def trg_def by fastforce
	+ moreover have "E.Ide ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>)"
	+ using assms arr_char src_def trg_def E.Ide_HcompNml E.Src_HcompNml
	+ by auto
	+ moreover have "E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>)"
	+ using assms arr_char src_def trg_def
	+ by (simp add: E.Nml_HcompNml(1) E.Ide_HcompNml E.Trg_HcompNml)
	+ moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor>"
	+ using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc by simp
	+ moreover have "\<^bold>\<lfloor>(Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>\<^bold>\<rfloor>"
	+ using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc
	+ by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ moreover have
	+ "B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
	+ B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
	+ proof -
	+ have "E.Ide (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>)"
	+ using assms src_def trg_def by fastforce
	+ moreover have "E.Ide ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
	+ using assms arr_char src_def trg_def E.Ide_HcompNml E.Src_HcompNml
	+ by auto
	+ moreover have "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
	+ using assms arr_char src_def trg_def
	+ by (simp add: E.Nml_HcompNml(1) E.Ide_HcompNml E.Trg_HcompNml)
	+ moreover have "\<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor>"
	+ using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc by simp
	+ moreover have
	+ "\<^bold>\<lfloor>(Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>\<^bold>\<rfloor>"
	+ using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc
	+ by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = Map (\<mu> \<star> \<nu> \<star> \<tau>)"
	+ proof -
	+ have 1: "Map (\<mu> \<star> \<nu> \<star> \<tau>) =
	+ B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
	+ using assms H.hseqI' Map_hcomp [of \<mu> "\<nu> \<star> \<tau>"] Map_hcomp [of \<nu> \<tau>] by simp
	+ also have
	+ "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
	+ ((B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ (B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
	+ B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
	+ proof -
	+ have "Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
	+ (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
	+ using assms B.interchange B.comp_cod_arr
	+ by (metis (no_types, lifting) B.can_Ide_self B.in_homE Map_hcomp arrE hseq_char)
	+ also have "... = (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B
	+ B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ (B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
	+ B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
	+ using assms B.interchange B.comp_arr_dom [of "Map \<mu>" "B.can (Dom \<mu>) (Dom \<mu>)"]
	+ by (metis (no_types, lifting) B.can_Ide_self B.comp_null(2) B.ext B.in_homE
	+ Map_hcomp arrE hseq_char)
	+ finally have
	+ "Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
	+ (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ (B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
	+ by simp
	+ thus ?thesis by simp
	+ qed
	+ also have
	+ "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
	+ (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>))) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ ((B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
	+ B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
	+ using B.comp_assoc by simp
	+ also have "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
	+ (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
	+ B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
	+ using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc src_def trg_def arr_char
	+ E.Src_HcompNml E.Trg_HcompNml E.Nml_HcompNml E.Ide_HcompNml
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis by metis
	+ qed
	+ qed
	+
	+ lemma obj_char:
	+ shows "obj a \<longleftrightarrow> endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
	+ proof
	+ assume a: "obj a"
	+ show "endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
	+ proof (intro conjI)
	+ show "endo a"
	+ using a ide_char by blast
	+ show "E.Obj (Dom a)"
	+ using a ide_char src_def
	+ by (metis (no_types, lifting) E.Ide_implies_Arr E.Obj_Trg arrE obj_def
	+ trg_simps(1) trg_src)
	+ show "Map a = \<lbrace>Dom a\<rbrace>"
	+ using a ide_char src_def by blast
	+ qed
	+ next
	+ assume a: "endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
	+ show "obj a"
	+ proof -
	+ have "arr a" using a by auto
	+ moreover have "src a = a"
	+ using a E.Obj_in_Hom(1) seq_char by (intro arr_eqI, auto)
	+ ultimately show ?thesis
	+ using obj_def by simp
	+ qed
	+ qed
	+
	+ lemma hcomp_obj_self:
	+ assumes "obj a"
	+ shows "a \<star> a = a"
	+ proof (intro arr_eqI)
	+ show "H.hseq a a"
	+ using assms by auto
	+ show "arr a"
	+ using assms by auto
	+ show 1: "Dom (a \<star> a) = Dom a"
	+ unfolding hcomp_def
	+ using assms arr_char E.HcompNml_Trg_Nml
	+ apply simp
	+ by (metis (no_types, lifting) objE obj_def trg_simps(1))
	+ show 2: "Cod (a \<star> a) = Cod a"
	+ unfolding hcomp_def
	+ using assms 1 arr_char E.HcompNml_Trg_Nml
	+ apply simp
	+ by (metis (no_types, lifting) Dom_hcomp ideE objE)
	+ show "Map (a \<star> a) = Map a"
	+ proof -
	+ have "Map (a \<star> a) = B.can (Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a) (Cod a \<^bold>\<star> Cod a) \<cdot>\<^sub>B
	+ (Map a \<star>\<^sub>B Map a) \<cdot>\<^sub>B
	+ B.can (Dom a \<^bold>\<star> Dom a) (Dom a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a)"
	+ using assms Map_hcomp by auto
	+ also have "... = B.can (Dom a) (Dom a \<^bold>\<star> Dom a) \<cdot>\<^sub>B
	+ (\<lbrace>Dom a\<rbrace> \<star>\<^sub>B \<lbrace>Dom a\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom a \<^bold>\<star> Dom a) (Dom a)"
	+ proof -
	+ have "Dom a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a = Dom a"
	+ using assms obj_char arr_char E.HcompNml_Trg_Nml
	+ by (metis (no_types, lifting) ideE objE obj_def' trg_simps(2))
	+ moreover have "Cod a = Dom a"
	+ using assms obj_char arr_char dom_char cod_char objE ide_char'
	+ by (metis (no_types, lifting) src_simps(1) src_simps(2))
	+ moreover have "Map a = \<lbrace>Dom a\<rbrace>"
	+ using assms obj_char by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = B.can (Dom a) (Dom a \<^bold>\<star> Dom a) \<cdot>\<^sub>B B.can (Dom a \<^bold>\<star> Dom a) (Dom a)"
	+ using assms obj_char arr_char B.comp_cod_arr E.ide_eval_Ide B.can_in_hom
	+ by (metis (no_types, lifting) H.ide_hcomp obj_def obj_def'
	+ calculation B.comp_ide_arr B.ide_hcomp B.hseqE B.ideD(1) ide_char B.seqE)
	+ also have "... = \<lbrace>Dom a\<rbrace>"
	+ using assms 1 2 obj_char arr_char B.vcomp_can calculation H.ide_hcomp ideE objE
	+ by (metis (no_types, lifting))
	+ also have "... = Map a"
	+ using assms obj_char by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma hcomp_ide_src:
	+ assumes "ide f"
	+ shows "f \<star> src f = f"
	+ proof (intro arr_eqI)
	+ show "H.hseq f (src f)"
	+ using assms by simp
	+ show "arr f"
	+ using assms by simp
	+ show 1: "Dom (f \<star> src f) = Dom f"
	+ unfolding hcomp_def
	+ using assms apply simp
	+ using assms ide_char arr_char E.HcompNml_Nml_Src
	+ by (metis (no_types, lifting) ideD(1))
	+ show "Cod (f \<star> src f) = Cod f"
	+ unfolding hcomp_def
	+ using assms apply simp
	+ using assms ide_char arr_char E.HcompNml_Nml_Src
	+ by (metis (no_types, lifting) ideD(1))
	+ show "Map (f \<star> src f) = Map f"
	+ proof -
	+ have "Map (f \<star> src f) = B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (src f)) (Cod f \<^bold>\<star> Cod (src f)) \<cdot>\<^sub>B
	+ (Map f \<star>\<^sub>B Map (src f)) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> Dom (src f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (src f))"
	+ unfolding hcomp_def
	+ using assms by simp
	+ also have "... = B.can (Dom f) (Dom f \<^bold>\<star> E.Src (Dom f)) \<cdot>\<^sub>B
	+ (\<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f)"
	+ using assms arr_char E.HcompNml_Nml_Src by fastforce
	+ also have "... = B.can (Dom f) (Dom f \<^bold>\<star> E.Src (Dom f)) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f)"
	+ proof -
	+ have "\<guillemotleft>B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f) :
	+ \<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>\<guillemotright>"
	+ using assms ide_char arr_char B.can_in_hom
	+ by (metis (no_types, lifting) B.canE_unitor(3) B.runit'_in_vhom E.eval_simps(2)
	+ E.Ide_implies_Arr ideE)
	+ thus ?thesis
	+ using B.comp_cod_arr by auto
	+ qed
	+ also have "... = \<lbrace>Dom f\<rbrace>"
	+ using assms 1 ide_char arr_char
	+ by (metis (no_types, lifting) H.ide_hcomp calculation ideE ide_src obj_def' obj_src)
	+ also have "... = Map f"
	+ using assms by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma hcomp_trg_ide:
	+ assumes "ide f"
	+ shows "trg f \<star> f = f"
	+ proof (intro arr_eqI)
	+ show "H.hseq (trg f) f"
	+ using assms by auto
	+ show "arr f"
	+ using assms by auto
	+ show 1: "Dom (trg f \<star> f) = Dom f"
	+ unfolding hcomp_def
	+ using assms apply simp
	+ using assms ide_char arr_char E.HcompNml_Trg_Nml
	+ by (metis (no_types, lifting) ideD(1))
	+ show "Cod (trg f \<star> f) = Cod f"
	+ unfolding hcomp_def
	+ using assms apply simp
	+ using assms ide_char arr_char E.HcompNml_Trg_Nml
	+ by (metis (no_types, lifting) ideD(1))
	+ show "Map (trg f \<star> f) = Map f"
	+ proof -
	+ have "Map (trg f \<star> f) = B.can (Cod (trg f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (Cod (trg f) \<^bold>\<star> Cod f) \<cdot>\<^sub>B
	+ (Map (trg f) \<star>\<^sub>B Map f) \<cdot>\<^sub>B
	+ B.can (Dom (trg f) \<^bold>\<star> Dom f) (Dom (trg f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f)"
	+ unfolding hcomp_def
	+ using assms by simp
	+ also have "... = B.can (Dom f) (E.Trg (Dom f) \<^bold>\<star> Dom f) \<cdot>\<^sub>B
	+ (\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace>) \<cdot>\<^sub>B
	+ B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (Dom f)"
	+ using assms arr_char E.HcompNml_Trg_Nml by fastforce
	+ also have "... = B.can (Dom f) (E.Trg (Dom f) \<^bold>\<star> Dom f) \<cdot>\<^sub>B
	+ B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (Dom f)"
	+ proof -
	+ have "\<guillemotleft>B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (Dom f) :
	+ \<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace>\<guillemotright>"
	+ using assms ide_char arr_char B.can_in_hom
	+ by (metis (no_types, lifting) B.canE_unitor(4) B.lunit'_in_vhom E.Nml_implies_Arr
	+ E.eval_simps'(3) ideE)
	+ thus ?thesis
	+ using B.comp_cod_arr by auto
	+ qed
	+ also have "... = \<lbrace>Dom f\<rbrace>"
	+ using assms 1 ide_char arr_char
	+ by (metis (no_types, lifting) H.ide_hcomp Map_ide(1) calculation ideD(1)
	+ src_trg trg.preserves_ide)
	+ also have "... = Map f"
	+ using assms by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ interpretation L: endofunctor vcomp H.L
	+ using H.endofunctor_L by auto
	+ interpretation R: endofunctor vcomp H.R
	+ using H.endofunctor_R by auto
	+
	+ interpretation L: full_functor vcomp vcomp H.L
	+ proof
	+ fix a a' g
	+ assume a: "ide a" and a': "ide a'"
	+ assume g: "in_hom g (H.L a') (H.L a)"
	+ have a_eq: "a = MkIde (Dom a)"
	+ using a dom_char [of a] by simp
	+ have a'_eq: "a' = MkIde (Dom a')"
	+ using a' dom_char [of a'] by simp
	+ have 1: "Cod g = Dom a"
	+ proof -
	+ have "Dom (H.L a) = Dom a"
	+ proof -
	+ have "Dom (H.L a) = E.Trg (Dom a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a"
	+ using a trg_def hcomp_def
	+ apply simp
	+ by (metis (no_types, lifting) ideE src_trg trg.preserves_reflects_arr)
	+ also have "... = Dom a"
	+ using a arr_char E.Trg_HcompNml
	+ by (metis (no_types, lifting) E.HcompNml_Trg_Nml ideD(1))
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using g cod_char [of g]
	+ by (metis (no_types, lifting) Dom_cod in_homE)
	+ qed
	+ have 2: "Dom g = Dom a'"
	+ proof -
	+ have "Dom (H.L a') = Dom a'"
	+ proof -
	+ have "Dom (H.L a') = E.Trg (Dom a') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a'"
	+ using a' trg_def hcomp_def
	+ apply simp
	+ by (metis (no_types, lifting) ideE src_trg trg.preserves_reflects_arr)
	+ also have "... = Dom a'"
	+ using a' arr_char E.Trg_HcompNml
	+ by (metis (no_types, lifting) E.HcompNml_Trg_Nml ideD(1))
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using g dom_char [of g]
	+ by (metis (no_types, lifting) Dom_dom in_homE)
	+ qed
	+ let ?f = "MkArr (Dom a') (Cod a) (Map g)"
	+ have f: "in_hom ?f a' a"
	+ proof (intro in_homI)
	+ show 3: "arr (MkArr (Dom a') (Cod a) (Map g))"
	+ proof (intro arr_MkArr [of "Dom a'" "Cod a" "Map g"])
	+ show "Dom a' \<in> IDE"
	+ using a' ide_char arr_char by blast
	+ show "Cod a \<in> IDE"
	+ using a ide_char arr_char by blast
	+ show "Map g \<in> HOM (Dom a') (Cod a)"
	+ proof
	+ show "E.Src (Dom a') = E.Src (Cod a) \<and> E.Trg (Dom a') = E.Trg (Cod a) \<and>
	+ \<guillemotleft>Map g : \<lbrace>Dom a'\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod a\<rbrace>\<guillemotright>"
	+ using a a' a_eq g 1 2 ide_char arr_char src_def trg_def trg_hcomp
	+ by (metis (no_types, lifting) Cod.simps(1) in_homE)
	+ qed
	+ qed
	+ show "dom (MkArr (Dom a') (Cod a) (Map g)) = a'"
	+ using a a' 3 dom_char by auto
	+ show "cod (MkArr (Dom a') (Cod a) (Map g)) = a"
	+ using a a' 3 cod_char by auto
	+ qed
	+ moreover have "H.L ?f = g"
	+ proof -
	+ have "H.L ?f =
	+ trg (MkArr (Dom a') (Cod a) (Map g)) \<star> MkArr (Dom a') (Cod a) (Map g)"
	+ using f by auto
	+ also have "... = MkIde (E.Trg (Cod a)) \<star> MkArr (Dom a') (Cod a) (Map g)"
	+ using a a' f trg_def [of a] vconn_implies_hpar by auto
	+ also have "... = MkArr (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a') (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a)
	+ (B.can (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) \<cdot>\<^sub>B
	+ (\<lbrace>E.Trg (Cod a)\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B
	+ B.can (E.Trg (Cod a) \<^bold>\<star> Dom a') (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a'))"
	+ using hcomp_def
	+ apply simp
	+ by (metis (no_types, lifting) Cod.simps(1) arrE f in_homE src_trg trg.preserves_arr
	+ trg_def)
	+ also have "... = MkArr (Dom a') (Cod a)
	+ (B.can (Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) \<cdot>\<^sub>B
	+ (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B
	+ B.can (E.Trg (Cod a) \<^bold>\<star> Dom a') (Dom a'))"
	+ proof -
	+ have "E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a' = Dom a'"
	+ using a a' arr_char E.HcompNml_Trg_Nml
	+ by (metis (no_types, lifting) f ideE trg_simps(1) vconn_implies_hpar(4))
	+ moreover have "E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a = Cod a"
	+ using a a' arr_char E.HcompNml_Trg_Nml by blast
	+ moreover have "\<lbrace>E.Trg (Cod a)\<rbrace> = trg\<^sub>B \<lbrace>Cod a\<rbrace>"
	+ using a a' arr_char E.eval_simps'(3) by fastforce
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = MkArr (Dom a') (Cod a)
	+ (B.lunit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom a'\<rbrace>)"
	+ proof -
	+ have "E.Trg (Cod a) = E.Trg (Dom a')"
	+ using a a' a_eq g ide_char arr_char src_def trg_def trg_hcomp
	+ \<open>Cod g = Dom a\<close> \<open>Dom g = Dom a'\<close>
	+ by (metis (no_types, lifting) Cod.simps(1) in_homE)
	+ moreover have "B.can (Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) = B.lunit \<lbrace>Cod a\<rbrace>"
	+ using a ide_char arr_char B.canE_unitor(2) by blast
	+ moreover have "B.can (E.Trg (Dom a') \<^bold>\<star> Dom a') (Dom a') = B.lunit' \<lbrace>Dom a'\<rbrace>"
	+ using a' ide_char arr_char B.canE_unitor(4) by blast
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = MkArr (Dom g) (Cod g) (Map g)"
	+ proof -
	+ have "src\<^sub>B \<lbrace>Cod a\<rbrace> = src\<^sub>B (Map g)"
	+ using a f g ide_char arr_char src_def B.comp_cod_arr
	+ by (metis (no_types, lifting) B.vconn_implies_hpar(1) B.vconn_implies_hpar(3)
	+ Cod.simps(1) Map.simps(1) in_homE)
	+ moreover have
	+ "B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B (Map g) \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom g\<rbrace> = Map g"
	+ proof -
	+ have "B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B (Map g) \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom g\<rbrace> =
	+ B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.lunit' \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
	+ using g ide_char arr_char B.lunit'_naturality
	+ by (metis (no_types, lifting) partial_magma_axioms B.in_homE partial_magma.arrI)
	+ also have "... = (B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.lunit' \<lbrace>Cod g\<rbrace>) \<cdot>\<^sub>B Map g"
	+ using B.comp_assoc by simp
	+ also have "... = Map g"
	+ using g arr_char E.ide_eval_Ide B.comp_arr_inv' B.comp_cod_arr by fastforce
	+ finally show ?thesis by simp
	+ qed
	+ ultimately have
	+ "B.lunit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom a'\<rbrace> = Map g"
	+ using a a' 1 2 f g hcomp_def dom_char cod_char
	+ by (metis (no_types, lifting) B.comp_null(2) B.ext B.lunit_simps(2) B.lunit_simps(3)
	+ B.src.preserves_reflects_arr B.trg_vcomp B.vseq_implies_hpar(1) ideE)
	+ thus ?thesis
	+ using a 1 2 by auto
	+ qed
	+ also have "... = g"
	+ using g MkArr_Map by blast
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show "\<exists>f. in_hom f a' a \<and> H.L f = g"
	+ by blast
	+ qed
	+
	+ interpretation R: full_functor vcomp vcomp H.R
	+ proof
	+ fix a a' g
	+ assume a: "ide a" and a': "ide a'"
	+ assume g: "in_hom g (H.R a') (H.R a)"
	+ have a_eq: "a = MkIde (Dom a)"
	+ using a dom_char [of a] by simp
	+ have a'_eq: "a' = MkIde (Dom a')"
	+ using a' dom_char [of a'] by simp
	+ have 1: "Cod g = Dom a"
	+ proof -
	+ have "Dom (H.R a) = Dom a"
	+ proof -
	+ have "Dom (H.R a) = Dom a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom a)"
	+ using a src_def hcomp_def
	+ apply simp
	+ by (metis (no_types, lifting) ideE trg_src src.preserves_reflects_arr)
	+ also have "... = Dom a"
	+ using a arr_char E.Src_HcompNml
	+ by (metis (no_types, lifting) E.HcompNml_Nml_Src ideD(1))
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using g cod_char [of g]
	+ by (metis (no_types, lifting) Dom_cod in_homE)
	+ qed
	+ have 2: "Dom g = Dom a'"
	+ proof -
	+ have "Dom (H.R a') = Dom a'"
	+ proof -
	+ have "Dom (H.R a') = Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom a')"
	+ using a' src_def hcomp_def
	+ apply simp
	+ by (metis (no_types, lifting) ideE trg_src src.preserves_reflects_arr)
	+ also have "... = Dom a'"
	+ using a' arr_char E.Src_HcompNml
	+ by (metis (no_types, lifting) E.HcompNml_Nml_Src ideD(1))
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using g dom_char [of g]
	+ by (metis (no_types, lifting) Dom_dom in_homE)
	+ qed
	+ let ?f = "MkArr (Dom a') (Cod a) (Map g)"
	+ have f: "in_hom ?f a' a"
	+ proof (intro in_homI)
	+ show 3: "arr (MkArr (Dom a') (Cod a) (Map g))"
	+ proof (intro arr_MkArr [of "Dom a'" "Cod a" "Map g"])
	+ show "Dom a' \<in> IDE"
	+ using a' ide_char arr_char by blast
	+ show "Cod a \<in> IDE"
	+ using a ide_char arr_char by blast
	+ show "Map g \<in> HOM (Dom a') (Cod a)"
	+ proof
	+ show "E.Src (Dom a') = E.Src (Cod a) \<and> E.Trg (Dom a') = E.Trg (Cod a) \<and>
	+ \<guillemotleft>Map g : \<lbrace>Dom a'\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod a\<rbrace>\<guillemotright>"
	+ using a a' a_eq g 1 2 ide_char arr_char src_def trg_def trg_hcomp
	+ by (metis (no_types, lifting) Cod.simps(1) in_homE)
	+ qed
	+ qed
	+ show "dom (MkArr (Dom a') (Cod a) (Map g)) = a'"
	+ using a a' 3 dom_char by auto
	+ show "cod (MkArr (Dom a') (Cod a) (Map g)) = a"
	+ using a a' 3 cod_char by auto
	+ qed
	+ moreover have "H.R ?f = g"
	+ proof -
	+ have "H.R ?f =
	+ MkArr (Dom a') (Cod a) (Map g) \<star> src (MkArr (Dom a') (Cod a) (Map g))"
	+ using f by auto
	+ also have "... = MkArr (Dom a') (Cod a) (Map g) \<star> MkIde (E.Src (Cod a))"
	+ using a a' f src_def [of a] vconn_implies_hpar by auto
	+ also have "... = MkArr (Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)) (Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a))
	+ (B.can (Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)) (Cod a \<^bold>\<star> E.Src (Cod a)) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B \<lbrace>E.Src (Cod a)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom a' \<^bold>\<star> E.Src (Cod a)) (Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)))"
	+ using hcomp_def
	+ apply simp
	+ by (metis (no_types, lifting) Cod_cod arrE f in_homE trg_src src.preserves_arr src_def)
	+ also have "... = MkArr (Dom a') (Cod a)
	+ (B.can (Cod a) (Cod a \<^bold>\<star> E.Src (Cod a)) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom a' \<^bold>\<star> E.Src (Cod a)) (Dom a'))"
	+ proof -
	+ have "Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a) = Dom a'"
	+ using a a' arr_char E.HcompNml_Nml_Src
	+ by (metis (no_types, lifting) f ideE src_simps(1) vconn_implies_hpar(3))
	+ moreover have "Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a) = Cod a"
	+ using a a' arr_char E.HcompNml_Nml_Src by blast
	+ moreover have "\<lbrace>E.Src (Cod a)\<rbrace> = src\<^sub>B \<lbrace>Cod a\<rbrace>"
	+ using a a' arr_char E.eval_simps'(2) by fastforce
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = MkArr (Dom a') (Cod a)
	+ (B.runit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B B.runit' \<lbrace>Dom a'\<rbrace>)"
	+ proof -
	+ have "E.Src (Cod a) = E.Src (Dom a')"
	+ using a a' g ide_char arr_char src_def trg_def src_hcomp
	+ by (metis (no_types, lifting) Cod_dom f ideE in_homE src_cod src_simps(1))
	+ moreover have "B.can (Cod a) (Cod a \<^bold>\<star> E.Src (Cod a)) = B.runit \<lbrace>Cod a\<rbrace>"
	+ using a ide_char arr_char B.canE_unitor(1) by blast
	+ moreover have "B.can (Dom a' \<^bold>\<star> E.Src (Dom a')) (Dom a') = B.runit' \<lbrace>Dom a'\<rbrace>"
	+ using a' ide_char arr_char B.canE_unitor(3) by blast
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = MkArr (Dom g) (Cod g) (Map g)"
	+ proof -
	+ have "src\<^sub>B \<lbrace>Cod a\<rbrace> = src\<^sub>B (Map g)"
	+ using a f g ide_char arr_char src_def B.comp_cod_arr
	+ by (metis (no_types, lifting) B.vconn_implies_hpar(1) B.vconn_implies_hpar(3)
	+ Cod.simps(1) Map.simps(1) in_homE)
	+ moreover have
	+ "B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B (Map g)) \<cdot>\<^sub>B B.runit' \<lbrace>Dom g\<rbrace> = Map g"
	+ proof -
	+ have "B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B (Map g)) \<cdot>\<^sub>B B.runit' \<lbrace>Dom g\<rbrace> =
	+ B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.runit'\<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
	+ using g ide_char arr_char B.runit'_naturality [of "Map g"]
	+ by (metis (no_types, lifting) partial_magma_axioms B.in_homE partial_magma.arrI)
	+ also have "... = (B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.runit' \<lbrace>Cod g\<rbrace>) \<cdot>\<^sub>B Map g"
	+ using B.comp_assoc by simp
	+ also have "... = Map g"
	+ using g arr_char E.ide_eval_Ide B.comp_arr_inv' B.comp_cod_arr by fastforce
	+ finally show ?thesis by simp
	+ qed
	+ ultimately have
	+ "B.runit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B B.runit' \<lbrace>Dom a'\<rbrace> = Map g"
	+ using a a' 1 2 f g hcomp_def dom_char cod_char
	+ by (metis (no_types, lifting) ideE)
	+ thus ?thesis
	+ using a 1 2 by auto
	+ qed
	+ also have "... = g"
	+ using g MkArr_Map by blast
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show "\<exists>f. in_hom f a' a \<and> H.R f = g"
	+ by blast
	+ qed
	+
	+ interpretation L: faithful_functor vcomp vcomp H.L
	+ proof
	+ fix f f'
	+ assume par: "par f f'" and eq: "H.L f = H.L f'"
	+ show "f = f'"
	+ proof (intro arr_eqI)
	+ have 1: "Dom f = Dom f' \<and> Cod f = Cod f'"
	+ using par dom_char cod_char by auto
	+ show "arr f"
	+ using par by simp
	+ show "arr f'"
	+ using par by simp
	+ show 2: "Dom f = Dom f'" and 3: "Cod f = Cod f'"
	+ using 1 by auto
	+ show "Map f = Map f'"
	+ proof -
	+ have "B.L (Map f) = trg\<^sub>B (Map f) \<star>\<^sub>B Map f"
	+ using par by auto
	+ also have "... = trg\<^sub>B (Map f') \<star>\<^sub>B Map f'"
	+ proof -
	+ have "\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f = \<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f'"
	+ proof -
	+ have A: "\<guillemotleft>B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) :
	+ \<lbrace>E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace>\<guillemotright>"
	+ using par arr_char B.can_in_hom E.Ide_HcompNml
	+ E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
	+ src_def trg_def
	+ by (metis (no_types, lifting) E.eval_simps(3) E.ide_eval_Ide E.Ide_implies_Arr
	+ B.canE_unitor(4) B.lunit'_in_vhom)
	+ have B: "\<guillemotleft>B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) :
	+ \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f\<rbrace>\<guillemotright>"
	+ using par arr_char B.can_in_hom E.Ide_HcompNml
	+ E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
	+ src_def trg_def
	+ by (metis (no_types, lifting) E.Nmlize.simps(3) E.eval.simps(3) E.Ide.simps(3)
	+ E.Ide_implies_Arr E.Src_Trg trg.preserves_arr trg_simps(2))
	+ have C: "\<guillemotleft>\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f :
	+ \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod f\<rbrace>\<guillemotright>"
	+ using par arr_char
	+ by (metis (no_types, lifting) E.eval_simps'(1) E.eval_simps(3) E.ide_eval_Ide
	+ E.Ide_implies_Arr E.Obj_Trg E.Obj_implies_Ide B.hcomp_in_vhom
	+ B.ide_in_hom(2) B.src_trg)
	+ have 3: "(\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
	+ B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) =
	+ (\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
	+ B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f')"
	+ proof -
	+ have 2: "B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) \<cdot>\<^sub>B
	+ (\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
	+ B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) =
	+ B.can (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f') (E.Trg (Dom f') \<^bold>\<star> Cod f') \<cdot>\<^sub>B
	+ (\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
	+ B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f')"
	+ using par eq hcomp_def trg_def src_trg trg.preserves_arr Map_hcomp
	+ trg_simps(1) trg_simps(2) trg_simps(3)
	+ by auto
	+ have "B.mono (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))"
	+ using par arr_char B.inverse_arrows_can B.iso_is_section B.section_is_mono
	+ src_def trg_def E.Nmlize_Nml E.HcompNml_Trg_Nml E.Ide_implies_Arr
	+ trg.preserves_arr trg_simps(1)
	+ by auto
	+ moreover have
	+ "B.seq (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))
	+ ((\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
	+ B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
	+ using A B C by auto
	+ moreover have
	+ "B.seq (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))
	+ ((\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
	+ B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f'))"
	+ using par 1 2 arr_char calculation(2) by auto
	+ moreover have "B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) =
	+ B.can (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f') (E.Trg (Dom f') \<^bold>\<star> Cod f')"
	+ using par 1 arr_char by simp
	+ ultimately show ?thesis
	+ using 2 B.monoE cod_char by auto
	+ qed
	+ show ?thesis
	+ proof -
	+ have "B.epi (B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
	+ using par arr_char B.inverse_arrows_can B.iso_is_retraction
	+ B.retraction_is_epi E.Nmlize_Nml E.HcompNml_Trg_Nml src_def trg_def
	+ E.Ide_implies_Arr
	+ by (metis (no_types, lifting) E.Nmlize.simps(3) E.Ide.simps(3) E.Src_Trg
	+ trg.preserves_arr trg_simps(1))
	+ moreover have "B.seq (\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f)
	+ (B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
	+ using A C by auto
	+ moreover have "B.seq (\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f')
	+ (B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
	+ using 1 3 calculation(2) by auto
	+ ultimately show ?thesis
	+ using par 1 3 arr_char B.epiE by simp
	+ qed
	+ qed
	+ moreover have "trg\<^sub>B (Map f) = \<lbrace>E.Trg (Dom f)\<rbrace> \<and>
	+ trg\<^sub>B (Map f') = \<lbrace>E.Trg (Dom f')\<rbrace>"
	+ using par arr_char trg_def E.Ide_implies_Arr B.comp_arr_dom
	+ B.vseq_implies_hpar(2) E.eval_simps(3)
	+ by (metis (no_types, lifting) B.vconn_implies_hpar(2))
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = B.L (Map f')"
	+ using par B.hseqE B.hseq_char' by auto
	+ finally have "B.L (Map f) = B.L (Map f')"
	+ by simp
	+ thus ?thesis
	+ using 2 3 par arr_char B.L.is_faithful
	+ by (metis (no_types, lifting) B.in_homE)
	+ qed
	+ qed
	+ qed
	+
	+ interpretation R: faithful_functor vcomp vcomp H.R
	+ proof
	+ fix f f'
	+ assume par: "par f f'" and eq: "H.R f = H.R f'"
	+ show "f = f'"
	+ proof (intro arr_eqI)
	+ have 1: "Dom f = Dom f' \<and> Cod f = Cod f'"
	+ using par dom_char cod_char by auto
	+ show "arr f"
	+ using par by simp
	+ show "arr f'"
	+ using par by simp
	+ show 2: "Dom f = Dom f'" and 3: "Cod f = Cod f'"
	+ using 1 by auto
	+ show "Map f = Map f'"
	+ proof -
	+ have "B.R (Map f) = Map f \<star>\<^sub>B src\<^sub>B (Map f)"
	+ using par apply simp by (metis B.hseqE B.hseq_char')
	+ also have "... = Map f' \<star>\<^sub>B src\<^sub>B (Map f')"
	+ proof -
	+ have "Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> = Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>"
	+ proof -
	+ have 2: "E.Ide (Cod f \<^bold>\<star> E.Src (Dom f))"
	+ using par arr_char src.preserves_arr by auto
	+ hence 3: "E.Ide (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f))"
	+ using par arr_char E.Nml_Src E.Ide_HcompNml calculation by auto
	+ have 4: "\<^bold>\<lfloor>Cod f \<^bold>\<star> E.Src (Dom f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<^bold>\<rfloor>"
	+ using par arr_char by (simp add: E.Nml_HcompNml(1))
	+ have A: "\<guillemotleft>B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) :
	+ \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>\<guillemotright>"
	+ using par arr_char B.can_in_hom E.Ide_HcompNml
	+ E.Ide_Nmlize_Ide E.Nml_Src E.Nmlize_Nml E.HcompNml_Nml_Src
	+ src_def trg_def
	+ by (metis (no_types, lifting) E.eval_simps(2) E.ide_eval_Ide E.Ide_implies_Arr
	+ B.canE_unitor(3) B.runit'_in_vhom)
	+ have B: "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) :
	+ \<lbrace>Cod f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<rbrace>\<guillemotright>"
	+ using 2 3 4 B.can_in_hom [of "Cod f \<^bold>\<star> E.Src (Dom f)" "Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)"]
	+ by simp
	+ have C: "\<guillemotleft>Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> :
	+ \<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>\<guillemotright>"
	+ using par arr_char E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
	+ src_def trg_def E.ide_eval_Ide E.Ide_implies_Arr E.Obj_implies_Ide
	+ apply (intro B.hcomp_in_vhom)
	+ apply (simp add: B.ide_in_hom(2))
	+ apply simp
	+ by (metis (no_types, lifting) A B.ideD(1) B.not_arr_null B.seq_if_composable
	+ B.src.preserves_reflects_arr B.vconn_implies_hpar(3) E.HcompNml_Nml_Src)
	+ have 5: "(Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) =
	+ (Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f'))"
	+ proof -
	+ have 6: "B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) \<cdot>\<^sub>B
	+ (Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) =
	+ B.can (Cod f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')) (Cod f' \<^bold>\<star> E.Src (Dom f')) \<cdot>\<^sub>B
	+ (Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f'))"
	+ using par eq hcomp_def src_def trg_src src.preserves_arr Map_hcomp
	+ src_simps(1) src_simps(2) src_simps(3)
	+ by auto
	+ have "B.mono (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))"
	+ using 2 3 4 B.inverse_arrows_can(1) B.iso_is_section B.section_is_mono
	+ by simp
	+ moreover have
	+ "B.seq (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))
	+ ((Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
	+ using A B C by auto
	+ moreover have
	+ "B.seq (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))
	+ ((Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')))"
	+ using par 1 6 arr_char calculation(2) by auto
	+ moreover have "B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) =
	+ B.can (Cod f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')) (Cod f' \<^bold>\<star> E.Src (Dom f'))"
	+ using par 1 arr_char by simp
	+ ultimately show ?thesis
	+ using 6 B.monoE cod_char by auto
	+ qed
	+ show ?thesis
	+ proof -
	+ have "B.epi (B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
	+ using 2 3 4 B.inverse_arrows_can(1) B.iso_is_retraction B.retraction_is_epi
	+ by (metis (no_types, lifting) E.Nml_Src E.Nmlize.simps(3) E.Nmlize_Nml
	+ E.HcompNml_Nml_Src E.Ide.simps(3) par arrE)
	+ moreover have "B.seq (Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>)
	+ (B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
	+ using A C by auto
	+ moreover have "B.seq (Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>)
	+ (B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
	+ using 1 5 calculation(2) by auto
	+ ultimately show ?thesis
	+ using par 1 5 arr_char B.epiE by simp
	+ qed
	+ qed
	+ moreover have "src\<^sub>B (Map f) = \<lbrace>E.Src (Dom f)\<rbrace> \<and>
	+ src\<^sub>B (Map f') = \<lbrace>E.Src (Dom f')\<rbrace>"
	+ using par arr_char src_def
	+ by (metis (no_types, lifting) B.vconn_implies_hpar(1) E.Nml_implies_Arr
	+ E.eval_simps(2))
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = B.R (Map f')"
	+ using par B.hseqE B.hseq_char' by auto
	+ finally have "B.R (Map f) = B.R (Map f')"
	+ by simp
	+ thus ?thesis
	+ using 2 3 par arr_char B.R.is_faithful
	+ by (metis (no_types, lifting) B.in_homE)
	+ qed
	+ qed
	+ qed
	+
	+ interpretation VxVxV: product_category vcomp VxV.comp ..
	+ interpretation VVV: subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and> src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using subcategory_VVV by auto
	+
	+ interpretation HoHV: "functor" VVV.comp vcomp H.HoHV
	+ using H.functor_HoHV by auto
	+ interpretation HoVH: "functor" VVV.comp vcomp H.HoVH
	+ using H.functor_HoVH by auto
	+
	+ definition \<a>
	+ where "\<a> \<tau> \<mu> \<nu> \<equiv> if VVV.arr (\<tau>, \<mu>, \<nu>) then hcomp \<tau> (hcomp \<mu> \<nu>) else null"
	+
	+ interpretation natural_isomorphism VVV.comp vcomp H.HoHV H.HoVH
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))\<close>
	+ proof
	+ show "\<And>\<tau>\<mu>\<nu>. \<not> VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow> \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>)) = null"
	+ using \<a>_def by simp
	+ show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
	+ dom (\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))) = H.HoHV (VVV.dom \<tau>\<mu>\<nu>)"
	+ using VVV.arr_char VV.arr_char \<a>_def H.hseqI' hcomp_assoc H.HoHV_def by force
	+ show 1: "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
	+ cod (\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))) = H.HoVH (VVV.cod \<tau>\<mu>\<nu>)"
	+ using VVV.arr_char VV.arr_char \<a>_def H.hseqI' H.HoVH_def by force
	+ show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
	+ H.HoVH \<tau>\<mu>\<nu> \<cdot>
	+ \<a> (fst (VVV.dom \<tau>\<mu>\<nu>)) (fst (snd (VVV.dom \<tau>\<mu>\<nu>)))
	+ (snd (snd (VVV.dom \<tau>\<mu>\<nu>))) =
	+ \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
	+ using \<a>_def HoVH.is_natural_1 H.HoVH_def by auto
	+ show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
	+ \<a> (fst (VVV.cod \<tau>\<mu>\<nu>)) (fst (snd (VVV.cod \<tau>\<mu>\<nu>)))
	+ (snd (snd (VVV.cod \<tau>\<mu>\<nu>))) \<cdot> H.HoHV \<tau>\<mu>\<nu> =
	+ \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
	+ proof -
	+ fix \<tau>\<mu>\<nu>
	+ assume \<tau>\<mu>\<nu>: "VVV.arr \<tau>\<mu>\<nu>"
	+ have "H.HoHV \<tau>\<mu>\<nu> = \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
	+ unfolding \<a>_def H.HoHV_def
	+ using \<tau>\<mu>\<nu> HoHV.preserves_cod hcomp_assoc VVV.arr_char VV.arr_char
	+ by simp
	+ thus "\<a> (fst (VVV.cod \<tau>\<mu>\<nu>)) (fst (snd (VVV.cod \<tau>\<mu>\<nu>))) (snd (snd (VVV.cod \<tau>\<mu>\<nu>))) \<cdot>
	+ H.HoHV \<tau>\<mu>\<nu> =
	+ \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
	+ using 1 \<tau>\<mu>\<nu> comp_cod_arr \<a>_def
	+ by (metis (no_types, lifting) H.HoVH_def HoHV.preserves_arr prod.collapse)
	+ qed
	+ show "\<And>fgh. VVV.ide fgh \<Longrightarrow> iso (\<a> (fst fgh) (fst (snd fgh)) (snd (snd fgh)))"
	+ using \<a>_def HoVH.preserves_ide H.HoVH_def by auto
	+ qed
	+
	+ definition \<i>
	+ where "\<i> \<equiv> \<lambda>a. a"
	+
	+ sublocale bicategory comp hcomp \<a> \<i> src trg
	+ using hcomp_obj_self \<a>_def hcomp_assoc VVV.arr_char VV.arr_char
	+ apply unfold_locales
	+ by (auto simp add: \<i>_def ide_in_hom(2))
	+
	+ lemma is_bicategory:
	+ shows "bicategory comp hcomp \<a> \<i> src trg"
	+ ..
	+
	+ sublocale strict_bicategory vcomp hcomp \<a> \<i> src trg
	+ proof
	+ show "\<And>fgh. ide fgh \<Longrightarrow> lunit fgh = fgh"
	+ proof -
	+ fix fgh
	+ assume fgh: "ide fgh"
	+ have "fgh = lunit fgh"
	+ proof (intro lunit_eqI)
	+ show "ide fgh" using fgh by simp
	+ show "\<guillemotleft>fgh : trg fgh \<star> fgh \<Rightarrow> fgh\<guillemotright>"
	+ using fgh hcomp_def hcomp_trg_ide by auto
	+ show "trg fgh \<star> fgh = (\<i> (trg fgh) \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh"
	+ proof -
	+ have "(\<i> (trg fgh) \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh =
	+ (trg fgh \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh"
	+ using fgh \<i>_def by metis
	+ also have "... = (trg fgh \<star> fgh) \<cdot> (trg fgh \<star> trg fgh \<star> fgh)"
	+ using fgh \<a>_def by fastforce
	+ also have "... = trg fgh \<star> fgh"
	+ using fgh hcomp_obj_self hcomp_assoc
	+ by (simp add: hcomp_trg_ide)
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ thus "lunit fgh = fgh" by simp
	+ qed
	+ show "\<And>fgh. ide fgh \<Longrightarrow> runit fgh = fgh"
	+ proof -
	+ fix fgh
	+ assume fgh: "ide fgh"
	+ have "fgh = runit fgh"
	+ proof (intro runit_eqI)
	+ show "ide fgh" using fgh by simp
	+ show "\<guillemotleft>fgh : fgh \<star> src fgh \<Rightarrow> fgh\<guillemotright>"
	+ using fgh hcomp_def hcomp_ide_src by auto
	+ show "fgh \<star> src fgh = (fgh \<star> \<i> (src fgh)) \<cdot> \<a> fgh (src fgh) (src fgh)"
	+ proof -
	+ have "(fgh \<star> \<i> (src fgh)) \<cdot> \<a> fgh (src fgh) (src fgh) =
	+ (fgh \<star> src fgh) \<cdot> \<a> fgh (src fgh) (src fgh)"
	+ using fgh \<i>_def by metis
	+ also have "... = (fgh \<star> src fgh) \<cdot> (fgh \<star> src fgh \<star> src fgh)"
	+ using fgh \<a>_def by fastforce
	+ also have "... = fgh \<star> src fgh"
	+ using fgh comp_arr_dom hcomp_obj_self by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ thus "runit fgh = fgh" by simp
	+ qed
	+ show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow> ide (\<a> f g h)"
	+ using \<a>_def VV.arr_char VVV.arr_char by auto
	+ qed
	+
	+ theorem is_strict_bicategory:
	+ shows "strict_bicategory vcomp hcomp \<a> \<i> src trg"
	+ ..
	+
	+ subsection "The Strictness Theorem"
	+
	+ text \<open>
	+ The Strictness Theorem asserts: ``Every bicategory is biequivalent to a strict bicategory.''
	+ This amounts to an equivalent (and perhaps more desirable) formulation of the
	+ Coherence Theorem.
	+ In this section we prove the Strictness Theorem by constructing an equivalence pseudofunctor
	+ from a bicategory to its strictification.
	+ \<close>
	+
	+ lemma iso_char:
	+ shows "iso \<mu> \<longleftrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
	+ and "iso \<mu> \<Longrightarrow> inv \<mu> = MkArr (Cod \<mu>) (Dom \<mu>) (B.inv (Map \<mu>))"
	+ proof -
	+ have 1: "iso \<mu> \<Longrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
	+ proof -
	+ assume \<mu>: "iso \<mu>"
	+ obtain \<nu> where \<nu>: "inverse_arrows \<mu> \<nu>"
	+ using \<mu> by auto
	+ have "B.inverse_arrows (Map \<mu>) (Map \<nu>)"
	+ proof
	+ show "B.ide (Map \<mu> \<cdot>\<^sub>B Map \<nu>)"
	+ proof -
	+ have "Map \<mu> \<cdot>\<^sub>B Map \<nu> = Map (\<mu> \<cdot> \<nu>)"
	+ using \<mu> \<nu> inverse_arrows_def Map_comp arr_char seq_char
	+ by (metis (no_types, lifting) ide_compE)
	+ moreover have "B.ide ..."
	+ using \<nu> ide_char by blast
	+ ultimately show ?thesis by simp
	+ qed
	+ show "B.ide (Map \<nu> \<cdot>\<^sub>B Map \<mu>)"
	+ proof -
	+ have "Map \<nu> \<cdot>\<^sub>B Map \<mu> = Map (\<nu> \<cdot> \<mu>)"
	+ using \<mu> \<nu> inverse_arrows_def comp_char [of \<nu> \<mu>] by simp
	+ moreover have "B.ide ..."
	+ using \<nu> ide_char by blast
	+ ultimately show ?thesis by simp
	+ qed
	+ qed
	+ thus "arr \<mu> \<and> B.iso (Map \<mu>)"
	+ using \<mu> by auto
	+ qed
	+ let ?\<nu> = "MkArr (Cod \<mu>) (Dom \<mu>) (B.inv (Map \<mu>))"
	+ have 2: "arr \<mu> \<and> B.iso (Map \<mu>) \<Longrightarrow> iso \<mu> \<and> inv \<mu> = ?\<nu>"
	+ proof
	+ assume \<mu>: "arr \<mu> \<and> B.iso (Map \<mu>)"
	+ have \<nu>: "\<guillemotleft>?\<nu> : cod \<mu> \<Rightarrow> dom \<mu>\<guillemotright>"
	+ using \<mu> arr_char dom_char cod_char by auto
	+ have 4: "inverse_arrows \<mu> ?\<nu>"
	+ proof
	+ show "ide (?\<nu> \<cdot> \<mu>)"
	+ proof -
	+ have "?\<nu> \<cdot> \<mu> = dom \<mu>"
	+ using \<mu> \<nu> MkArr_Map comp_char seq_char B.comp_inv_arr' dom_char by auto
	+ thus ?thesis
	+ using \<mu> by simp
	+ qed
	+ show "ide (\<mu> \<cdot> ?\<nu>)"
	+ proof -
	+ have "\<mu> \<cdot> ?\<nu> = cod \<mu>"
	+ using \<mu> \<nu> MkArr_Map comp_char seq_char B.comp_arr_inv' cod_char by auto
	+ thus ?thesis
	+ using \<mu> by simp
	+ qed
	+ qed
	+ thus "iso \<mu>" by auto
	+ show "inv \<mu> = ?\<nu>"
	+ using 4 inverse_unique by simp
	+ qed
	+ have 3: "arr \<mu> \<and> B.iso (Map \<mu>) \<Longrightarrow> iso \<mu>"
	+ using 2 by simp
	+ show "iso \<mu> \<longleftrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
	+ using 1 3 by blast
	+ show "iso \<mu> \<Longrightarrow> inv \<mu> = ?\<nu>"
	+ using 1 2 by blast
	+ qed
	+
	+ text \<open>
	+ We next define a map \<open>UP\<close> from the given bicategory \<open>B\<close> to its strictification,
	+ and show that it is an equivalence pseudofunctor.
	+ The following auxiliary definition is not logically necessary, but it provides some
	+ terms that can be the targets of simplification rules and thereby enables some proofs
	+ to be done by simplification that otherwise could not be. Trying to eliminate it
	+ breaks some short proofs below, so I have kept it.
	+ \<close>
	+
	+ definition UP\<^sub>0
	+ where "UP\<^sub>0 a \<equiv> if B.obj a then MkIde \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 else null"
	+
	+ lemma obj_UP\<^sub>0 [simp]:
	+ assumes "B.obj a"
	+ shows "obj (UP\<^sub>0 a)"
	+ using assms UP\<^sub>0_def ide_MkIde [of "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"] src_def obj_def by simp
	+
	+ lemma UP\<^sub>0_in_hom [intro]:
	+ assumes "B.obj a"
	+ shows "\<guillemotleft>UP\<^sub>0 a : UP\<^sub>0 a \<rightarrow> UP\<^sub>0 a\<guillemotright>"
	+ and "\<guillemotleft>UP\<^sub>0 a : UP\<^sub>0 a \<Rightarrow> UP\<^sub>0 a\<guillemotright>"
	+ using assms obj_UP\<^sub>0 by blast+
	+
	+ lemma UP\<^sub>0_simps [simp]:
	+ assumes "B.obj a"
	+ shows "ide (UP\<^sub>0 a)" "arr (UP\<^sub>0 a)"
	+ and "src (UP\<^sub>0 a) = UP\<^sub>0 a" and "trg (UP\<^sub>0 a) = UP\<^sub>0 a"
	+ and "dom (UP\<^sub>0 a) = UP\<^sub>0 a" and "cod (UP\<^sub>0 a) = UP\<^sub>0 a"
	+ using assms obj_UP\<^sub>0
	+ apply blast
	+ using assms obj_UP\<^sub>0
	+ apply blast
	+ using assms obj_UP\<^sub>0
	+ apply simp_all
	+ using ideD(2) obj_UP\<^sub>0
	+ apply blast
	+ using ideD(3) obj_UP\<^sub>0
	+ by blast
	+
	+ definition UP
	+ where "UP \<mu> \<equiv> if B.arr \<mu> then MkArr \<^bold>\<langle>B.dom \<mu>\<^bold>\<rangle> \<^bold>\<langle>B.cod \<mu>\<^bold>\<rangle> \<mu> else null"
	+
	+ lemma Dom_UP [simp]:
	+ assumes "B.arr \<mu>"
	+ shows "Dom (UP \<mu>) = \<^bold>\<langle>B.dom \<mu>\<^bold>\<rangle>"
	+ using assms UP_def by fastforce
	+
	+ lemma Cod_UP [simp]:
	+ assumes "B.arr \<mu>"
	+ shows "Cod (UP \<mu>) = \<^bold>\<langle>B.cod \<mu>\<^bold>\<rangle>"
	+ using assms UP_def by fastforce
	+
	+ lemma Map_UP [simp]:
	+ assumes "B.arr \<mu>"
	+ shows "Map (UP \<mu>) = \<mu>"
	+ using assms UP_def by fastforce
	+
	+ lemma arr_UP:
	+ assumes "B.arr \<mu>"
	+ shows "arr (UP \<mu>)"
	+ using assms UP_def
	+ by (intro arrI, fastforce+)
	+
	+ lemma UP_in_hom [intro]:
	+ assumes "B.arr \<mu>"
	+ shows "\<guillemotleft>UP \<mu> : UP\<^sub>0 (src\<^sub>B \<mu>) \<rightarrow> UP\<^sub>0 (trg\<^sub>B \<mu>)\<guillemotright>"
	+ and "\<guillemotleft>UP \<mu> : UP (B.dom \<mu>) \<Rightarrow> UP (B.cod \<mu>)\<guillemotright>"
	+ using assms arr_UP UP_def UP\<^sub>0_def dom_char cod_char src_def trg_def by auto
	+
	+ lemma UP_simps [simp]:
	+ assumes "B.arr \<mu>"
	+ shows "arr (UP \<mu>)"
	+ and "src (UP \<mu>) = UP\<^sub>0 (src\<^sub>B \<mu>)" and "trg (UP \<mu>) = UP\<^sub>0 (trg\<^sub>B \<mu>)"
	+ and "dom (UP \<mu>) = UP (B.dom \<mu>)" and "cod (UP \<mu>) = UP (B.cod \<mu>)"
	+ using assms arr_UP UP_in_hom by auto
	+
	+ interpretation UP: "functor" V\<^sub>B vcomp UP
	+ using UP_def arr_UP UP_simps(4-5)
	+ apply unfold_locales
	+ apply auto[4]
	+ using arr_UP UP_def comp_char seq_char
	+ by auto
	+
	+ interpretation UP: weak_arrow_of_homs V\<^sub>B src\<^sub>B trg\<^sub>B vcomp src trg UP
	+ proof
	+ fix \<mu>
	+ assume \<mu>: "B.arr \<mu>"
	+ show "isomorphic (UP (src\<^sub>B \<mu>)) (src (UP \<mu>))"
	+ proof -
	+ let ?\<phi> = "MkArr \<^bold>\<langle>src\<^sub>B \<mu>\<^bold>\<rangle> \<^bold>\<langle>src\<^sub>B \<mu>\<^bold>\<rangle>\<^sub>0 (src\<^sub>B \<mu>)"
	+ have \<phi>: "\<guillemotleft>?\<phi> : UP (src\<^sub>B \<mu>) \<Rightarrow> src (UP \<mu>)\<guillemotright>"
	+ proof
	+ show 1: "arr ?\<phi>"
	+ using \<mu> by (intro arrI, auto)
	+ show "dom ?\<phi> = UP (src\<^sub>B \<mu>)"
	+ using \<mu> 1 dom_char UP_def by simp
	+ show "cod ?\<phi> = src (UP \<mu>)"
	+ using \<mu> 1 cod_char src_def by auto
	+ qed
	+ have "iso ?\<phi>"
	+ using \<mu> \<phi> iso_char src_def by auto
	+ thus ?thesis
	+ using \<phi> isomorphic_def by auto
	+ qed
	+ show "isomorphic (UP (trg\<^sub>B \<mu>)) (trg (UP \<mu>))"
	+ proof -
	+ let ?\<phi> = "MkArr \<^bold>\<langle>trg\<^sub>B \<mu>\<^bold>\<rangle> \<^bold>\<langle>trg\<^sub>B \<mu>\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B \<mu>)"
	+ have \<phi>: "\<guillemotleft>?\<phi> : UP (trg\<^sub>B \<mu>) \<Rightarrow> trg (UP \<mu>)\<guillemotright>"
	+ proof
	+ show 1: "arr ?\<phi>"
	+ using \<mu> by (intro arrI, auto)
	+ show "dom ?\<phi> = UP (trg\<^sub>B \<mu>)"
	+ using \<mu> 1 dom_char UP_def by simp
	+ show "cod ?\<phi> = trg (UP \<mu>)"
	+ using \<mu> 1 cod_char trg_def by auto
	+ qed
	+ have "iso ?\<phi>"
	+ using \<mu> \<phi> iso_char trg_def by auto
	+ thus ?thesis
	+ using \<phi> isomorphic_def by auto
	+ qed
	+ qed
	+
	+ interpretation "functor" B.VV.comp VV.comp UP.FF
	+ using UP.functor_FF by auto
	+ interpretation HoUP_UP: composite_functor B.VV.comp VV.comp vcomp
	+ UP.FF \<open>\<lambda>\<mu>\<nu>. hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> ..
	+ interpretation UPoH: composite_functor B.VV.comp V\<^sub>B vcomp
	+ \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>\<close> UP ..
	+
	+ abbreviation \<Phi>\<^sub>o
	+ where "\<Phi>\<^sub>o fg \<equiv> MkArr (\<^bold>\<langle>fst fg\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>snd fg\<^bold>\<rangle>) \<^bold>\<langle>fst fg \<star>\<^sub>B snd fg\<^bold>\<rangle> (fst fg \<star>\<^sub>B snd fg)"
	+
	+ interpretation \<Phi>: transformation_by_components
	+ B.VV.comp vcomp HoUP_UP.map UPoH.map \<Phi>\<^sub>o
	+ proof
	+ fix fg
	+ assume fg: "B.VV.ide fg"
	+ show "\<guillemotleft>\<Phi>\<^sub>o fg : HoUP_UP.map fg \<Rightarrow> UPoH.map fg\<guillemotright>"
	+ using fg arr_char dom_char cod_char B.VV.ide_char B.VV.arr_char
	+ UP.FF_def UP_def hcomp_def B.can_Ide_self src_def trg_def
	+ apply (intro in_homI) by auto
	+ next
	+ fix \<mu>\<nu>
	+ assume \<mu>\<nu>: "B.VV.arr \<mu>\<nu>"
	+ show "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> = UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>)"
	+ proof -
	+ have "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> =
	+ MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
	+ proof -
	+ have "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> =
	+ MkArr (\<^bold>\<langle>B.cod (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>) (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)) \<cdot>
	+ MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (\<^bold>\<langle>B.cod (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
	+ using \<mu>\<nu> B.VV.arr_char arr_char UP.FF_def hcomp_def UP_def
	+ src_def trg_def B.can_in_hom B.can_Ide_self B.comp_arr_dom B.comp_cod_arr
	+ by auto
	+ also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
	+ using \<mu>\<nu> B.VV.arr_char arr_char comp_def B.comp_cod_arr
	+ apply (intro arr_eqI) by auto
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>)"
	+ proof -
	+ have "UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>) =
	+ MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>) \<cdot>
	+ MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (\<^bold>\<langle>B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>))"
	+ using \<mu>\<nu> B.VV.arr_char arr_char UP.FF_def hcomp_def UP_def
	+ src_def trg_def B.can_in_hom B.can_Ide_self B.comp_arr_dom B.comp_cod_arr
	+ by auto
	+ also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
	+ (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
	+ using \<mu>\<nu> B.VV.arr_char arr_char comp_def B.comp_arr_dom
	+ by (intro arr_eqI, auto)
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ abbreviation \<Phi>
	+ where "\<Phi> \<equiv> \<Phi>.map"
	+
	+ lemma \<Phi>_in_hom [intro]:
	+ assumes "B.arr (fst \<mu>\<nu>)" and "B.arr (snd \<mu>\<nu>)" and "src\<^sub>B (fst \<mu>\<nu>) = trg\<^sub>B (snd \<mu>\<nu>)"
	+ shows "\<guillemotleft>\<Phi> \<mu>\<nu> : UP\<^sub>0 (src\<^sub>B (snd \<mu>\<nu>)) \<rightarrow> UP\<^sub>0 (trg\<^sub>B (fst \<mu>\<nu>))\<guillemotright>"
	+ and "\<guillemotleft>\<Phi> \<mu>\<nu> : UP (B.dom (fst \<mu>\<nu>)) \<star> UP (B.dom (snd \<mu>\<nu>))
	+ \<Rightarrow> UP (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))\<guillemotright>"
	+ proof -
	+ let ?\<mu> = "fst \<mu>\<nu>" and ?\<nu> = "snd \<mu>\<nu>"
	+ show 1: "\<guillemotleft>\<Phi> \<mu>\<nu> : UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>) \<Rightarrow> UP (B.cod ?\<mu> \<star>\<^sub>B B.cod ?\<nu>)\<guillemotright>"
	+ proof
	+ show "arr (\<Phi> \<mu>\<nu>)"
	+ using assms by auto
	+ show "dom (\<Phi> \<mu>\<nu>) = UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>)"
	+ proof -
	+ have "B.VV.in_hom (?\<mu>, ?\<nu>) (B.dom ?\<mu>, B.dom ?\<nu>) (B.cod ?\<mu>, B.cod ?\<nu>)"
	+ using assms B.VV.in_hom_char B.VV.arr_char by auto
	+ hence "dom (\<Phi> \<mu>\<nu>) = HoUP_UP.map (B.dom ?\<mu>, B.dom ?\<nu>)"
	+ by auto
	+ also have "... = UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>)"
	+ using assms UP.FF_def by auto
	+ finally show ?thesis by simp
	+ qed
	+ show "cod (\<Phi> \<mu>\<nu>) = UP (B.cod ?\<mu> \<star>\<^sub>B B.cod ?\<nu>)"
	+ using assms B.VV.in_hom_char B.VV.arr_char by auto
	+ qed
	+ show "\<guillemotleft>\<Phi> \<mu>\<nu> : UP\<^sub>0 (src\<^sub>B ?\<nu>) \<rightarrow> UP\<^sub>0 (trg\<^sub>B ?\<mu>)\<guillemotright>"
	+ using assms 1 src_dom [of "\<Phi> \<mu>\<nu>"] trg_dom [of "\<Phi> \<mu>\<nu>"] by auto
	+ qed
	+
	+ lemma \<Phi>_simps [simp]:
	+ assumes "B.arr (fst \<mu>\<nu>)" and "B.arr (snd \<mu>\<nu>)" and "src\<^sub>B (fst \<mu>\<nu>) = trg\<^sub>B (snd \<mu>\<nu>)"
	+ shows "arr (\<Phi> \<mu>\<nu>)"
	+ and "src (\<Phi> \<mu>\<nu>) = UP\<^sub>0 (src\<^sub>B (snd \<mu>\<nu>))" and "trg (\<Phi> \<mu>\<nu>) = UP\<^sub>0 (trg\<^sub>B (fst \<mu>\<nu>))"
	+ and "dom (\<Phi> \<mu>\<nu>) = UP (B.dom (fst \<mu>\<nu>)) \<star> UP (B.dom (snd \<mu>\<nu>))"
	+ and "cod (\<Phi> \<mu>\<nu>) = UP (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))"
	+ using assms \<Phi>_in_hom [of \<mu>\<nu>] by auto
	+
	+ lemma \<Phi>_ide_simps [simp]:
	+ assumes "B.ide (fst fg)" and "B.ide (snd fg)" and "src\<^sub>B (fst fg) = trg\<^sub>B (snd fg)"
	+ shows "Dom (\<Phi> fg) = \<^bold>\<langle>fst fg\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>snd fg\<^bold>\<rangle>"
	+ and "Cod (\<Phi> fg) = \<^bold>\<langle>fst fg \<star>\<^sub>B snd fg\<^bold>\<rangle>"
	+ and "Map (\<Phi> fg) = fst fg \<star>\<^sub>B snd fg"
	+ using assms B.VV.ide_char B.VV.arr_char by auto
	+
	+ interpretation \<Phi>: natural_isomorphism B.VV.comp vcomp HoUP_UP.map UPoH.map \<Phi>
	+ proof
	+ fix fg
	+ assume fg: "B.VV.ide fg"
	+ have "arr (\<Phi> fg)"
	+ using fg \<Phi>.preserves_reflects_arr [of fg] by simp
	+ thus "iso (\<Phi> fg)"
	+ using fg iso_char by simp
	+ qed
	+
	+ lemma \<Phi>_ide_simp:
	+ assumes "B.ide f" and "B.ide g" and "src\<^sub>B f = trg\<^sub>B g"
	+ shows "\<Phi> (f, g) = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
	+ using assms B.VV.ide_char B.VV.arr_char by simp
	+
	+ lemma \<Phi>'_ide_simp:
	+ assumes "B.ide f" and "B.ide g" and "src\<^sub>B f = trg\<^sub>B g"
	+ shows "inv (\<Phi> (f, g)) = MkArr \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
	+ using assms \<Phi>_ide_simp iso_char \<Phi>.components_are_iso [of "(f, g)"]
	+ B.VV.ide_char B.VV.arr_char
	+ by simp
	+
	+ interpretation UP: pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP \<Phi>
	+ proof
	+ fix f g h
	+ assume f: "B.ide f" and g: "B.ide g" and h: "B.ide h"
	+ and fg: "src\<^sub>B f = trg\<^sub>B g" and gh: "src\<^sub>B g = trg\<^sub>B h"
	+ show "UP \<a>\<^sub>B[f, g, h] \<cdot> \<Phi> (f \<star>\<^sub>B g, h) \<cdot> (\<Phi> (f, g) \<star> UP h) =
	+ \<Phi> (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> \<Phi> (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h)"
	+ proof -
	+ have "UP \<a>\<^sub>B[f, g, h] \<cdot> \<Phi> (f \<star>\<^sub>B g, h) \<cdot> (\<Phi> (f, g) \<star> UP h) =
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
	+ proof -
	+ have 1: "UP.hseq\<^sub>D (MkIde \<^bold>\<langle>f\<^bold>\<rangle>) (MkIde \<^bold>\<langle>g\<^bold>\<rangle>)"
	+ using f g fg hseq_char src_def trg_def arr_char by auto
	+ have 2: "UP.hseq\<^sub>D (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>))
	+ (MkIde \<^bold>\<langle>h\<^bold>\<rangle>)"
	+ proof -
	+ have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) =
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
	+ using f g fg comp_def by auto
	+ thus ?thesis
	+ using f g h fg gh arr_char src_def trg_def by auto
	+ qed
	+ have "UP \<a>\<^sub>B[f, g, h] = MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h]"
	+ using f g h fg gh UP_def B.HoHV_def B.HoVH_def B.VVV.arr_char B.VV.arr_char
	+ B.VVV.dom_char B.VVV.cod_char
	+ by simp
	+ moreover have
	+ "\<Phi> (f \<star>\<^sub>B g, h) = MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
	+ MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h)"
	+ using f g h fg gh \<Phi>.map_simp_ide \<Phi>.map_def UP.FF_def UP_def hcomp_def
	+ B.VV.arr_char B.can_Ide_self B.comp_arr_dom B.comp_cod_arr src_def trg_def
	+ apply simp
	+ by (metis (no_types, lifting) B.ide_hcomp B.ide_char arr_UP)
	+ moreover have "\<Phi> (f, g) \<star> UP h =
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])"
	+ proof -
	+ have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)
	+ (B.can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<cdot>\<^sub>B (f \<star>\<^sub>B g) \<cdot>\<^sub>B B.can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)) =
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
	+ using f g fg B.can_Ide_self B.comp_arr_dom B.comp_cod_arr by simp
	+ moreover have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot>
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g) =
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
	+ using f g fg comp_def by auto
	+ moreover have "B.can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) = B.inv \<a>\<^sub>B[f, g, h]"
	+ using f g h fg gh B.canI_associator_0 B.inverse_arrows_can by simp
	+ ultimately show ?thesis
	+ using 1 2 f g h fg gh \<Phi>.map_def UP_def hcomp_def UP.FF_def
	+ B.VV.arr_char trg_def B.can_Ide_self B.comp_cod_arr
	+ by (simp del: B.hcomp_in_vhom)
	+ qed
	+ ultimately have "UP \<a>\<^sub>B[f, g, h] \<cdot> \<Phi> (f \<star>\<^sub>B g, h) \<cdot> (\<Phi> (f, g) \<star> UP h) =
	+ MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h] \<cdot>
	+ MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
	+ MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])"
	+ using comp_assoc by simp
	+ also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle>
	+ (\<a>\<^sub>B[f, g, h] \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B
	+ B.inv \<a>\<^sub>B[f, g, h])"
	+ proof -
	+ have "Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])) \<and>
	+ Arr (MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h)) \<and>
	+ Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)
	+ (((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B B.inv \<a>\<^sub>B[f, g, h])) \<and>
	+ Arr (MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h)) \<and>
	+ Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle>
	+ (((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B B.inv \<a>\<^sub>B[f, g, h])) \<and>
	+ Arr (MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h])"
	+ using f g h fg gh B.\<alpha>.preserves_hom B.HoHV_def B.HoVH_def by auto
	+ thus ?thesis
	+ using f g h fg gh comp_def B.comp_arr_dom B.comp_cod_arr by simp
	+ qed
	+ also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
	+ using B.comp_cod_arr B.comp_arr_inv'
	+ by (auto simp add: f fg g gh h)
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = \<Phi> (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> \<Phi> (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h)"
	+ proof -
	+ have "\<Phi> (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> \<Phi> (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h) =
	+ \<Phi> (f, g \<star>\<^sub>B h) \<cdot> (MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> \<Phi> (g, h)) \<cdot> (MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>g\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>h\<^bold>\<rangle>)"
	+ using f g h fg gh VVV.arr_char VV.arr_char arr_char src_def trg_def UP_def \<a>_def
	+ by auto
	+ also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
	+ proof -
	+ have "\<Phi> (f, g \<star>\<^sub>B h) = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
	+ using f g h fg gh \<Phi>.map_simp_ide \<Phi>.map_def UP.FF_def UP_def hcomp_def
	+ B.VV.arr_char B.can_Ide_self B.comp_arr_dom B.comp_cod_arr src_def trg_def
	+ arr_char
	+ apply simp_all
	+ by blast
	+ moreover
	+ have "\<Phi> (g, h) = MkArr (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle> (g \<star>\<^sub>B h)"
	+ using f g h fg gh \<Phi>.map_def UP.FF_def UP_def hcomp_def B.VV.arr_char
	+ B.can_Ide_self src_def trg_def arr_char
	+ by auto
	+ moreover have "MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkArr (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle> (g \<star>\<^sub>B h) =
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
	+ using f g h fg gh hcomp_def arr_char src_def trg_def B.can_Ide_self
	+ B.comp_arr_dom B.comp_cod_arr
	+ by auto
	+ moreover
	+ have "MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>g\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>h\<^bold>\<rangle> =
	+ MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
	+ proof -
	+ have "\<guillemotleft>f : f \<Rightarrow>\<^sub>B f\<guillemotright> \<and> \<guillemotleft>g : g \<Rightarrow>\<^sub>B g\<guillemotright> \<and> \<guillemotleft>h : h \<Rightarrow>\<^sub>B h\<guillemotright>"
	+ using f g h by auto
	+ thus ?thesis
	+ using f g h fg gh hcomp_def arr_char src_def trg_def B.can_Ide_self
	+ B.comp_arr_dom B.comp_cod_arr
	+ by simp
	+ qed
	+ ultimately show ?thesis
	+ using comp_assoc by auto
	+ qed
	+ also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
	+ proof -
	+ have "Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
	+ Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
	+ Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
	+ Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h))"
	+ using f g h fg gh by auto
	+ thus ?thesis
	+ using f g h fg gh comp_def by auto
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+
	+ lemma UP_is_pseudofunctor:
	+ shows "pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP \<Phi>" ..
	+
	+ lemma UP_map\<^sub>0_obj [simp]:
	+ assumes "B.obj a"
	+ shows "UP.map\<^sub>0 a = UP\<^sub>0 a"
	+ using assms UP.map\<^sub>0_def by auto
	+
	+ interpretation UP: full_functor V\<^sub>B vcomp UP
	+ proof
	+ fix \<mu> f g
	+ assume f: "B.ide f" and g: "B.ide g"
	+ assume \<mu>: "\<guillemotleft>\<mu> : UP f \<Rightarrow> UP g\<guillemotright>"
	+ show "\<exists>\<nu>. \<guillemotleft>\<nu> : f \<Rightarrow>\<^sub>B g\<guillemotright> \<and> UP \<nu> = \<mu>"
	+ proof -
	+ have 1: "\<guillemotleft>Map \<mu> : f \<Rightarrow>\<^sub>B g\<guillemotright>"
	+ using f g \<mu> UP_def arr_char in_hom_char by auto
	+ moreover have "UP (Map \<mu>) = \<mu>"
	+ proof -
	+ have "\<mu> = MkArr (Dom \<mu>) (Cod \<mu>) (Map \<mu>)"
	+ using \<mu> MkArr_Map by auto
	+ also have "... = UP (Map \<mu>)"
	+ using f g \<mu> 1 UP_def arr_char dom_char cod_char
	+ apply simp
	+ by (metis (no_types, lifting) B.in_homE Dom.simps(1) in_homE)
	+ finally show ?thesis by auto
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+
	+ interpretation UP: faithful_functor V\<^sub>B vcomp UP
	+ using arr_char UP_def
	+ by (unfold_locales, simp_all)
	+
	+ interpretation UP: fully_faithful_functor V\<^sub>B vcomp UP ..
	+
	+ lemma UP_is_fully_faithful_functor:
	+ shows "fully_faithful_functor V\<^sub>B vcomp UP"
	+ ..
	+
	+ no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>") (* Inherited from functor, I think. *)
	+
	+ lemma Map_reflects_hhom:
	+ assumes "B.obj a" and "B.obj b" and "ide g"
	+ and "\<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>"
	+ shows "\<guillemotleft>Map g : a \<rightarrow>\<^sub>B b\<guillemotright>"
	+ proof
	+ have 1: "B.ide (Map g)"
	+ using assms ide_char by blast
	+ show "B.arr (Map g)"
	+ using 1 by simp
	+ show "src\<^sub>B (Map g) = a"
	+ proof -
	+ have "src\<^sub>B (Map g) = Map (src g)"
	+ using assms src_def apply simp
	+ by (metis (no_types, lifting) E.eval_simps(2) E.Ide_implies_Arr arr_char ideE)
	+ also have "... = Map (UP.map\<^sub>0 a)"
	+ using assms by (metis (no_types, lifting) in_hhomE)
	+ also have "... = a"
	+ using assms UP.map\<^sub>0_def UP_def [of a] src_def by auto
	+ finally show ?thesis by simp
	+ qed
	+ show "trg\<^sub>B (Map g) = b"
	+ proof -
	+ have "trg\<^sub>B (Map g) = Map (trg g)"
	+ using assms trg_def apply simp
	+ by (metis (no_types, lifting) E.eval_simps(3) E.Ide_implies_Arr arr_char ideE)
	+ also have "... = Map (UP.map\<^sub>0 b)"
	+ using assms by (metis (no_types, lifting) in_hhomE)
	+ also have "... = b"
	+ using assms UP.map\<^sub>0_def UP_def [of b] src_def by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma eval_Dom_ide [simp]:
	+ assumes "ide g"
	+ shows "\<lbrace>Dom g\<rbrace> = Map g"
	+ using assms dom_char ideD by auto
	+
	+ lemma Cod_ide:
	+ assumes "ide f"
	+ shows "Cod f = Dom f"
	+ using assms dom_char by auto
	+
	+ lemma Map_preserves_objects:
	+ assumes "obj a"
	+ shows "B.obj (Map a)"
	+ proof -
	+ have "src\<^sub>B (Map a) = Map (src a)"
	+ using assms src_def apply simp
	+ using E.eval_simps(2) E.Ide_implies_Arr arr_char ideE
	+ by (metis (no_types, lifting) objE)
	+ also have 1: "... = \<lbrace>E.Src (Dom a)\<rbrace>"
	+ using assms src_def by auto
	+ also have "... = \<lbrace>\<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0\<rbrace>"
	+ using assms B.src.is_extensional 1 by force
	+ also have "... = Map a"
	+ using assms by auto
	+ finally have "src\<^sub>B (Map a) = Map a" by simp
	+ moreover have "B.arr (Map a)"
	+ using assms B.ideD arr_char by auto
	+ ultimately show ?thesis
	+ using B.obj_def by simp
	+ qed
	+
	+ interpretation UP: equivalence_pseudofunctor
	+ V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP \<Phi>
	+ proof
	+ (* UP is full, hence locally full. *)
	+ show "\<And>f f' \<nu>. \<lbrakk> B.ide f; B.ide f'; src\<^sub>B f = src\<^sub>B f'; trg\<^sub>B f = trg\<^sub>B f';
	+ \<guillemotleft>\<nu> : UP f \<Rightarrow> UP f'\<guillemotright> \<rbrakk> \<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright> \<and> UP \<mu> = \<nu>"
	+ using UP.is_full by simp
	+ (* UP is essentially surjective up to equivalence on objects. *)
	+ show "\<And>b. obj b \<Longrightarrow> \<exists>a. B.obj a \<and> equivalent_objects (UP.map\<^sub>0 a) b"
	+ proof -
	+ fix b
	+ assume b: "obj b"
	+ have 1: "B.obj (Map b)"
	+ using b Map_preserves_objects by simp
	+ have 3: "UP.map\<^sub>0 (Map b) = MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Map b)"
	+ using b 1 UP.map\<^sub>0_def [of "Map b"] UP_def src_def arr_char by auto
	+ have 4: "b = MkArr (Dom b) (Dom b) (Map b)"
	+ using b objE eval_Dom_ide
	+ by (metis (no_types, lifting) dom_char ideD(2) obj_def)
	+ let ?\<phi> = "MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Dom b) (Map b)"
	+ have \<phi>: "arr ?\<phi>"
	+ proof -
	+ have 2: "E.Obj (Dom b)"
	+ proof -
	+ have "Dom b = Dom (src b)"
	+ using b obj_def by simp
	+ moreover have "Dom (src b) = E.Src (Dom b)"
	+ using b obj_def src_def arr_char by simp
	+ moreover have "E.Obj (E.Src (Dom b))"
	+ using b obj_def src_def arr_char arr_def E.Obj_Src by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ have "E.Nml \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<and> E.Ide \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0"
	+ using 1 by auto
	+ moreover have "E.Nml (Dom b) \<and> E.Ide (Dom b)"
	+ using b arr_char [of b] by auto
	+ moreover have "E.Src \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 = E.Src (Dom b)"
	+ using b 1 2 B.obj_def obj_char
	+ by (cases "Dom b", simp_all)
	+ moreover have "E.Trg \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 = E.Trg (Dom b)"
	+ using b 1 2 B.obj_def obj_char
	+ by (cases "Dom b", simp_all)
	+ moreover have "\<guillemotleft>Map b : \<lbrace>\<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom b\<rbrace>\<guillemotright>"
	+ using b 1 by (elim objE, auto)
	+ ultimately show ?thesis
	+ using arr_char \<open>E.Nml \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<and> E.Ide \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0\<close> by auto
	+ qed
	+ hence "iso ?\<phi>"
	+ using 1 iso_char by auto
	+ moreover have "dom ?\<phi> = UP.map\<^sub>0 (Map b)"
	+ using \<phi> dom_char b 1 3 B.objE UP.map\<^sub>0_def UP_def src_def by auto
	+ moreover have "cod ?\<phi> = b"
	+ using \<phi> cod_char b 4 1 by auto
	+ ultimately have "isomorphic (UP.map\<^sub>0 (Map b)) b"
	+ using \<phi> 3 4 isomorphic_def by blast
	+ moreover have 5: "obj (UP.map\<^sub>0 (Map b))"
	+ using 1 UP.map\<^sub>0_simps(2) by simp
	+ ultimately have 6: "UP.map\<^sub>0 (Map b) = b"
	+ using b isomorphic_objects_are_equal by simp
	+ have "equivalent_objects (UP.map\<^sub>0 (Map b)) b"
	+ using b 6 equivalent_objects_reflexive [of b] by simp
	+ thus "\<exists>a. B.obj a \<and> equivalent_objects (UP.map\<^sub>0 a) b"
	+ using 1 6 by auto
	+ qed
	+ (* UP is locally essentially surjective. *)
	+ show "\<And>a b g. \<lbrakk> B.obj a; B.obj b; \<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>; ide g \<rbrakk> \<Longrightarrow>
	+ \<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f \<and> isomorphic (UP f) g"
	+ proof -
	+ fix a b g
	+ assume a: "B.obj a" and b: "B.obj b"
	+ assume g_in_hhom: "\<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>"
	+ assume ide_g: "ide g"
	+ have 1: "B.ide (Map g)"
	+ using ide_g ide_char by blast
	+ have "arr (UP a)"
	+ using a by auto
	+ have "arr (UP b)"
	+ using b by auto
	+ have Map_g_eq: "Map g = \<lbrace>Dom g\<rbrace>"
	+ using ide_g by simp
	+ have Map_g_in_hhom: "\<guillemotleft>Map g : a \<rightarrow>\<^sub>B b\<guillemotright>"
	+ using a b ide_g g_in_hhom Map_reflects_hhom by simp
	+
	+ let ?\<phi> = "MkArr \<^bold>\<langle>Map g\<^bold>\<rangle> (Dom g) (Map g)"
	+ have \<phi>: "arr ?\<phi>"
	+ proof -
	+ have "\<guillemotleft>Map ?\<phi> : \<lbrace>Dom ?\<phi>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod ?\<phi>\<rbrace>\<guillemotright>"
	+ using 1 Map_g_eq by auto
	+ moreover have "E.Ide \<^bold>\<langle>Map g\<^bold>\<rangle> \<and> E.Nml \<^bold>\<langle>Map g\<^bold>\<rangle>"
	+ using 1 by simp
	+ moreover have "E.Ide (Dom g) \<and> E.Nml (Dom g)"
	+ using ide_g arr_char ide_char by blast
	+ moreover have "E.Src \<^bold>\<langle>Map g\<^bold>\<rangle> = E.Src (Dom g)"
	+ using ide_g g_in_hhom src_def Map_g_in_hhom
	+ by (metis (no_types, lifting) B.ideD(2) B.in_hhom_def B.objE B.obj_def'
	+ Dom.simps(1) E.Src.simps(2) UP.map\<^sub>0_def \<open>arr (UP a)\<close> a in_hhomE UP_def)
	+ moreover have "E.Trg \<^bold>\<langle>Map g\<^bold>\<rangle> = E.Trg (Dom g)"
	+ proof -
	+ have "E.Trg \<^bold>\<langle>Map g\<^bold>\<rangle> = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
	+ using Map_g_in_hhom by auto
	+ also have "... = E.Trg (Dom g)"
	+ proof -
	+ have "E.Trg (Dom g) = Dom (trg g)"
	+ using ide_g trg_def by simp
	+ also have "... = Dom (UP.map\<^sub>0 b)"
	+ using g_in_hhom by auto
	+ also have "... = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
	+ using b \<open>arr (UP b)\<close> UP.map\<^sub>0_def src_def UP_def B.objE by auto
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using arr_char by simp
	+ qed
	+ have "\<guillemotleft>?\<phi> : UP (Map g) \<Rightarrow> g\<guillemotright>"
	+ proof
	+ show "arr ?\<phi>"
	+ using \<phi> by simp
	+ show "dom ?\<phi> = UP (Map g)"
	+ using \<phi> 1 dom_char UP_def by simp
	+ show "cod ?\<phi> = g"
	+ proof -
	+ have "cod ?\<phi> = MkArr (Dom g) (Dom g) (Map g)"
	+ using ide_g cod_char Map_g_eq \<phi> by auto
	+ moreover have "Dom g = Cod g"
	+ using ide_g Cod_ide by simp
	+ ultimately have "cod ?\<phi> = MkArr (Dom g) (Cod g) (Map g)"
	+ by simp
	+ thus ?thesis
	+ by (metis (no_types, lifting) "1" B.comp_ide_self
	+ \<open>Dom g = Cod g\<close> comp_cod_arr ideD(1) ideD(3) ide_g comp_char)
	+ qed
	+ qed
	+ moreover have "iso ?\<phi>"
	+ using \<phi> 1 iso_char by simp
	+ ultimately have "isomorphic (UP (Map g)) g"
	+ using isomorphic_def by auto
	+ thus "\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f \<and> isomorphic (UP f) g"
	+ using 1 Map_g_in_hhom by auto
	+ qed
	+ qed
	+
	+ theorem UP_is_equivalence_pseudofunctor:
	+ shows "equivalence_pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP \<Phi>" ..
	+
	+ text \<open>
	+ Next, we work out the details of the equivalence pseudofunctor \<open>DN\<close> in the
	+ converse direction.
	+ \<close>
	+
	+ definition DN
	+ where "DN \<mu> \<equiv> if arr \<mu> then Map \<mu> else B.null"
	+
	+ lemma DN_in_hom [intro]:
	+ assumes "arr \<mu>"
	+ shows "\<guillemotleft>DN \<mu> : DN (src \<mu>) \<rightarrow>\<^sub>B DN (trg \<mu>)\<guillemotright>"
	+ and "\<guillemotleft>DN \<mu> : DN (dom \<mu>) \<Rightarrow>\<^sub>B DN (cod \<mu>)\<guillemotright>"
	+ using assms DN_def arr_char [of \<mu>] B.vconn_implies_hpar(1-2) E.eval_in_hom(1)
	+ B.in_hhom_def
	+ by auto
	+
	+ lemma DN_simps [simp]:
	+ assumes "arr \<mu>"
	+ shows "B.arr (DN \<mu>)"
	+ and "src\<^sub>B (DN \<mu>) = DN (src \<mu>)" and "trg\<^sub>B (DN \<mu>) = DN (trg \<mu>)"
	+ and "B.dom (DN \<mu>) = DN (dom \<mu>)" and "B.cod (DN \<mu>) = DN (cod \<mu>)"
	+ using assms DN_in_hom by auto
	+
	+ interpretation "functor" vcomp V\<^sub>B DN
	+ using DN_def seqE Map_comp seq_char
	+ by (unfold_locales, auto)
	+
	+ interpretation DN: weak_arrow_of_homs vcomp src trg V\<^sub>B src\<^sub>B trg\<^sub>B DN
	+ proof
	+ fix \<mu>
	+ assume \<mu>: "arr \<mu>"
	+ show "B.isomorphic (DN (src \<mu>)) (src\<^sub>B (DN \<mu>))"
	+ proof -
	+ have "DN (src \<mu>) = src\<^sub>B (DN \<mu>)"
	+ using \<mu> DN_def arr_char E.eval_simps(2) E.Ide_implies_Arr
	+ apply simp
	+ by (metis (no_types, lifting) B.vconn_implies_hpar(1) E.Nml_implies_Arr ideE
	+ ide_src src_simps(3))
	+ moreover have "B.ide (DN (src \<mu>))"
	+ using \<mu> by simp
	+ ultimately show ?thesis
	+ using \<mu> B.isomorphic_reflexive by auto
	+ qed
	+ show "B.isomorphic (DN (trg \<mu>)) (trg\<^sub>B (DN \<mu>))"
	+ proof -
	+ have "DN (trg \<mu>) = trg\<^sub>B (DN \<mu>)"
	+ using \<mu> DN_def arr_char E.eval_simps(3) E.Ide_implies_Arr
	+ apply simp
	+ by (metis (no_types, lifting) B.vconn_implies_hpar(2) E.Nml_implies_Arr ideE
	+ ide_trg trg_simps(3))
	+ moreover have "B.ide (DN (trg \<mu>))"
	+ using \<mu> by simp
	+ ultimately show ?thesis
	+ using B.isomorphic_reflexive by auto
	+ qed
	+ qed
	+
	+ interpretation "functor" VV.comp B.VV.comp DN.FF
	+ using DN.functor_FF by auto
	+ interpretation HoDN_DN: composite_functor VV.comp B.VV.comp V\<^sub>B
	+ DN.FF \<open>\<lambda>\<mu>\<nu>. H\<^sub>B (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> ..
	+ interpretation DNoH: composite_functor VV.comp vcomp V\<^sub>B
	+ \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> DN ..
	+
	+ abbreviation \<Psi>\<^sub>o
	+ where "\<Psi>\<^sub>o fg \<equiv> B.can (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)) (Dom (fst fg) \<^bold>\<star> Dom (snd fg))"
	+
	+ abbreviation \<Psi>\<^sub>o'
	+ where "\<Psi>\<^sub>o' fg \<equiv> B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
	+
	+ lemma \<Psi>\<^sub>o_in_hom:
	+ assumes "VV.ide fg"
	+ shows "\<guillemotleft>\<Psi>\<^sub>o fg : Map (fst fg) \<star>\<^sub>B Map (snd fg) \<Rightarrow>\<^sub>B \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>\<guillemotright>"
	+ and "\<guillemotleft>\<Psi>\<^sub>o' fg : \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace> \<Rightarrow>\<^sub>B Map (fst fg) \<star>\<^sub>B Map (snd fg)\<guillemotright>"
	+ and "B.inverse_arrows (\<Psi>\<^sub>o fg) (\<Psi>\<^sub>o' fg)"
	+ proof -
	+ have 1: "E.Ide (Dom (fst fg) \<^bold>\<star> Dom (snd fg))"
	+ unfolding E.Ide.simps(3)
	+ apply (intro conjI)
	+ using assms VV.ide_char VV.arr_char arr_char
	+ apply simp
	+ using VV.arr_char VV.ideD(1) assms
	+ apply blast
	+ by (metis (no_types, lifting) VV.arrE VV.ideD(1) assms src_simps(1) trg_simps(1))
	+ have 2: "E.Ide (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
	+ using 1
	+ by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char VV.ideD(1) arr_char assms)
	+ have 3: "\<^bold>\<lfloor>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<^bold>\<rfloor>"
	+ by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
	+ E.Nmlize_Nml VV.arr_char VV.ideD(1) arr_char assms 1)
	+ have 4: "\<lbrace>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<rbrace> = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
	+ using assms VV.ide_char VV.arr_char arr_char by simp
	+ show "\<guillemotleft>\<Psi>\<^sub>o fg : Map (fst fg) \<star>\<^sub>B Map (snd fg) \<Rightarrow>\<^sub>B \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>\<guillemotright>"
	+ using 1 2 3 4 by auto
	+ show "\<guillemotleft>\<Psi>\<^sub>o' fg : \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace> \<Rightarrow>\<^sub>B Map (fst fg) \<star>\<^sub>B Map (snd fg)\<guillemotright>"
	+ using 1 2 3 4 by auto
	+ show "B.inverse_arrows (\<Psi>\<^sub>o fg) (\<Psi>\<^sub>o' fg)"
	+ using 1 2 3 B.inverse_arrows_can by blast
	+ qed
	+
	+ interpretation \<Psi>: transformation_by_components
	+ VV.comp V\<^sub>B HoDN_DN.map DNoH.map \<Psi>\<^sub>o
	+ proof
	+ fix fg
	+ assume fg: "VV.ide fg"
	+ have 1: "\<lbrace>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<rbrace> = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
	+ using fg VV.ide_char VV.arr_char arr_char by simp
	+ show "\<guillemotleft>\<Psi>\<^sub>o fg : HoDN_DN.map fg \<Rightarrow>\<^sub>B DNoH.map fg\<guillemotright>"
	+ proof
	+ show "B.arr (\<Psi>\<^sub>o fg)"
	+ using fg \<Psi>\<^sub>o_in_hom by blast
	+ show "B.dom (\<Psi>\<^sub>o fg) = HoDN_DN.map fg"
	+ proof -
	+ have "B.dom (\<Psi>\<^sub>o fg) = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
	+ using fg \<Psi>\<^sub>o_in_hom by blast
	+ also have "... = HoDN_DN.map fg"
	+ using fg DN.FF_def DN_def VV.arr_char src_def trg_def VV.ide_char by auto
	+ finally show ?thesis by simp
	+ qed
	+ show "B.cod (\<Psi>\<^sub>o fg) = DNoH.map fg"
	+ proof -
	+ have "B.cod (\<Psi>\<^sub>o fg) = \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>"
	+ using fg \<Psi>\<^sub>o_in_hom by blast
	+ also have "... = DNoH.map fg"
	+ proof -
	+ have "DNoH.map fg =
	+ B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) \<cdot>\<^sub>B
	+ (Map (fst fg) \<star>\<^sub>B Map (snd fg)) \<cdot>\<^sub>B
	+ B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
	+ using fg DN_def Map_hcomp VV.arr_char
	+ apply simp
	+ using VV.ideD(1) by blast
	+ also have "... =
	+ B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) \<cdot>\<^sub>B
	+ B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
	+ proof -
	+ have "(Map (fst fg) \<star>\<^sub>B Map (snd fg)) \<cdot>\<^sub>B
	+ B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)) =
	+ B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
	+ using fg 1 \<Psi>\<^sub>o_in_hom B.comp_cod_arr by blast
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>"
	+ proof -
	+ have "B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) = \<Psi>\<^sub>o fg"
	+ using fg VV.ide_char Cod_ide by simp
	+ thus ?thesis
	+ using fg 1 \<Psi>\<^sub>o_in_hom [of fg] B.comp_arr_inv' by fastforce
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ next
	+ show "\<And>f. VV.arr f \<Longrightarrow>
	+ \<Psi>\<^sub>o (VV.cod f) \<cdot>\<^sub>B HoDN_DN.map f = DNoH.map f \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom f)"
	+ proof -
	+ fix \<mu>\<nu>
	+ assume \<mu>\<nu>: "VV.arr \<mu>\<nu>"
	+ show "\<Psi>\<^sub>o (VV.cod \<mu>\<nu>) \<cdot>\<^sub>B HoDN_DN.map \<mu>\<nu> = DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
	+ proof -
	+ have 1: "E.Ide (Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>))"
	+ unfolding E.Ide.simps(3)
	+ apply (intro conjI)
	+ using \<mu>\<nu> VV.ide_char VV.arr_char arr_char
	+ apply simp
	+ using VV.arr_char VV.ideD(1) \<mu>\<nu>
	+ apply blast
	+ by (metis (no_types, lifting) VV.arrE \<mu>\<nu> src_simps(1) trg_simps(1))
	+ have 2: "E.Ide (Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>))"
	+ using 1
	+ by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char VV.ideD(1) arr_char \<mu>\<nu>)
	+ have 3: "\<^bold>\<lfloor>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>)\<^bold>\<rfloor>"
	+ by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
	+ E.Nmlize_Nml VV.arr_char arr_char \<mu>\<nu> 1)
	+ have 4: "E.Ide (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>))"
	+ unfolding E.Ide.simps(3)
	+ apply (intro conjI)
	+ using \<mu>\<nu> VV.ide_char VV.arr_char arr_char
	+ apply simp
	+ using VV.arr_char VV.ideD(1) \<mu>\<nu>
	+ apply blast
	+ by (metis (no_types, lifting) "1" E.Ide.simps(3) VV.arrE \<mu>\<nu> arrE)
	+ have 5: "E.Ide (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>))"
	+ using 4
	+ by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char VV.ideD(1) arr_char \<mu>\<nu>)
	+ have 6: "\<^bold>\<lfloor>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)\<^bold>\<rfloor>"
	+ by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
	+ E.Nmlize_Nml VV.arr_char arr_char \<mu>\<nu> 1)
	+ have A: "\<guillemotleft>\<Psi>\<^sub>o' \<mu>\<nu> : \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>)\<rbrace>
	+ \<Rightarrow>\<^sub>B \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
	+ using 1 2 3 by auto
	+ have B: "\<guillemotleft>Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>) :
	+ \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
	+ using \<mu>\<nu> VV.arr_char arr_char src_def trg_def E.Nml_implies_Arr E.eval_simps'(2-3)
	+ by auto
	+ have C: "\<guillemotleft>B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) :
	+ \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
	+ using 4 5 6 by auto
	+ have "\<Psi>\<^sub>o (VV.cod \<mu>\<nu>) \<cdot>\<^sub>B HoDN_DN.map \<mu>\<nu> =
	+ B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
	+ (Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>))"
	+ using \<mu>\<nu> VV.arr_char VV.cod_char arr_char src_def trg_def cod_char DN.FF_def DN_def
	+ by auto
	+ also have "... = B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>))
	+ (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
	+ (Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>)) \<cdot>\<^sub>B \<Psi>\<^sub>o' \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o \<mu>\<nu>"
	+ using B B.comp_assoc \<mu>\<nu> VV.arr_char arr_char src_def trg_def B.inverse_arrows_can
	+ E.Ide_HcompNml E.Nmlize_Nml E.Nml_HcompNml(1) B.can_Ide_self B.comp_arr_dom
	+ by auto
	+ also have "... = DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
	+ proof -
	+ have "DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>) =
	+ B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
	+ (Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>)) \<cdot>\<^sub>B \<Psi>\<^sub>o' \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
	+ using \<mu>\<nu> VV.arr_char arr_char src_def trg_def E.Ide_HcompNml E.Nml_HcompNml
	+ E.Src_HcompNml E.Trg_HcompNml \<mu>\<nu> A B C DN_def hcomp_def B.comp_assoc
	+ by auto
	+ moreover have "\<Psi>\<^sub>o (VV.dom \<mu>\<nu>) = \<Psi>\<^sub>o \<mu>\<nu>"
	+ using \<mu>\<nu> VV.dom_char VV.arr_char by auto
	+ ultimately show ?thesis
	+ using B.comp_assoc by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+
	+ abbreviation \<Psi>
	+ where "\<Psi> \<equiv> \<Psi>.map"
	+
	+ interpretation \<Psi>: natural_isomorphism VV.comp V\<^sub>B HoDN_DN.map DNoH.map \<Psi>
	+ proof
	+ show "\<And>fg. VV.ide fg \<Longrightarrow> B.iso (\<Psi> fg)"
	+ proof -
	+ fix fg
	+ assume fg: "VV.ide fg"
	+ have "B.inverse_arrows (\<Psi>\<^sub>o fg) (\<Psi>\<^sub>o' fg)"
	+ using fg \<Psi>\<^sub>o_in_hom by simp
	+ thus "B.iso (\<Psi> fg)"
	+ using fg B.iso_def \<Psi>.map_simp_ide by auto
	+ qed
	+ qed
	+
	+ no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
	+
	+ lemma \<Psi>_in_hom [intro]:
	+ assumes "arr (fst \<mu>\<nu>)" and "arr (snd \<mu>\<nu>)" and "src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)"
	+ shows "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
	+ and "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
	+ \<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
	+ proof -
	+ have 1: "VV.arr \<mu>\<nu>"
	+ using assms VV.arr_char by simp
	+ show 2: "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
	+ \<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
	+ proof -
	+ have "HoDN_DN.map (VV.dom \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
	+ using assms 1 DN.FF_def by auto
	+ moreover have "DNoH.map (VV.cod \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
	+ using assms 1 by simp
	+ ultimately show ?thesis
	+ using assms 1 \<Psi>.preserves_hom by auto
	+ qed
	+ show "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
	+ using assms 1 2 B.src_dom [of "\<Psi> \<mu>\<nu>"] B.trg_dom [of "\<Psi> \<mu>\<nu>"] by auto
	+ qed
	+
	+ lemma \<Psi>_simps [simp]:
	+ assumes "arr (fst \<mu>\<nu>)" and "arr (snd \<mu>\<nu>)" and "src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)"
	+ shows "B.arr (\<Psi> \<mu>\<nu>)"
	+ and "src\<^sub>B (\<Psi> \<mu>\<nu>) = DN (src (snd \<mu>\<nu>))" and "trg\<^sub>B (\<Psi> \<mu>\<nu>) = DN (trg (fst \<mu>\<nu>))"
	+ and "B.dom (\<Psi> \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
	+ and "B.cod (\<Psi> \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
	+ proof
	+ show "VV.arr \<mu>\<nu>"
	+ using assms by blast
	+ have 1: "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
	+ using assms by blast
	+ show "src\<^sub>B (\<Psi> \<mu>\<nu>) = DN (src (snd \<mu>\<nu>))"
	+ using 1 by fast
	+ show "trg\<^sub>B (\<Psi> \<mu>\<nu>) = DN (trg (fst \<mu>\<nu>))"
	+ using 1 by fast
	+ have 2: "\<guillemotleft>\<Psi> \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
	+ \<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
	+ using assms by blast
	+ show "B.dom (\<Psi> \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
	+ using 2 by fast
	+ show "B.cod (\<Psi> \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
	+ using 2 by fast
	+ qed
	+
	+ interpretation DN: pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN \<Psi>
	+ proof
	+ show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow>
	+ DN (\<a> f g h) \<cdot>\<^sub>B \<Psi> (f \<star> g, h) \<cdot>\<^sub>B (\<Psi> (f, g) \<star>\<^sub>B DN h) =
	+ \<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
	+ proof -
	+ fix f g h
	+ assume f: "ide f" and g: "ide g" and h: "ide h"
	+ and fg: "src f = trg g" and gh: "src g = trg h"
	+ show "DN (\<a> f g h) \<cdot>\<^sub>B \<Psi> (f \<star> g, h) \<cdot>\<^sub>B (\<Psi> (f, g) \<star>\<^sub>B DN h) =
	+ \<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
	+ proof -
	+ have 1: "E.Trg (Dom g) = E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<and>
	+ \<lbrace>E.Trg (Dom g)\<rbrace> = \<lbrace>E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)\<rbrace>"
	+ using f g h fg gh arr_char src_def trg_def E.Trg_HcompNml
	+ by (metis (no_types, lifting) ideD(1) src_simps(2) trg_simps(2))
	+ have 2: "arr (MkArr (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)
	+ (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<cdot>\<^sub>B
	+ (Map f \<star>\<^sub>B B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)))"
	+ proof -
	+ have "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<cdot>\<^sub>B
	+ (Map f \<star>\<^sub>B
	+ B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
	+ EVAL (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B EVAL (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
	+ proof (intro B.comp_in_homI)
	+ show 2: "\<guillemotleft>B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
	+ EVAL (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B
	+ EVAL (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)\<guillemotright>"
	+ using f g h fg gh 1
	+ apply (intro B.can_in_hom)
	+ apply (metis (no_types, lifting) E.Ide_HcompNml E.Nml_HcompNml(1)
	+ arr_char ideD(1) src_simps(1) trg_simps(1))
	+ apply (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml ideD(1)
	+ arr_char src_simps(1) trg_simps(1))
	+ by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
	+ E.Nmlize_Nml ideD(1) arr_char src_simps(1) trg_simps(1))
	+ show "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) :
	+ EVAL (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<Rightarrow>\<^sub>B
	+ EVAL (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
	+ proof -
	+ have "E.Ide (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
	+ using f g h fg gh 1 Cod_ide E.Ide_HcompNml arr_char
	+ apply simp
	+ by (metis (no_types, lifting) ideD(1) src_simps(1) trg_simps(1))
	+ moreover have "E.Ide (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
	+ using f g h fg gh
	+ by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Nml_HcompNml(1)
	+ arr_char calculation ideD(1) src_simps(1) trg_simps(1))
	+ moreover have "E.Nmlize (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) =
	+ E.Nmlize (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
	+ using f g h fg gh
	+ by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
	+ E.Nmlize_Nml arr_char calculation(1) ideD(1) src_simps(1) trg_simps(1))
	+ ultimately show ?thesis
	+ using B.can_in_hom [of "Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h" "Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h"]
	+ by blast
	+ qed
	+ show
	+ "\<guillemotleft>Map f \<star>\<^sub>B B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B
	+ B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
	+ EVAL (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B EVAL (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
	+ using f g h fg gh B.can_in_hom
	+ apply simp
	+ proof (intro B.hcomp_in_vhom B.comp_in_homI)
	+ show 1: "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
	+ EVAL (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B EVAL (Dom g \<^bold>\<star> Dom h)\<guillemotright>"
	+ using g h gh B.can_in_hom
	+ by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Nml_HcompNml(1)
	+ E.Nmlize.simps(3) E.Nmlize_Nml arr_char ideD(1) src_simps(1) trg_simps(1))
	+ show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) :
	+ EVAL (Cod g \<^bold>\<star> Cod h) \<Rightarrow>\<^sub>B EVAL (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
	+ using g h gh B.can_in_hom
	+ by (metis (no_types, lifting) Cod_ide E.Ide.simps(3) E.Ide_HcompNml
	+ E.Nml_HcompNml(1) E.Nmlize.simps(3) E.Nmlize_Nml arr_char ideD(1)
	+ src_simps(2) trg_simps(2))
	+ show "\<guillemotleft>Map g \<star>\<^sub>B Map h : EVAL (Dom g \<^bold>\<star> Dom h) \<Rightarrow>\<^sub>B EVAL (Cod g \<^bold>\<star> Cod h)\<guillemotright>"
	+ using g h gh 1 Map_in_Hom B.hcomp_in_vhom B.not_arr_null B.seq_if_composable
	+ B.trg.is_extensional B.trg.preserves_hom B.vconn_implies_hpar(2)
	+ B.vconn_implies_hpar(4) Cod_ide E.eval.simps(3) Map_ide(1)
	+ arr_char ideD(1)
	+ by (metis (no_types, lifting))
	+ show "\<guillemotleft>Map f : Map f \<Rightarrow>\<^sub>B EVAL (Cod f)\<guillemotright>"
	+ using f arr_char Cod_ide by auto
	+ show "src\<^sub>B (Map f) = trg\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
	+ using f g h fg gh 1 2 src_def trg_def B.arrI B.hseqE B.not_arr_null
	+ B.trg.is_extensional B.trg.preserves_hom B.vconn_implies_hpar(2)
	+ B.vconn_implies_hpar(4) E.eval.simps(3)
	+ by (metis (no_types, lifting) Map_ide(1))
	+ qed
	+ qed
	+ thus ?thesis
	+ using f g h fg gh arr_char src_def trg_def E.Nml_HcompNml E.Ide_HcompNml
	+ ideD(1)
	+ apply (intro arr_MkArr) by auto
	+ qed
	+ have 3: "E.Ide (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using g h gh ide_char arr_char src_def trg_def E.Ide_HcompNml Cod_ide
	+ by (metis (no_types, lifting) ideD(1) src_simps(2) trg_simps(2))
	+ have 4: "E.Ide (Dom g \<^bold>\<star> Dom h)"
	+ using g h gh ide_char arr_char src_def trg_def Cod_ide
	+ by (metis (no_types, lifting) E.Ide.simps(3) arrE ideD(1) src_simps(2) trg_simps(2))
	+ have 5: "E.Nmlize (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Nmlize (Dom g \<^bold>\<star> Dom h)"
	+ using g h gh ide_char arr_char src_def trg_def E.Nml_HcompNml
	+ by (metis (no_types, lifting) 4 E.Ide.simps(3) E.Nmlize.simps(3) E.Nmlize_Nml
	+ ideD(1))
	+ have 6: "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h fg gh arr_char src_def trg_def
	+ by (metis (no_types, lifting) 1 E.Nml_HcompNml(1) E.Ide_HcompNml ideD(1)
	+ src_simps(2) trg_simps(2))
	+ have 7: "E.Ide (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h fg gh arr_char src_def trg_def
	+ by (metis (no_types, lifting) 1 3 E.Ide.simps(3) ideD(1) src_simps(2) trg_simps(2))
	+ have 8: "E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
	+ E.Nmlize (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h fg gh arr_char src_def trg_def
	+ 7 E.Nml_HcompNml(1) ideD(1)
	+ by auto
	+ have "DN (\<a> f g h) \<cdot>\<^sub>B \<Psi> (f \<star> g, h) \<cdot>\<^sub>B (\<Psi> (f, g) \<star>\<^sub>B DN h) =
	+ B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
	+ proof -
	+ have 9: "VVV.arr (f, g, h)"
	+ using f g h fg gh VVV.arr_char VV.arr_char arr_char ideD by simp
	+ have 10: "VV.ide (f, g)"
	+ using f g fg VV.ide_char by auto
	+ have 11: "VV.ide (hcomp f g, h)"
	+ using f g h fg gh VV.ide_char VV.arr_char by simp
	+ have 12: "arr (MkArr (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)
	+ (B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B
	+ B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)))"
	+ proof (intro arr_MkArr)
	+ show "Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h \<in> IDE"
	+ using g h gh
	+ by (metis (no_types, lifting) 3 E.Nml_HcompNml(1) arr_char ideD(1)
	+ mem_Collect_eq src_simps(2) trg_simps(2))
	+ show "Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h \<in> IDE"
	+ using g h gh Cod_ide \<open>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h \<in> IDE\<close> by auto
	+ show "B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B
	+ B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)
	+ \<in> HOM (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
	+ proof
	+ show "E.Src (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Src (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<and>
	+ E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Trg (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<and>
	+ \<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
	+ \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
	+ proof (intro conjI)
	+ show "E.Src (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Src (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
	+ using g h gh Cod_ide by simp
	+ show "E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Trg (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
	+ using g h gh Cod_ide by simp
	+ show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
	+ \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
	+ proof (intro B.comp_in_homI)
	+ show "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
	+ \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom g \<^bold>\<star> Dom h\<rbrace>\<guillemotright>"
	+ using 3 4 5 by blast
	+ show "\<guillemotleft>Map g \<star>\<^sub>B Map h : \<lbrace>Dom g \<^bold>\<star> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<star> Cod h\<rbrace>\<guillemotright>"
	+ using g h gh
	+ by (metis (no_types, lifting) 4 B.ide_in_hom(2) Cod_ide E.eval.simps(3)
	+ E.ide_eval_Ide Map_ide(2))
	+ show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) :
	+ \<lbrace>Cod g \<^bold>\<star> Cod h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
	+ using 3 4 5 Cod_ide g h by auto
	+ qed
	+ qed
	+ qed
	+ qed
	+ have "DN (\<a> f g h) = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
	+ proof -
	+ have "DN (\<a> f g h) =
	+ (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
	+ ((Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h))) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h))"
	+ using f g h fg gh 1 2 9 10 11 12 DN_def \<a>_def hcomp_def src_def trg_def
	+ B.comp_assoc Cod_ide
	+ by simp
	+ also have
	+ "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
	+ (Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ proof -
	+ have "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
	+ \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B Map g \<star>\<^sub>B Map h\<guillemotright>"
	+ using g h 3 4 5 B.can_in_hom [of "Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h" "Dom g \<^bold>\<star> Dom h"]
	+ by simp
	+ hence "Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
	+ Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
	+ B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using B.comp_cod_arr by auto
	+ also have "... = Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
	+ using f g h fg gh arr_char src_def trg_def B.vcomp_can
	+ B.can_Ide_self
	+ using 3 4 5 by auto
	+ finally have "Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
	+ (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
	+ Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
	+ by simp
	+ thus ?thesis by simp
	+ qed
	+ also have
	+ "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ proof -
	+ have "\<guillemotleft>B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
	+ \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>\<guillemotright>"
	+ using f g h 6 7 8
	+ B.can_in_hom [of "Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h" "Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h"]
	+ by simp
	+ hence "(Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
	+ B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using B.comp_cod_arr by auto
	+ thus ?thesis by simp
	+ qed
	+ also have
	+ "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h fg gh src_def trg_def B.vcomp_can
	+ using 6 7 8 by auto
	+ also have "... = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
	+ using f g h fg gh src_def trg_def B.can_Ide_self
	+ using 6 by blast
	+ finally show ?thesis by simp
	+ qed
	+ have "DN (\<a> f g h) \<cdot>\<^sub>B \<Psi> (f \<star> g, h) \<cdot>\<^sub>B (\<Psi> (f, g) \<star>\<^sub>B DN h) =
	+ B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
	+ B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) \<cdot>\<^sub>B
	+ (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h)"
	+ proof -
	+ have "DN (\<a> f g h) =
	+ B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h fg gh DN_def 1 4 6 7 B.can_Ide_self E.HcompNml_assoc
	+ E.Ide.simps(3) \<open>DN (\<a> f g h) = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>\<close> ide_char
	+ by (metis (no_types, lifting) arr_char ideD(1))
	+ thus ?thesis
	+ using f g h fg gh 1 2 4 5 6 7 8 9 10 11 12 DN_def \<alpha>_def
	+ \<Psi>.map_simp_ide hcomp_def src_def trg_def Cod_ide
	+ by simp
	+ qed
	+ also have
	+ "... = (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
	+ B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)) \<cdot>\<^sub>B
	+ (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h)"
	+ using B.comp_assoc by simp
	+ also have
	+ "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) \<cdot>\<^sub>B
	+ B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
	+ proof -
	+ have "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h =
	+ B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
	+ proof -
	+ have "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h =
	+ B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B B.can (Dom h) (Dom h)"
	+ using h B.can_Ide_self by fastforce
	+ also have "... = B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
	+ using f g h 1 4 7 arr_char E.Nml_HcompNml(1) E.Src_HcompNml
	+ B.hcomp_can [of "Dom f \<^bold>\<star> Dom g" "Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g" "Dom h" "Dom h"]
	+ by (metis (no_types, lifting) E.Nmlize.simps(3) E.Nmlize_Nml
	+ E.Ide.simps(3) E.Ide_HcompNml E.Src.simps(3) arrE ideD(1))
	+ finally show ?thesis by simp
	+ qed
	+ moreover have
	+ "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
	+ B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
	+ B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
	+ proof -
	+ have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
	+ using f g h 1 4 7
	+ by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Src_HcompNml
	+ arrE ideD(1))
	+ moreover have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h 1 4 7 E.Ide_HcompNml E.Nml_HcompNml(1) arr_char calculation
	+ ideD(1)
	+ by auto
	+ moreover have "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h 1 4 6 by blast
	+ moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
	+ E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h 1 4 7
	+ by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
	+ E.Nmlize_Nml E.Ide.simps(3) arrE calculation(1) ideD(1))
	+ moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
	+ E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h 1 4 7 E.HcompNml_assoc by fastforce
	+ ultimately show ?thesis
	+ using B.vcomp_can by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
	+ proof -
	+ have "E.Ide ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
	+ using 1 4 7 by simp
	+ moreover have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
	+ using f g 1 4 7
	+ by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Src_HcompNml
	+ arrE ideD(1))
	+ moreover have "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h 1 8 6 7 by blast
	+ moreover have "E.Nmlize ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h) =
	+ E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
	+ using f g h 1 4 7 E.Nml_HcompNml(1) by fastforce
	+ moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
	+ E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
	+ using f g h 1 4 7
	+ by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
	+ E.Nmlize_Nml E.HcompNml_assoc E.Ide.simps(3) arrE ideD(1))
	+ ultimately show ?thesis
	+ using B.vcomp_can by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = \<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
	+ proof -
	+ have "\<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h] =
	+ (\<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h))) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
	+ using B.comp_assoc by simp
	+ also have
	+ "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
	+ proof -
	+ have "\<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) =
	+ B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
	+ proof -
	+ have "\<Psi> (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B \<Psi> (g, h)) =
	+ B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
	+ (Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h))"
	+ proof -
	+ have "VV.ide (g, h)"
	+ using g h gh VV.ide_char VV.arr_char by simp
	+ moreover have "VV.ide (f, hcomp g h)"
	+ using f g h fg gh VV.ide_char VV.arr_char by simp
	+ ultimately show ?thesis
	+ using f g h fg gh \<Psi>.map_simp_ide DN_def hcomp_def src_def trg_def
	+ by simp
	+ qed
	+ also have
	+ "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
	+ (B.can (Dom f) (Dom f) \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h))"
	+ proof -
	+ have "Map f = B.can (Dom f) (Dom f)"
	+ using f arr_char B.can_Ide_self [of "Dom f"] Map_ide
	+ by (metis (no_types, lifting) ide_char')
	+ thus ?thesis by simp
	+ qed
	+ also have
	+ "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
	+ B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
	+ using 1 4 5 7 B.hcomp_can by auto
	+ also have "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
	+ using 1 4 5 6 7 8 B.vcomp_can by auto
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "\<a>\<^sub>B[DN f, DN g, DN h] =
	+ B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
	+ using f g h 1 4 7 DN_def B.canE_associator(1) Map_ide
	+ by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
	+ using 1 4 5 6 7 8 E.Nmlize_Hcomp_Hcomp
	+ B.vcomp_can [of "(Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h" "Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h"
	+ "Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h"]
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+
	+ lemma DN_is_pseudofunctor:
	+ shows "pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN \<Psi>"
	+ ..
	+
	+ interpretation faithful_functor vcomp V\<^sub>B DN
	+ proof
	+ fix \<mu> \<mu>'
	+ assume par: "par \<mu> \<mu>'" and eq: "DN \<mu> = DN \<mu>'"
	+ show "\<mu> = \<mu>'"
	+ proof (intro arr_eqI)
	+ show "arr \<mu>"
	+ using par by simp
	+ show "arr \<mu>'"
	+ using par by simp
	+ show "Dom \<mu> = Dom \<mu>'"
	+ using par arr_char dom_char by force
	+ show "Cod \<mu> = Cod \<mu>'"
	+ using par arr_char cod_char by force
	+ show "Map \<mu> = Map \<mu>'"
	+ using par eq DN_def by simp
	+ qed
	+ qed
	+
	+ no_notation B.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
	+
	+ lemma DN_UP:
	+ assumes "B.arr \<mu>"
	+ shows "DN (UP \<mu>) = \<mu>"
	+ using assms UP_def DN_def arr_UP by auto
	+
	+ interpretation DN: equivalence_pseudofunctor
	+ vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN \<Psi>
	+ proof
	+ (* DN is locally (but not globally) full. *)
	+ show "\<And>f f' \<nu>. \<lbrakk> ide f; ide f'; src f = src f'; trg f = trg f'; \<guillemotleft>\<nu> : DN f \<Rightarrow>\<^sub>B DN f'\<guillemotright> \<rbrakk>
	+ \<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> DN \<mu> = \<nu>"
	+ proof -
	+ fix f f' \<nu>
	+ assume f: "ide f" and f': "ide f'"
	+ and eq_src: "src f = src f'" and eq_trg: "trg f = trg f'"
	+ and \<nu>: "\<guillemotleft>\<nu> : DN f \<Rightarrow>\<^sub>B DN f'\<guillemotright>"
	+ show "\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> DN \<mu> = \<nu>"
	+ proof -
	+ let ?\<mu> = "MkArr (Dom f) (Dom f') \<nu>"
	+ have \<mu>: "\<guillemotleft>?\<mu> : f \<Rightarrow> f'\<guillemotright>"
	+ proof
	+ have "Map f = \<lbrace>Dom f\<rbrace>"
	+ using f by simp
	+ have "Map f' = \<lbrace>Dom f'\<rbrace>"
	+ using f' by simp
	+ have "Dom f' = Cod f'"
	+ using f' Cod_ide by simp
	+ show \<mu>: "arr ?\<mu>"
	+ proof -
	+ have "E.Nml (Dom ?\<mu>) \<and> E.Ide (Dom ?\<mu>)"
	+ proof -
	+ have "E.Nml (Dom f) \<and> E.Ide (Dom f)"
	+ using f ide_char arr_char by blast
	+ thus ?thesis
	+ using f by simp
	+ qed
	+ moreover have "E.Nml (Cod ?\<mu>) \<and> E.Ide (Cod ?\<mu>)"
	+ proof -
	+ have "E.Nml (Dom f') \<and> E.Ide (Dom f')"
	+ using f' ide_char arr_char by blast
	+ thus ?thesis
	+ using f' by simp
	+ qed
	+ moreover have "E.Src (Dom ?\<mu>) = E.Src (Cod ?\<mu>)"
	+ using f f' \<nu> arr_char src_def eq_src ideD(1) by auto
	+ moreover have "E.Trg (Dom ?\<mu>) = E.Trg (Cod ?\<mu>)"
	+ using f f' \<nu> arr_char trg_def eq_trg ideD(1) by auto
	+ moreover have "\<guillemotleft>Map ?\<mu> : \<lbrace>Dom ?\<mu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod ?\<mu>\<rbrace>\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>\<nu> : \<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom f'\<rbrace>\<guillemotright>"
	+ using f f' \<nu> ide_char arr_char DN_def Cod_ide Map_ide
	+ by (metis (no_types, lifting) ideD(1))
	+ thus ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using f f' \<nu> ide_char arr_char by blast
	+ qed
	+ show "dom ?\<mu> = f"
	+ using f \<mu> dom_char MkArr_Map MkIde_Dom' by simp
	+ show "cod ?\<mu> = f'"
	+ proof -
	+ have "cod ?\<mu> = MkIde (Dom f')"
	+ using \<mu> cod_char by simp
	+ also have "... = MkArr (Dom f') (Cod f') (Map f')"
	+ using f' by auto
	+ also have "... = f'"
	+ using f' MkArr_Map by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ moreover have "DN ?\<mu> = \<nu>"
	+ using \<mu> DN_def by auto
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ (* DN is essentially surjective up to equivalence on objects. *)
	+ show "\<And>a'. B.obj a' \<Longrightarrow> \<exists>a. obj a \<and> B.equivalent_objects (DN.map\<^sub>0 a) a'"
	+ proof -
	+ fix a'
	+ assume a': "B.obj a'"
	+ have "obj (UP.map\<^sub>0 a')"
	+ using a' UP.map\<^sub>0_simps(1) by simp
	+ moreover have "B.equivalent_objects (DN.map\<^sub>0 (UP.map\<^sub>0 a')) a'"
	+ proof -
	+ have "arr (MkArr \<^bold>\<langle>a'\<^bold>\<rangle> \<^bold>\<langle>a'\<^bold>\<rangle> a')"
	+ using a' UP_def [of a'] UP.preserves_reflects_arr [of a'] by auto
	+ moreover have "arr (MkArr \<^bold>\<langle>a'\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a'\<^bold>\<rangle>\<^sub>0 a')"
	+ using a' arr_char B.obj_def by auto
	+ ultimately have "DN.map\<^sub>0 (UP.map\<^sub>0 a') = a'"
	+ using a' UP.map\<^sub>0_def UP_def DN.map\<^sub>0_def DN_def src_def UP.map\<^sub>0_simps(1)
	+ by auto
	+ thus ?thesis
	+ using a' B.equivalent_objects_reflexive by simp
	+ qed
	+ ultimately show "\<exists>a. obj a \<and> B.equivalent_objects (DN.map\<^sub>0 a) a'"
	+ by blast
	+ qed
	+ (* DN is locally essentially surjective. *)
	+ show "\<And>a b g. \<lbrakk> obj a; obj b; \<guillemotleft>g : DN.map\<^sub>0 a \<rightarrow>\<^sub>B DN.map\<^sub>0 b\<guillemotright>; B.ide g \<rbrakk> \<Longrightarrow>
	+ \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> B.isomorphic (DN f) g"
	+ proof -
	+ fix a b g
	+ assume a: "obj a" and b: "obj b"
	+ and g: "\<guillemotleft>g : DN.map\<^sub>0 a \<rightarrow>\<^sub>B DN.map\<^sub>0 b\<guillemotright>" and ide_g: "B.ide g"
	+ have "ide (UP g)"
	+ using ide_g UP.preserves_ide by simp
	+ moreover have "B.isomorphic (DN (UP g)) g"
	+ using ide_g DN_UP B.isomorphic_reflexive by simp
	+ moreover have "\<guillemotleft>UP g : a \<rightarrow> b\<guillemotright>"
	+ proof
	+ show "arr (UP g)"
	+ using g UP.preserves_reflects_arr by auto
	+ show "src (UP g) = a"
	+ proof -
	+ have "src (UP g) = MkArr \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 (src\<^sub>B g)"
	+ using ide_g src_def UP_def UP.preserves_reflects_arr [of g] B.ideD(1) by simp
	+ also have "... = a"
	+ proof -
	+ have "src\<^sub>B g = src\<^sub>B (DN.map\<^sub>0 a)"
	+ using a g B.in_hhom_def by simp
	+ also have "... = Map a"
	+ using a Map_preserves_objects DN.map\<^sub>0_def DN_def B.src_src by auto
	+ finally have "src\<^sub>B g = Map a" by simp
	+ hence "MkArr \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 (src\<^sub>B g) = MkArr \<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0 (Map a)"
	+ by simp
	+ also have "... = a"
	+ using a obj_char apply (cases "Dom a", simp_all)
	+ by (metis (no_types, lifting) B.obj_def' a comp_ide_arr dom_char dom_eqI objE)
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ show "trg (UP g) = b"
	+ proof -
	+ have "trg (UP g) = MkArr \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B g)"
	+ using ide_g trg_def UP_def UP.preserves_reflects_arr [of g] B.ideD(1) by simp
	+ also have "... = b"
	+ proof -
	+ have "trg\<^sub>B g = trg\<^sub>B (DN.map\<^sub>0 b)"
	+ using b g B.in_hhom_def by simp
	+ also have "... = Map b"
	+ using b Map_preserves_objects DN.map\<^sub>0_def DN_def B.src_src by auto
	+ finally have "trg\<^sub>B g = Map b" by simp
	+ hence "MkArr \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B g) = MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Map b)"
	+ by simp
	+ also have "... = b"
	+ using b obj_char apply (cases "Dom b", simp_all)
	+ by (metis (no_types, lifting) B.obj_def' b comp_ide_arr dom_char dom_eqI objE)
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ ultimately show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> B.isomorphic (DN f) g"
	+ by blast
	+ qed
	+ qed
	+
	+ theorem DN_is_equivalence_pseudofunctor:
	+ shows "equivalence_pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN \<Psi>"
	+ ..
	+
	+ text \<open>
	+ The following gives an explicit formula for a component of the unit isomorphism of
	+ the pseudofunctor \<open>UP\<close> from a bicategory to its strictification.
	+ It is not currently being used -- I originally proved it in order to establish something
	+ that I later proved in a more abstract setting -- but it might be useful at some point.
	+ \<close>
	+
	+ interpretation L: bicategorical_language V\<^sub>B src\<^sub>B trg\<^sub>B ..
	+ interpretation E: evaluation_map V\<^sub>B src\<^sub>B trg\<^sub>B V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
	+ \<open>\<lambda>\<mu>. if B.arr \<mu> then \<mu> else B.null\<close>
	+ using B.src.is_extensional B.trg.is_extensional
	+ by (unfold_locales, auto)
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ interpretation UP: equivalence_pseudofunctor
	+ V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP \<Phi>
	+ using UP_is_equivalence_pseudofunctor by auto
	+
	+ lemma UP_\<Psi>_char:
	+ assumes "B.obj a"
	+ shows "UP.\<Psi> a = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
	+ proof -
	+ have " MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a = UP.\<Psi> a"
	+ proof (intro UP.\<Psi>_eqI)
	+ show "B.obj a"
	+ using assms by simp
	+ have 0: "\<guillemotleft>a : a \<Rightarrow>\<^sub>B a\<guillemotright>"
	+ using assms by auto
	+ have 1: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
	+ apply (unfold arr_char, intro conjI)
	+ using assms by auto
	+ have 2: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> a)"
	+ apply (unfold arr_char, intro conjI)
	+ using assms by auto
	+ have 3: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 a)"
	+ apply (unfold arr_char, intro conjI)
	+ using assms by auto
	+ show "\<guillemotleft>MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a : UP.map\<^sub>0 a \<Rightarrow> UP a\<guillemotright>"
	+ proof
	+ show "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)" by fact
	+ show "dom (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) = UP.map\<^sub>0 a"
	+ using assms 1 2 dom_char UP.map\<^sub>0_def UP_def src_def by auto
	+ show "cod (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) = UP a"
	+ using assms 1 2 cod_char UP.map\<^sub>0_def UP_def src_def by auto
	+ qed
	+ show "iso (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
	+ using assms 1 iso_char by auto
	+ show "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<cdot> \<i> (UP.map\<^sub>0 a) =
	+ (UP \<i>\<^sub>B[a] \<cdot> \<Phi> (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
	+ proof -
	+ have "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<cdot> \<i> (UP.map\<^sub>0 a) = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
	+ proof -
	+ have "\<i> (UP.map\<^sub>0 a) = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 a"
	+ unfolding \<i>_def UP.map\<^sub>0_def UP_def
	+ using assms 2 src_def by auto
	+ moreover have "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<cdot> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 a = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
	+ using assms 0 1 2 comp_def by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = (UP \<i>\<^sub>B[a] \<cdot> \<Phi> (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
	+ proof -
	+ have "UP \<i>\<^sub>B[a] = MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a]"
	+ using assms UP_def by simp
	+ moreover have "\<Phi> (a, a) = MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a)"
	+ using assms \<Phi>_ide_simp by auto
	+ ultimately have "UP \<i>\<^sub>B[a] \<cdot> \<Phi> (a, a) = MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a]"
	+ using assms comp_def B.comp_arr_dom
	+ by (elim B.objE, auto)
	+ moreover have "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a =
	+ MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (B.runit' a)"
	+ proof -
	+ have "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a =
	+ MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>)
	+ (B.can (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<cdot>\<^sub>B B.can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
	+ using assms 0 1 2 3 hcomp_def B.comp_cod_arr src_def trg_def by auto
	+ moreover have
	+ "B.can (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<cdot>\<^sub>B B.can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 = B.runit' a"
	+ proof -
	+ have "B.can (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<cdot>\<^sub>B B.can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 =
	+ (a \<star>\<^sub>B a) \<cdot>\<^sub>B B.inv (B.runit a)"
	+ using assms B.can_Ide_self B.canE_unitor [of "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"] by auto
	+ also have "... = B.runit' a"
	+ using assms B.comp_cod_arr by auto
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ ultimately have "(UP \<i>\<^sub>B[a] \<cdot> \<Phi> (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) =
	+ MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (B.runit' a)"
	+ by simp
	+ also have "... = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
	+ using assms comp_def B.unitor_coincidence B.iso_unit B.comp_arr_inv
	+ B.inv_is_inverse
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ thus ?thesis by simp
	+ qed
	+
	+ end
	+
	+ subsection "Pseudofunctors into a Strict Bicategory"
	+
	+ text \<open>
	+ In the special case of a pseudofunctor into a strict bicategory, we can obtain
	+ explicit formulas for the images of the units and associativities under the pseudofunctor,
	+ which only involve the structure maps of the pseudofunctor, since the units and associativities
	+ in the target bicategory are all identities. This is useful in applying strictification.
	+ \<close>
	+
	+ locale pseudofunctor_into_strict_bicategory =
	+ pseudofunctor +
	+ D: strict_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ begin
	+
	+ lemma image_of_unitor:
	+ assumes "C.ide g"
	+ shows "F \<l>\<^sub>C[g] = (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ and "F \<r>\<^sub>C[g] = (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
	+ and "F (C.lunit' g) = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g)"
	+ and "F (C.runit' g) = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))"
	+ proof -
	+ show A: "F \<l>\<^sub>C[g] = (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ proof -
	+ have 1: "\<guillemotleft>(D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) :
	+ F (trg\<^sub>C g \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g : F (trg\<^sub>C g) \<star>\<^sub>D F g \<Rightarrow>\<^sub>D F g\<guillemotright>"
	+ using assms \<Psi>_char by (auto simp add: D.hcomp_obj_arr D.hseqI')
	+ show "\<guillemotleft>D.inv (\<Phi> (trg\<^sub>C g, g)) : F (trg\<^sub>C g \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F (trg\<^sub>C g) \<star>\<^sub>D F g\<guillemotright>"
	+ using assms \<Phi>_components_are_iso \<Phi>_in_hom(2) D.inv_is_inverse by simp
	+ qed
	+ have "(D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) =
	+ F g \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ using 1 D.comp_cod_arr by auto
	+ also have "... = (F \<l>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
	+ (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ using assms lunit_coherence [of g] D.strict_lunit by simp
	+ also have "... = F \<l>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D
	+ ((\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (trg\<^sub>C g, g))"
	+ using D.comp_assoc by simp
	+ also have "... = F \<l>\<^sub>C[g]"
	+ proof -
	+ have "(\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) = F (trg\<^sub>C g) \<star>\<^sub>D F g"
	+ using assms \<Psi>_char D.whisker_right
	+ by (metis C.ideD(1) C.obj_trg C.trg.preserves_reflects_arr D.comp_arr_inv'
	+ \<Psi>_simps(5) preserves_arr preserves_ide)
	+ moreover have "\<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) = F (trg\<^sub>C g \<star>\<^sub>C g)"
	+ using assms \<Phi>_components_are_iso D.comp_arr_inv D.inv_is_inverse by simp
	+ ultimately show ?thesis
	+ using assms D.comp_arr_dom D.comp_cod_arr \<Psi>_char \<Phi>_in_hom(2) by auto
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ show B: "F \<r>\<^sub>C[g] = (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
	+ proof -
	+ have 1: "\<guillemotleft>(F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) :
	+ F (g \<star>\<^sub>C src\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g)) : F g \<star>\<^sub>D F (src\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
	+ using assms \<Psi>_char by (auto simp add: D.hcomp_arr_obj D.hseqI')
	+ show "\<guillemotleft>D.inv (\<Phi> (g, src\<^sub>C g)) : F (g \<star>\<^sub>C src\<^sub>C g) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F (src\<^sub>C g)\<guillemotright>"
	+ using assms \<Phi>_components_are_iso \<Phi>_in_hom(2) D.inv_is_inverse by simp
	+ qed
	+ have "(F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) =
	+ F g \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
	+ using 1 D.comp_cod_arr by auto
	+ also have "... = (F \<r>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
	+ using assms runit_coherence [of g] D.strict_runit by simp
	+ also have "... = F \<r>\<^sub>C[g] \<cdot>\<^sub>D (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D ((F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
	+ using D.comp_assoc by simp
	+ also have "... = F \<r>\<^sub>C[g]"
	+ proof -
	+ have "(F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) = F g \<star>\<^sub>D F (src\<^sub>C g)"
	+ using assms D.whisker_left \<Psi>_char
	+ by (metis C.ideD(1) C.obj_src C.src.preserves_ide D.comp_arr_inv' D.ideD(1)
	+ \<Psi>_simps(5) preserves_ide)
	+ moreover have "\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) = F (g \<star>\<^sub>C src\<^sub>C g)"
	+ using assms \<Phi>_components_are_iso D.comp_arr_inv D.inv_is_inverse by simp
	+ ultimately show ?thesis
	+ using assms D.comp_arr_dom D.comp_cod_arr \<Psi>_char \<Phi>_in_hom(2) [of g "src\<^sub>C g"]
	+ by auto
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ show "F (C.lunit' g) = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g)"
	+ proof -
	+ have "F (C.lunit' g) = D.inv (F \<l>\<^sub>C[g])"
	+ using assms C.iso_lunit preserves_inv by simp
	+ also have "... = D.inv ((D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)))"
	+ using A by simp
	+ also have "... = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (\<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g)"
	+ proof -
	+ have "D.iso (D.inv (\<Phi> (trg\<^sub>C g, g))) \<and> D.inv (D.inv (\<Phi> (trg\<^sub>C g, g))) = \<Phi> (trg\<^sub>C g, g)"
	+ using assms \<Phi>_components_are_iso D.iso_inv_iso by simp
	+ moreover have "D.iso (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) \<and>
	+ D.inv (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) = \<Psi> (trg\<^sub>C g) \<star>\<^sub>D F g"
	+ using assms \<Psi>_char D.iso_inv_iso by simp
	+ moreover have "D.seq (D.inv (\<Psi> (trg\<^sub>C g)) \<star>\<^sub>D F g) (D.inv (\<Phi> (trg\<^sub>C g, g)))"
	+ using assms \<Psi>_char by (metis A C.lunit_simps(1) preserves_arr)
	+ ultimately show ?thesis
	+ using D.inv_comp by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ show "F (C.runit' g) = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))"
	+ proof -
	+ have "F (C.runit' g) = D.inv (F \<r>\<^sub>C[g])"
	+ using assms C.iso_runit preserves_inv by simp
	+ also have "... = D.inv ((F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)))"
	+ using B by simp
	+ also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<Psi> (src\<^sub>C g))"
	+ proof -
	+ have "D.iso (D.inv (\<Phi> (g, src\<^sub>C g))) \<and> D.inv (D.inv (\<Phi> (g, src\<^sub>C g))) = \<Phi> (g, src\<^sub>C g)"
	+ using assms \<Phi>_components_are_iso D.iso_inv_iso by simp
	+ moreover have "D.iso (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) \<and>
	+ D.inv (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) = F g \<star>\<^sub>D \<Psi> (src\<^sub>C g)"
	+ using assms \<Psi>_char D.iso_inv_iso by simp
	+ moreover have "D.seq (F g \<star>\<^sub>D D.inv (\<Psi> (src\<^sub>C g))) (D.inv (\<Phi> (g, src\<^sub>C g)))"
	+ using assms \<Psi>_char by (metis B C.runit_simps(1) preserves_arr)
	+ ultimately show ?thesis
	+ using D.inv_comp by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ lemma image_of_associator:
	+ assumes "C.ide f" and "C.ide g" and "C.ide h" and "src\<^sub>C f = trg\<^sub>C g" and "src\<^sub>C g = trg\<^sub>C h"
	+ shows "F \<a>\<^sub>C[f, g, h] = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
	+ and "F (C.\<a>' f g h) = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
	+ proof -
	+ show 1: "F \<a>\<^sub>C[f, g, h] = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
	+ proof -
	+ have 2: "D.seq (\<Phi> (f, g \<star>\<^sub>C h)) ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])"
	+ proof (intro D.seqI)
	+ show "D.arr \<a>\<^sub>D[F f, F g, F h]"
	+ using assms D.assoc_in_hom(2) [of "F f" "F g" "F h"] by auto
	+ show "D.hseq (F f) (\<Phi> (g, h))"
	+ using assms by fastforce
	+ show "D.dom (F f \<star>\<^sub>D \<Phi> (g, h)) = D.cod \<a>\<^sub>D[F f, F g, F h]"
	+ using assms \<open>D.hseq (F f) (\<Phi> (g, h))\<close> by simp
	+ show "D.arr (\<Phi> (f, g \<star>\<^sub>C h))"
	+ using assms by auto
	+ show "D.dom (\<Phi> (f, g \<star>\<^sub>C h)) = D.cod ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])"
	+ using assms \<open>D.hseq (F f) (\<Phi> (g, h))\<close> by simp
	+ qed
	+ moreover have 3: "F \<a>\<^sub>C[f, g, h] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) =
	+ \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
	+ using assms assoc_coherence [of f g h] by blast
	+ moreover have "D.iso (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
	+ proof -
	+ have "D.iso (\<Phi> (f \<star>\<^sub>C g, h)) \<and> D.iso (\<Phi> (f, g)) \<and> D.iso (F h)"
	+ using assms \<Phi>_components_are_iso by simp
	+ moreover have "D.seq (\<Phi> (f \<star>\<^sub>C g, h)) (\<Phi> (f, g) \<star>\<^sub>D F h)"
	+ proof (intro D.seqI)
	+ show "D.hseq (\<Phi> (f, g)) (F h)"
	+ using assms C.VV.arr_char D.hseqI' by simp
	+ show "D.arr (\<Phi> (f \<star>\<^sub>C g, h))"
	+ using assms C.VV.arr_char by simp
	+ show "D.dom (\<Phi> (f \<star>\<^sub>C g, h)) = D.cod (\<Phi> (f, g) \<star>\<^sub>D F h)"
	+ using assms 2 3 by (metis D.seqE)
	+ qed
	+ ultimately show ?thesis
	+ using assms D.isos_compose by simp
	+ qed
	+ ultimately have "F \<a>\<^sub>C[f, g, h] =
	+ (\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
	+ using D.invert_side_of_triangle(2)
	+ [of "\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
	+ "F \<a>\<^sub>C[f, g, h]" "\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)"]
	+ by presburger
	+ also have "... = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
	+ proof -
	+ have "D.inv (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)) =
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
	+ proof -
	+ have "D.iso (\<Phi> (f \<star>\<^sub>C g, h))"
	+ using assms \<Phi>_components_are_iso D.iso_inv_iso by simp
	+ moreover have "D.iso (\<Phi> (f, g) \<star>\<^sub>D F h) \<and>
	+ D.inv (\<Phi> (f, g) \<star>\<^sub>D F h) = D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h"
	+ using assms \<Phi>_components_are_iso D.iso_inv_iso by simp
	+ moreover have "D.seq (\<Phi> (f \<star>\<^sub>C g, h)) (\<Phi> (f, g) \<star>\<^sub>D F h)"
	+ using assms by fastforce
	+ ultimately show ?thesis
	+ using D.inv_comp by simp
	+ qed
	+ moreover have "(F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] = (F f \<star>\<^sub>D \<Phi> (g, h))"
	+ using assms D.comp_arr_dom D.assoc_in_hom [of "F f" "F g" "F h"] \<Phi>_in_hom
	+ by (metis "2" "3" D.comp_arr_ide D.hseq_char D.seqE D.strict_assoc
	+ \<Phi>_simps(2) \<Phi>_simps(3) preserves_ide)
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ finally show ?thesis
	+ by simp
	+ qed
	+ show "F (C.\<a>' f g h) = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
	+ proof -
	+ have "F (C.\<a>' f g h) = D.inv (F \<a>\<^sub>C[f, g, h])"
	+ using assms preserves_inv by simp
	+ also have "... = D.inv (\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h)))"
	+ using 1 by simp
	+ also have "... = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
	+ using assms \<Phi>_components_are_iso C.VV.arr_char D.iso_inv_iso FF_def D.hcomp_assoc
	+ D.comp_assoc
	+ (* OK, this is pretty cool, but not as cool as if I didn't have to direct it. *)
	+ by (simp add: D.inv_comp D.isos_compose D.hseqI')
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+
	+ end
	+
	+ subsection "Internal Equivalences in a Strict Bicategory"
	+
	+ text \<open>
	+ In this section we prove a useful fact about internal equivalences in a strict bicategory:
	+ namely, that if the ``right'' triangle identity holds for such an equivalence then the
	+ ``left'' does, as well. Later we will dualize this property, and use strictification to
	+ extend it to arbitrary bicategories.
	+ \<close>
	+
	+ locale equivalence_in_strict_bicategory =
	+ strict_bicategory +
	+ equivalence_in_bicategory
	+ begin
	+
	+ lemma triangle_right_implies_left:
	+ shows "(g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g \<Longrightarrow> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f"
	+ proof -
	+ text \<open>
	+ The formal proof here was constructed following the string diagram sketch below,
	+ which appears in \cite{nlab-zigzag-diagram}
	+ (see it also in context in \cite{nlab-adjoint-equivalence}).
	+ The diagram is reproduced here by permission of its author, Mike Shulman,
	+ who says (private communication):
	+ ``Just don't give the impression that the proof itself is due to me, because it's not.
	+ I don't know who first gave that proof; it's probably folklore.''
	+ \begin{figure}[h]
	+ \includegraphics[width=6.5in]{triangle_right_implies_left.png}
	+ \end{figure}
	+ \<close>
	+ assume 1: "(g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
	+ have 2: "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) = g"
	+ proof -
	+ have "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) = inv ((g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g))"
	+ using antipar unit_is_iso counit_is_iso inv_comp hcomp_assoc hseqI'
	+ by simp
	+ also have "... = g"
	+ using 1 by simp
	+ finally show ?thesis by blast
	+ qed
	+ have "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = (\<epsilon> \<star> f) \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>)"
	+ proof -
	+ have "(f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>) = f \<star> \<eta>"
	+ using 2 ide_left ide_right antipar whisker_left
	+ by (metis comp_cod_arr unit_simps(1) unit_simps(3))
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (\<epsilon> \<star> f) \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>) \<star> (inv \<eta> \<cdot> \<eta>)"
	+ proof -
	+ have "inv \<eta> \<cdot> \<eta> = src f"
	+ by (simp add: comp_inv_arr')
	+ thus ?thesis
	+ by (metis antipar(1) antipar(2) arrI calculation
	+ comp_ide_arr hcomp_arr_obj ideD(1) ide_left ide_right obj_src seqE
	+ strict_assoc' triangle_in_hom(1) vconn_implies_hpar(1))
	+ qed
	+ also have "... = (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> ((f \<star> inv \<eta>) \<cdot> (f \<star> \<eta>))) \<cdot> (f \<star> \<eta>)"
	+ using ide_left ide_right antipar unit_is_iso
	+ by (metis "2" arr_inv calculation comp_arr_dom comp_inv_arr' counit_simps(1)
	+ counit_simps(2) dom_inv hcomp_arr_obj ideD(1) unit_simps(1) unit_simps(2)
	+ unit_simps(5) obj_trg seqI whisker_left)
	+ also have "... = (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star>
	+ ((f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>))) \<cdot> (f \<star> \<eta>)"
	+ proof -
	+ have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = (f \<star> g) \<star> f"
	+ using whisker_right [of f "inv \<epsilon>" \<epsilon>] counit_in_hom
	+ by (simp add: antipar(1) comp_inv_arr')
	+ thus ?thesis
	+ using hcomp_assoc comp_arr_dom
	+ by (metis comp_cod_arr ide_left local.unit_simps(1) local.unit_simps(3)
	+ whisker_left)
	+ qed
	+ also have "... = (((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<cdot> (f \<star> g)) \<star>
	+ (((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))) \<cdot>
	+ (f \<star> \<eta>)"
	+ using ide_left ide_right antipar counit_is_iso comp_assoc whisker_right comp_cod_arr
	+ by (metis "2" comp_arr_dom counit_simps(1) counit_simps(2))
	+ also have "... = (((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f))) \<cdot>
	+ ((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))) \<cdot>
	+ (f \<star> \<eta>)"
	+ proof -
	+ have 3: "seq (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) (f \<star> g)"
	+ using 2 antipar counit_is_iso by auto
	+ moreover have 4: "seq ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) ((\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))"
	+ using antipar unit_is_iso counit_is_iso hseqI' hcomp_assoc by auto
	+ ultimately show ?thesis
	+ using interchange by simp
	+ qed
	+ also have "... = ((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f))) \<cdot>
	+ ((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>)"
	+ using comp_assoc by simp
	+ also have "... = ((\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
	+ ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> f)) \<cdot>
	+ (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
	+ proof -
	+ have "(\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) =
	+ (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> f)"
	+ proof -
	+ have "seq \<epsilon> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))"
	+ using antipar by (simp add: "2")
	+ moreover have "seq ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) f"
	+ using antipar unit_is_iso counit_is_iso hcomp_assoc hcomp_obj_arr hseqI' by auto
	+ ultimately show ?thesis
	+ using antipar counit_is_iso comp_assoc comp_arr_dom hcomp_obj_arr hseqI'
	+ interchange [of \<epsilon> "f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)" "(f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)" f]
	+ by simp
	+ qed
	+ moreover have "((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>) =
	+ (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
	+ proof -
	+ have "((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>) =
	+ (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> (g \<star> f) \<star> \<eta>) \<cdot> (f \<star> \<eta> \<star> src f)"
	+ using antipar comp_assoc hcomp_assoc whisker_left hcomp_arr_obj hseqI' by simp
	+ also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> ((g \<star> f) \<star> \<eta>) \<cdot> (\<eta> \<cdot> src f))"
	+ using antipar comp_arr_dom whisker_left hcomp_arr_obj hseqI' by simp
	+ also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> \<eta>)"
	+ using antipar comp_arr_dom comp_cod_arr hcomp_arr_obj
	+ interchange [of "g \<star> f" \<eta> \<eta> "src f"]
	+ by simp
	+ also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> g \<star> f) \<cdot> (f \<star> src f \<star> \<eta>)"
	+ using antipar comp_arr_dom comp_cod_arr whisker_left hseqI'
	+ interchange [of \<eta> "src f" "g \<star> f" \<eta>]
	+ by simp
	+ also have "... = ((f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> g \<star> f)) \<cdot> (f \<star> \<eta>)"
	+ using antipar comp_assoc by (simp add: hcomp_obj_arr)
	+ also have "... = (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
	+ using antipar comp_assoc whisker_left whisker_right hcomp_assoc hseqI' by simp
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
	+ ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot>
	+ (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f)) \<cdot> (f \<star> \<eta>)"
	+ using comp_assoc hcomp_assoc antipar(1) antipar(2) by auto
	+ also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
	+ ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<cdot> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f)) \<cdot>
	+ (f \<star> \<eta>)"
	+ using ide_left ide_right antipar comp_cod_arr comp_assoc whisker_left
	+ by (metis "1" "2" comp_ide_self unit_simps(1) unit_simps(3))
	+ also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
	+ proof -
	+ have "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<cdot> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
	+ using ide_left ide_right antipar comp_arr_dom comp_assoc
	+ by (metis "1" "2" comp_ide_self)
	+ thus ?thesis
	+ using antipar comp_cod_arr hseqI' by simp
	+ qed
	+ also have "... = (f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
	+ proof -
	+ have "(\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>) =
	+ (trg f \<cdot> \<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
	+ using hcomp_obj_arr comp_cod_arr by simp
	+ also have "... = ((trg f \<star> f \<star> inv \<eta>) \<cdot> (\<epsilon> \<star> inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
	+ proof -
	+ have "seq (f \<star> inv \<eta>) (inv \<epsilon> \<star> f)"
	+ using antipar unit_is_iso counit_is_iso hseqI' hcomp_arr_obj hcomp_assoc by auto
	+ thus ?thesis
	+ using unit_is_iso counit_is_iso counit_in_hom interchange by auto
	+ qed
	+ also have "... = (f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
	+ proof -
	+ have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = (trg f \<star> inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> trg f \<star> f)"
	+ using counit_is_iso hseqI' by (simp add: hcomp_obj_arr)
	+ also have "... = \<epsilon> \<star> inv \<epsilon> \<star> f"
	+ using antipar counit_is_iso hseqI' comp_arr_dom comp_cod_arr
	+ interchange [of "trg f" \<epsilon> "inv \<epsilon> \<star> f" "trg f \<star> f"]
	+ by force
	+ finally have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = \<epsilon> \<star> inv \<epsilon> \<star> f" by simp
	+ moreover have "trg f \<star> f \<star> inv \<eta> = f \<star> inv \<eta>"
	+ using unit_is_iso hcomp_obj_arr [of "trg f" "f \<star> inv \<eta>"] hseqI'
	+ by (simp add: antipar(1) hseq_char')
	+ ultimately have "((trg f \<star> f \<star> inv \<eta>) \<cdot> (\<epsilon> \<star> inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>) =
	+ ((f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f))) \<cdot> (f \<star> \<eta>)"
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = f \<star> inv \<eta> \<cdot> \<eta>"
	+ proof -
	+ have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = f \<star> g \<star> f"
	+ using ide_left ide_right antipar counit_is_iso whisker_right hcomp_assoc
	+ by (metis comp_arr_dom comp_inv_arr' counit_simps(1) counit_simps(2) seqE)
	+ thus ?thesis
	+ using ide_left ide_right antipar unit_is_iso comp_cod_arr
	+ by (metis arr_inv dom_inv unit_simps(1) unit_simps(3) seqI whisker_left)
	+ qed
	+ also have "... = f \<star> src f"
	+ using antipar unit_is_iso by (simp add: comp_inv_arr')
	+ also have "... = f"
	+ using hcomp_arr_obj by simp
	+ finally show ?thesis by simp
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ Now we use strictification to generalize the preceding result to arbitrary bicategories.
	+ I originally attempted to generalize this proof directly from the strict case, by filling
	+ in the necessary canonical isomorphisms, but it turned out to be too daunting.
	+ The proof using strictification is still fairly tedious, but it is manageable.
	+ \<close>
	+
	+ context equivalence_in_bicategory
	+ begin
	+
	+ interpretation S: strictified_bicategory V H \<a> \<i> src trg ..
	+
	+ notation S.vcomp (infixr "\<cdot>\<^sub>S" 55)
	+ notation S.hcomp (infixr "\<star>\<^sub>S" 53)
	+ notation S.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
	+ notation S.in_hhom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
	+
	+ interpretation UP: equivalence_pseudofunctor V H \<a> \<i> src trg
	+ S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
	+ using S.UP_is_equivalence_pseudofunctor by auto
	+ interpretation UP: pseudofunctor_into_strict_bicategory V H \<a> \<i> src trg
	+ S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.\<Phi>
	+ ..
	+ interpretation E: equivalence_in_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
	+ \<open>S.UP f\<close> \<open>S.UP g\<close>
	+ \<open>S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (src f)\<close>
	+ \<open>S.inv (UP.\<Psi> (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)\<close>
	+ using equivalence_in_bicategory_axioms UP.preserves_equivalence [of f g \<eta> \<epsilon>] by auto
	+ interpretation E: equivalence_in_strict_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
	+ \<open>S.UP f\<close> \<open>S.UP g\<close>
	+ \<open>S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (src f)\<close>
	+ \<open>S.inv (UP.\<Psi> (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)\<close>
	+ ..
	+
	+ lemma UP_triangle:
	+ shows "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
	+ S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
	+ and "S.UP (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) =
	+ (S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.\<Psi> (src g))) \<cdot>\<^sub>S
	+ (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
	+ and "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
	+ S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ and "S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) =
	+ (S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ and "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<Longrightarrow>
	+ S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f)) =
	+ (S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ show T1: "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
	+ S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
	+ proof -
	+ have "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
	+ S.UP (g \<star> \<epsilon>) \<cdot>\<^sub>S S.UP \<a>[g, f, g] \<cdot>\<^sub>S S.UP (\<eta> \<star> g)"
	+ using antipar assoc_in_hom unit_in_hom counit_in_hom hseqI' by simp
	+ also have "... = (S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S ((S.inv (S.\<Phi> (g, f \<star> g)) \<cdot>\<^sub>S
	+ S.\<Phi> (g, f \<star> g)) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.\<Phi> (f, g))) \<cdot>\<^sub>S
	+ (((S.inv (S.\<Phi> (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (S.inv (S.\<Phi> (g \<star> f, g)))) \<cdot>\<^sub>S
	+ S.\<Phi> (g \<star> f, g)) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
	+ proof -
	+ have "S.UP \<a>[g, f, g] =
	+ S.\<Phi> (g, f \<star> g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S (S.inv (S.\<Phi> (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
	+ S.inv (S.\<Phi> (g \<star> f, g))"
	+ using ide_left ide_right antipar UP.image_of_associator [of g f g] by simp
	+ moreover have
	+ "S.UP (g \<star> \<epsilon>) = S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S S.inv (S.\<Phi> (g, f \<star> g))"
	+ proof -
	+ have "S.seq (S.\<Phi> (g, src g)) (S.UP g \<star>\<^sub>S S.UP \<epsilon>)"
	+ using antipar UP.FF_def S.hseqI' UP.\<Phi>_in_hom [of g "src g"]
	+ apply (intro S.seqI) by auto
	+ moreover have
	+ "S.UP (g \<star> \<epsilon>) \<cdot>\<^sub>S S.\<Phi> (g, f \<star> g) = S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>)"
	+ using antipar UP.\<Phi>.naturality [of "(g, \<epsilon>)"] UP.FF_def VV.arr_char by simp
	+ moreover have "S.iso (S.\<Phi> (g, f \<star> g))"
	+ using antipar UP.\<Phi>_components_are_iso by simp
	+ ultimately show ?thesis
	+ using antipar S.comp_assoc
	+ S.invert_side_of_triangle(2)
	+ [of "S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>)" "S.UP (g \<star> \<epsilon>)" "S.\<Phi> (g, f \<star> g)"]
	+ by simp
	+ qed
	+ moreover have "S.UP (\<eta> \<star> g) =
	+ (S.\<Phi> (g \<star> f, g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
	+ proof -
	+ have "S.UP (\<eta> \<star> g) \<cdot>\<^sub>S S.\<Phi> (trg g, g) = S.\<Phi> (g \<star> f, g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)"
	+ using antipar UP.\<Phi>.naturality [of "(\<eta>, g)"] UP.FF_def VV.arr_char by simp
	+ moreover have "S.seq (S.\<Phi> (g \<star> f, g)) (S.UP \<eta> \<star>\<^sub>S S.UP g)"
	+ using antipar UP.\<Phi>_in_hom(2) S.hseqI' by (intro S.seqI, auto)
	+ ultimately show ?thesis
	+ using antipar S.invert_side_of_triangle(2) by simp
	+ qed
	+ ultimately show ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ also have "... = S.\<Phi> (g, src g) \<cdot>\<^sub>S
	+ ((S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.\<Phi> (f, g))) \<cdot>\<^sub>S
	+ ((S.inv (S.\<Phi> (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
	+ S.inv (S.\<Phi> (trg g, g))"
	+ proof -
	+ have "(S.inv (S.\<Phi> (g \<star> f, g)) \<cdot>\<^sub>S S.\<Phi> (g \<star> f, g)) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g) =
	+ (S.UP \<eta> \<star>\<^sub>S S.UP g)"
	+ using antipar S.comp_inv_arr' UP.\<Phi>_in_hom S.comp_cod_arr S.hseqI' by auto
	+ moreover have "(S.inv (S.\<Phi> (g, f \<star> g)) \<cdot>\<^sub>S S.\<Phi> (g, f \<star> g)) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.\<Phi> (f, g)) =
	+ (S.UP g \<star>\<^sub>S S.\<Phi> (f, g))"
	+ proof -
	+ have "S.inv (S.\<Phi> (g, f \<star> g)) \<cdot>\<^sub>S S.\<Phi> (g, f \<star> g) = S.UP g \<star>\<^sub>S S.UP (f \<star> g)"
	+ using antipar S.comp_inv_arr' UP.\<Phi>_in_hom by auto
	+ thus ?thesis
	+ using antipar VV.arr_char S.comp_cod_arr S.hseqI' UP.\<Phi>_in_hom by simp
	+ qed
	+ ultimately show ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ also have "... = S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
	+ using antipar VV.arr_char S.whisker_left S.whisker_right by auto
	+ finally show ?thesis by simp
	+ qed
	+ show T2: "S.UP (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) =
	+ (S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.\<Psi> (src g))) \<cdot>\<^sub>S
	+ (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
	+ using UP.image_of_unitor by simp
	+ show "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
	+ S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
	+ S.UP (\<epsilon> \<star> f) \<cdot>\<^sub>S S.UP \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>S S.UP (f \<star> \<eta>)"
	+ using antipar hseqI' by simp
	+ also have "... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.inv (S.\<Phi> (f \<star> g, f)) \<cdot>\<^sub>S
	+ S.\<Phi> (f \<star> g, f) \<cdot>\<^sub>S (S.\<Phi> (f, g) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.inv (S.\<Phi> (f, g \<star> f)) \<cdot>\<^sub>S
	+ S.\<Phi> (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ have "S.UP \<a>\<^sup>-\<^sup>1[f, g, f] =
	+ S.\<Phi> (f \<star> g, f) \<cdot>\<^sub>S (S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S
	+ S.inv (S.\<Phi> (f, g \<star> f))"
	+ using ide_left ide_right antipar UP.image_of_associator by simp
	+ moreover have "S.UP (\<epsilon> \<star> f) =
	+ S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.inv (S.\<Phi> (f \<star> g, f))"
	+ proof -
	+ have "S.seq (S.\<Phi> (trg f, f)) (S.UP \<epsilon> \<star>\<^sub>S S.UP f)"
	+ using antipar UP.FF_def VV.ide_char VV.arr_char UP.\<Phi>_in_hom [of "trg f" f] S.hseqI'
	+ apply (intro S.seqI) by auto
	+ moreover have
	+ "S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) = S.UP (\<epsilon> \<star> f) \<cdot>\<^sub>S S.\<Phi> (f \<star> g, f)"
	+ using antipar UP.\<Phi>.naturality [of "(\<epsilon>, f)"] UP.FF_def VV.arr_char by simp
	+ moreover have "S.iso (S.\<Phi> (f \<star> g, f))"
	+ using antipar UP.\<Phi>_components_are_iso by simp
	+ ultimately show ?thesis
	+ using antipar S.comp_assoc
	+ S.invert_side_of_triangle(2)
	+ [of "S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f)" "S.UP (\<epsilon> \<star> f)" "S.\<Phi> (f \<star> g, f)"]
	+ by metis
	+ qed
	+ moreover have "S.UP (f \<star> \<eta>) =
	+ (S.\<Phi> (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ have "S.\<Phi> (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>) = S.UP (f \<star> \<eta>) \<cdot>\<^sub>S S.\<Phi> (f, src f)"
	+ using antipar UP.\<Phi>.naturality [of "(f, \<eta>)"] UP.FF_def VV.arr_char by simp
	+ moreover have "S.seq (S.\<Phi> (f, g \<star> f)) (S.UP f \<star>\<^sub>S S.UP \<eta>)"
	+ using antipar S.hseqI' by (intro S.seqI, auto)
	+ ultimately show ?thesis
	+ using antipar S.invert_side_of_triangle(2) by auto
	+ qed
	+ ultimately show ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ also have "... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S
	+ ((S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.\<Phi> (f, g) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
	+ ((S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
	+ S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ have "(S.inv (S.\<Phi> (f \<star> g, f)) \<cdot>\<^sub>S S.\<Phi> (f \<star> g, f)) \<cdot>\<^sub>S (S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) =
	+ (S.\<Phi> (f, g) \<star>\<^sub>S S.UP f)"
	+ using antipar S.comp_cod_arr VV.arr_char S.hseqI' S.comp_inv_arr' by auto
	+ moreover have "(S.inv (S.\<Phi> (f, g \<star> f)) \<cdot>\<^sub>S S.\<Phi> (f, g \<star> f)) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>) =
	+ (S.UP f \<star>\<^sub>S S.UP \<eta>)"
	+ using antipar S.comp_inv_arr' S.comp_cod_arr S.hseqI' by auto
	+ ultimately show ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ also have "... = S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ using antipar VV.arr_char S.whisker_left S.whisker_right by auto
	+ finally show ?thesis by simp
	+ qed
	+ show "S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) =
	+ (S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ using UP.image_of_unitor by simp
	+ show "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<Longrightarrow>
	+ S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f)) =
	+ (S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ assume A: "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ have B: "(S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g) = S.UP g"
	+ proof -
	+ show "(S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g) = S.UP g"
	+ proof -
	+ have 2: "S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g)) =
	+ (S.\<Phi> (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.\<Psi> (src g))) \<cdot>\<^sub>S
	+ (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g))"
	+ using A T1 T2 by simp
	+ show ?thesis
	+ proof -
	+ have 8: "S.seq (S.\<Phi> (g, src g))
	+ ((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
	+ S.inv (S.\<Phi> (trg g, g)))"
	+ using antipar VV.arr_char S.hseqI' S.hcomp_assoc
	+ apply (intro S.seqI) by auto
	+ have 7: "S.seq (S.\<Phi> (g, src g))
	+ ((S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) \<cdot>\<^sub>S (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
	+ S.inv (S.\<Phi> (trg g, g)))"
	+ using antipar 2 8 S.comp_assoc by auto
	+ have 5: "(S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) =
	+ (S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) \<cdot>\<^sub>S (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g)"
	+ proof -
	+ have "((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S
	+ S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.\<Phi> (trg g, g)) =
	+ ((S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) \<cdot>\<^sub>S (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
	+ S.inv (S.\<Phi> (trg g, g))"
	+ proof -
	+ have "S.mono (S.\<Phi> (g, src g))"
	+ using antipar S.iso_is_section S.section_is_mono by simp
	+ thus ?thesis
	+ using 2 8 7 S.monoE S.comp_assoc by presburger
	+ qed
	+ moreover have "S.epi (S.inv (S.\<Phi> (trg g, g)))"
	+ using antipar S.iso_is_retraction S.retraction_is_epi
	+ UP.\<Phi>_components_are_iso S.iso_inv_iso
	+ by simp
	+ moreover have "S.seq ((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S
	+ S.UP \<eta> \<star>\<^sub>S S.UP g))
	+ (S.inv (S.\<Phi> (trg g, g)))"
	+ using S.comp_assoc S.seq_char 8 by presburger
	+ moreover have
	+ "S.seq ((S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) \<cdot>\<^sub>S (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g))
	+ (S.inv (S.\<Phi> (trg g, g)))"
	+ using antipar calculation(1) calculation(3) by presburger
	+ ultimately show ?thesis
	+ using 2 S.epiE by blast
	+ qed
	+ have 6: "S.seq (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g))
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
	+ using antipar VV.arr_char S.hseqI' S.hcomp_assoc by auto
	+ have 3: "(S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g))) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) =
	+ (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g)"
	+ proof -
	+ have "S.seq (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g))
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
	+ using 6 by simp
	+ moreover have "(S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) \<cdot>\<^sub>S (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) =
	+ (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
	+ using 5 by argo
	+ moreover have "S.iso (S.UP g \<star>\<^sub>S UP.\<Psi> (src g))"
	+ using antipar UP.\<Psi>_char S.UP_map\<^sub>0_obj by simp
	+ moreover have "S.inv (S.UP g \<star>\<^sub>S UP.\<Psi> (src g)) =
	+ S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g))"
	+ using antipar UP.\<Psi>_char S.UP_map\<^sub>0_obj by simp
	+ ultimately show ?thesis
	+ using S.invert_side_of_triangle(1)
	+ [of "(S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g)) \<cdot>\<^sub>S
	+ (S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
	+ "S.UP g \<star>\<^sub>S UP.\<Psi> (src g)" "S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g"]
	+ by presburger
	+ qed
	+ have 4: "(((S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g))) \<cdot>\<^sub>S
	+ (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g))) \<cdot>\<^sub>S
	+ ((S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S (UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g))
	+ = S.UP g"
	+ proof -
	+ have "(((S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g))) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g))) \<cdot>\<^sub>S
	+ ((S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S (UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g)) =
	+ (((S.UP g \<star>\<^sub>S S.inv (UP.\<Psi> (src g))) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g))) \<cdot>\<^sub>S
	+ ((S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g))) \<cdot>\<^sub>S (UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g)"
	+ using S.comp_assoc by simp
	+ also have "... = (S.inv (UP.\<Psi> (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g)"
	+ using 3 S.comp_assoc by auto
	+ also have "... = S.inv (UP.\<Psi> (trg g)) \<cdot>\<^sub>S UP.\<Psi> (trg g) \<star>\<^sub>S S.UP g"
	+ using UP.\<Psi>_char(2) S.whisker_right by auto
	+ also have "... = UP.map\<^sub>0 (trg g) \<star>\<^sub>S S.UP g"
	+ using UP.\<Psi>_char [of "trg g"] S.comp_inv_arr S.inv_is_inverse by simp
	+ also have "... = S.UP g"
	+ using S.UP_map\<^sub>0_obj by (simp add: S.hcomp_obj_arr)
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using antipar S.whisker_left S.whisker_right UP.\<Psi>_char S.comp_assoc by simp
	+ qed
	+ qed
	+ qed
	+ show "S.\<Phi> (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f)) =
	+ (S.\<Phi> (trg f, f) \<cdot>\<^sub>S (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ proof -
	+ have "(S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) =
	+ (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))"
	+ proof -
	+ have 2: "(S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ ((S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) =
	+ S.UP f"
	+ proof -
	+ have "S.UP f = (S.inv (UP.\<Psi> (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (src f))"
	+ using B antipar E.triangle_right_implies_left by argo
	+ also have "... = (S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ ((S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"
	+ proof -
	+ have "S.inv (UP.\<Psi> (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f =
	+ (S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f)"
	+ using UP.\<Phi>_components_are_iso UP.\<Psi>_char S.whisker_right by simp
	+ moreover have "S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.\<Psi> (src f) =
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"
	+ using antipar UP.\<Phi>_components_are_iso UP.\<Psi>_char S.whisker_left S.comp_assoc
	+ by simp
	+ ultimately show ?thesis
	+ using S.comp_assoc by presburger
	+ qed
	+ finally show ?thesis by argo
	+ qed
	+ show ?thesis
	+ proof -
	+ have "((S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) =
	+ (UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f)"
	+ proof -
	+ have "S.inv (S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.UP f = UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f"
	+ using UP.\<Psi>_char S.iso_inv_iso S.comp_arr_dom S.UP_map\<^sub>0_obj
	+ by (simp add: S.hcomp_obj_arr S.hseqI')
	+ moreover have "S.arr (S.UP f)"
	+ by simp
	+ moreover have "S.iso (S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f)"
	+ using UP.\<Phi>_components_are_iso S.iso_inv_iso S.UP_map\<^sub>0_obj
	+ by (simp add: UP.\<Psi>_char(2))
	+ ultimately show ?thesis
	+ using 2 S.invert_side_of_triangle(1)
	+ [of "S.UP f" "S.inv (UP.\<Psi> (trg f)) \<star>\<^sub>S S.UP f"
	+ "((S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S UP.\<Psi> (src f))"]
	+ by presburger
	+ qed
	+ moreover have "S.hseq (UP.\<Psi> (trg f)) (S.UP f) \<and>
	+ S.iso (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) \<and>
	+ S.inv (S.UP f \<star>\<^sub>S UP.\<Psi> (src f)) = S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f))"
	+ using UP.\<Psi>_char S.hseqI' S.UP_map\<^sub>0_obj by simp
	+ ultimately show ?thesis
	+ using S.invert_side_of_triangle(2)
	+ [of "UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f"
	+ "(S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)"
	+ "S.UP f \<star>\<^sub>S UP.\<Psi> (src f)"]
	+ by presburger
	+ qed
	+ qed
	+ hence "S.\<Phi> (trg f, f) \<cdot>\<^sub>S ((S.UP \<epsilon> \<cdot>\<^sub>S S.\<Phi> (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (S.\<Phi> (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f)) =
	+ S.\<Phi> (trg f, f) \<cdot>\<^sub>S ((UP.\<Psi> (trg f) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
	+ (S.UP f \<star>\<^sub>S S.inv (UP.\<Psi> (src f)))) \<cdot>\<^sub>S S.inv (S.\<Phi> (f, src f))"
	+ by simp
	+ thus ?thesis
	+ using S.comp_assoc by simp
	+ qed
	+ qed
	+ qed
	+
	+ lemma triangle_right_implies_left:
	+ assumes "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ proof -
	+ have "par ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
	+ using antipar hseqI' by simp
	+ moreover have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) = S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
	+ using assms UP_triangle(3-5) by simp
	+ ultimately show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ using UP.is_faithful by blast
	+ qed
	+
	+ text \<open>
	+ We \emph{really} don't want to go through the ordeal of proving a dual version of
	+ \<open>UP_triangle(5)\<close>, do we? So let's be smart and dualize via the opposite bicategory.
	+ \<close>
	+
	+ lemma triangle_left_implies_right:
	+ assumes "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ shows "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ proof -
	+ interpret Cop: op_bicategory V H \<a> \<i> src trg ..
	+ interpret Eop: equivalence_in_bicategory V Cop.H Cop.\<a> \<i> Cop.src Cop.trg g f \<eta> \<epsilon>
	+ using antipar unit_is_iso counit_is_iso unit_in_hom counit_in_hom iso_inv_iso
	+ by (unfold_locales, simp_all)
	+ have "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<Longrightarrow>
	+ (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ using antipar Cop.lunit_ide_simp Cop.runit_ide_simp Cop.assoc_ide_simp
	+ VVV.ide_char VVV.arr_char VV.arr_char Eop.triangle_right_implies_left
	+ by simp
	+ thus ?thesis
	+ using assms by simp
	+ qed
	+
	+ lemma triangle_left_iff_right:
	+ shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<longleftrightarrow>
	+ (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ using triangle_left_implies_right triangle_right_implies_left by auto
	+
	+ end
	+
	+ text \<open>
	+ We might as well specialize the dual result back to the strict case while we are at it.
	+ \<close>
	+
	+ context equivalence_in_strict_bicategory
	+ begin
	+
	+ lemma triangle_left_iff_right:
	+ shows "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
	+ proof -
	+ have "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f \<longleftrightarrow> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ proof -
	+ have "\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] = f"
	+ using strict_lunit strict_runit by simp
	+ moreover have "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)"
	+ using antipar strict_assoc assoc'_in_hom(2) [of f g f] comp_cod_arr hseqI'
	+ by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
	+ using triangle_left_iff_right by blast
	+ also have "... \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
	+ proof -
	+ have "\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] = g"
	+ using strict_lunit strict_runit by simp
	+ moreover have "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g)"
	+ using antipar strict_assoc assoc_in_hom(2) [of g f g] comp_cod_arr hseqI'
	+ by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ end
	+
	+end
	diff --git a/thys/Bicategory/Subbicategory.thy b/thys/Bicategory/Subbicategory.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/Subbicategory.thy
	@@ -0,0 +1,1357 @@
	+(* Title: Subbicategory
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Sub-Bicategories"
	+
	+text \<open>
	+ In this section we give a construction of a sub-bicategory in terms of a predicate
	+ on the arrows of an ambient bicategory that has certain closure properties with respect
	+ to that bicategory. While the construction given here is likely to be of general use,
	+ it is not the most general sub-bicategory construction that one could imagine,
	+ because it requires that the sub-bicategory actually contain the unit and associativity
	+ isomorphisms of the ambient bicategory. Our main motivation for including this construction
	+ here is to apply it to exploit the fact that the sub-bicategory of endo-arrows of a fixed
	+ object is a monoidal category, which will enable us to transfer to bicategories a result
	+ about unit isomorphisms in monoidal categories.
	+\<close>
	+
	+theory Subbicategory
	+imports Bicategory
	+begin
	+
	+ subsection "Construction"
	+
	+ locale subbicategory =
	+ B: bicategory V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B +
	+ subcategory V Arr
	+ for V :: "'a comp" (infixr "\<cdot>\<^sub>B" 55)
	+ and H :: "'a comp" (infixr "\<star>\<^sub>B" 55)
	+ and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>\<^sub>B[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src\<^sub>B :: "'a \<Rightarrow> 'a"
	+ and trg\<^sub>B :: "'a \<Rightarrow> 'a"
	+ and Arr :: "'a \<Rightarrow> bool" +
	+ assumes src_closed: "Arr f \<Longrightarrow> Arr (src\<^sub>B f)"
	+ and trg_closed: "Arr f \<Longrightarrow> Arr (trg\<^sub>B f)"
	+ and hcomp_closed: "\<lbrakk> Arr f; Arr g; trg\<^sub>B f = src\<^sub>B g \<rbrakk> \<Longrightarrow> Arr (g \<star>\<^sub>B f)"
	+ and assoc_closed: "\<lbrakk> Arr f \<and> B.ide f; Arr g \<and> B.ide g; Arr h \<and> B.ide h;
	+ src\<^sub>B f = trg\<^sub>B g; src\<^sub>B g = trg\<^sub>B h \<rbrakk> \<Longrightarrow> Arr (\<a>\<^sub>B f g h)"
	+ and assoc'_closed: "\<lbrakk> Arr f \<and> B.ide f; Arr g \<and> B.ide g; Arr h \<and> B.ide h;
	+ src\<^sub>B f = trg\<^sub>B g; src\<^sub>B g = trg\<^sub>B h \<rbrakk> \<Longrightarrow> Arr (B.inv (\<a>\<^sub>B f g h))"
	+ and lunit_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.\<ll> f)"
	+ and lunit'_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.inv (B.\<ll> f))"
	+ and runit_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.\<rr> f)"
	+ and runit'_closed: "\<lbrakk> Arr f; B.ide f \<rbrakk> \<Longrightarrow> Arr (B.inv (B.\<rr> f))"
	+ begin
	+
	+ notation B.in_hom ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>B _\<guillemotright>")
	+
	+ notation comp (infixr "\<cdot>" 55)
	+
	+ definition hcomp (infixr "\<star>" 53)
	+ where "g \<star> f = (if Arr f \<and> Arr g \<and> trg\<^sub>B f = src\<^sub>B g then g \<star>\<^sub>B f else null)"
	+
	+ definition src
	+ where "src \<mu> = (if Arr \<mu> then src\<^sub>B \<mu> else null)"
	+
	+ definition trg
	+ where "trg \<mu> = (if Arr \<mu> then trg\<^sub>B \<mu> else null)"
	+
	+ interpretation src: endofunctor \<open>(\<cdot>)\<close> src
	+ using src_def null_char inclusion arr_char src_closed trg_closed dom_closed cod_closed
	+ apply unfold_locales
	+ apply auto[4]
	+ by (metis B.src.preserves_comp_2 comp_char seq_char)
	+
	+ interpretation trg: endofunctor \<open>(\<cdot>)\<close> trg
	+ using trg_def null_char inclusion arr_char src_closed trg_closed dom_closed cod_closed
	+ apply unfold_locales
	+ apply auto[4]
	+ by (metis B.trg.preserves_comp_2 comp_char seq_char)
	+
	+ interpretation horizontal_homs \<open>(\<cdot>)\<close> src trg
	+ using src_def trg_def src.preserves_arr trg.preserves_arr null_char ide_char arr_char
	+ inclusion
	+ by (unfold_locales, simp_all)
	+
	+ interpretation VxV: product_category \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> ..
	+ interpretation VV: subcategory VxV.comp
	+ \<open>\<lambda>\<mu>\<nu>. arr (fst \<mu>\<nu>) \<and> arr (snd \<mu>\<nu>) \<and> src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)\<close>
	+ using subcategory_VV by auto
	+
	+ interpretation "functor" VV.comp \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
	+ using hcomp_def VV.arr_char src_def trg_def arr_char hcomp_closed dom_char cod_char
	+ VV.dom_char VV.cod_char
	+ apply unfold_locales
	+ apply auto[2]
	+ proof -
	+ fix f
	+ assume f: "VV.arr f"
	+ show "dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
	+ proof -
	+ have "dom (fst f \<star> snd f) = B.dom (fst f) \<star>\<^sub>B B.dom (snd f)"
	+ proof -
	+ have "dom (fst f \<star> snd f) = B.dom (fst f \<star> snd f)"
	+ using f dom_char
	+ by (simp add: arrI hcomp_closed hcomp_def)
	+ also have "... = B.dom (fst f) \<star>\<^sub>B B.dom (snd f)"
	+ using f
	+ by (metis (no_types, lifting) B.hcomp_simps(3) B.hseqI' VV.arrE arrE hcomp_def
	+ inclusion src_def trg_def)
	+ finally show ?thesis by blast
	+ qed
	+ also have "... = fst (VV.dom f) \<star> snd (VV.dom f)"
	+ using f VV.arr_char VV.dom_char arr_char hcomp_def B.seq_if_composable dom_closed
	+ by (simp, metis)
	+ finally show ?thesis by simp
	+ qed
	+ show "cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
	+ proof -
	+ have "cod (fst f \<star> snd f) = B.cod (fst f) \<star>\<^sub>B B.cod (snd f)"
	+ using f VV.arr_char arr_char cod_char hcomp_def src_def trg_def
	+ src_closed trg_closed hcomp_closed inclusion B.hseq_char arrE
	+ by auto
	+ also have "... = fst (VV.cod f) \<star> snd (VV.cod f)"
	+ using f VV.arr_char VV.cod_char arr_char hcomp_def B.seq_if_composable cod_closed
	+ by (simp, metis)
	+ finally show ?thesis by simp
	+ qed
	+ next
	+ fix f g
	+ assume fg: "VV.seq g f"
	+ show "fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
	+ proof -
	+ have "fst (VV.comp g f) \<star> snd (VV.comp g f) = fst g \<cdot> fst f \<star> snd g \<cdot> snd f"
	+ using fg VV.seq_char VV.comp_char VxV.comp_char VxV.not_Arr_Null
	+ by (metis (no_types, lifting) VxV.seqE prod.sel(1) prod.sel(2))
	+ also have "... = (fst g \<cdot>\<^sub>B fst f) \<star>\<^sub>B (snd g \<cdot>\<^sub>B snd f)"
	+ using fg comp_char hcomp_def VV.seq_char inclusion arr_char seq_char B.hseq_char
	+ by (metis (no_types, lifting) B.hseq_char' VxV.seq_char null_char)
	+ also have 1: "... = (fst g \<star>\<^sub>B snd g) \<cdot>\<^sub>B (fst f \<star>\<^sub>B snd f)"
	+ proof -
	+ have "src\<^sub>B (fst g) = trg\<^sub>B (snd g)"
	+ by (metis (no_types, lifting) VV.arrE VV.seq_char arr_char fg src_def trg_def)
	+ thus ?thesis
	+ using fg VV.seq_char VV.arr_char arr_char seq_char inclusion B.interchange
	+ by (meson VxV.seqE)
	+ qed
	+ also have "... = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
	+ using fg comp_char hcomp_def VV.seq_char VV.arr_char arr_char seq_char inclusion
	+ B.hseq_char' hcomp_closed src_def trg_def
	+ by (metis (no_types, lifting) 1)
	+ finally show ?thesis by auto
	+ qed
	+ qed
	+
	+ interpretation horizontal_composition \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> src trg
	+ using arr_char src_def trg_def src_closed trg_closed
	+ apply (unfold_locales)
	+ using hcomp_def inclusion not_arr_null by auto
	+
	+ interpretation VxVxV: product_category \<open>(\<cdot>)\<close> VxV.comp ..
	+ interpretation VVV: subcategory VxVxV.comp
	+ \<open>\<lambda>\<tau>\<mu>\<nu>. arr (fst \<tau>\<mu>\<nu>) \<and> VV.arr (snd \<tau>\<mu>\<nu>) \<and>
	+ src (fst \<tau>\<mu>\<nu>) = trg (fst (snd \<tau>\<mu>\<nu>))\<close>
	+ using subcategory_VVV by auto
	+
	+ interpretation HoHV: "functor" VVV.comp \<open>(\<cdot>)\<close> HoHV
	+ using functor_HoHV by auto
	+ interpretation HoVH: "functor" VVV.comp \<open>(\<cdot>)\<close> HoVH
	+ using functor_HoVH by auto
	+
	+ abbreviation \<a>
	+ where "\<a> \<mu> \<nu> \<tau> \<equiv> if VVV.arr (\<mu>, \<nu>, \<tau>) then \<a>\<^sub>B \<mu> \<nu> \<tau> else null"
	+
	+ abbreviation (input) \<alpha>\<^sub>S\<^sub>B
	+ where "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> \<equiv> \<a> (fst \<mu>\<nu>\<tau>) (fst (snd \<mu>\<nu>\<tau>)) (snd (snd \<mu>\<nu>\<tau>))"
	+
	+ lemma assoc_closed':
	+ assumes "VVV.arr \<mu>\<nu>\<tau>"
	+ shows "Arr (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>)"
	+ proof -
	+ have 1: "B.VVV.arr \<mu>\<nu>\<tau>"
	+ using assms VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char arr_char
	+ src_def trg_def inclusion
	+ by auto
	+ show "Arr (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>)"
	+ proof -
	+ have "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> =
	+ (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>)) \<cdot>\<^sub>B \<alpha>\<^sub>S\<^sub>B (B.VVV.dom \<mu>\<nu>\<tau>)"
	+ using assms B.\<alpha>_def 1 B.VVV.arr_char B.VV.arr_char B.VVV.dom_char B.VV.dom_char
	+ B.assoc_is_natural_1 [of "fst \<mu>\<nu>\<tau>" "fst (snd \<mu>\<nu>\<tau>)" "snd (snd \<mu>\<nu>\<tau>)"]
	+ VV.arr_char VVV.arr_char arr_dom src_dom trg_dom
	+ by auto
	+ moreover have "Arr (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>))"
	+ using assms 1 B.VVV.arr_char B.VV.arr_char hcomp_closed
	+ by (metis (no_types, lifting) B.H.preserves_arr B.hcomp_simps(2)
	+ VV.arr_char VVV.arrE arrE)
	+ moreover have "Arr (\<alpha>\<^sub>S\<^sub>B (B.VVV.dom \<mu>\<nu>\<tau>))"
	+ proof -
	+ have "\<alpha>\<^sub>S\<^sub>B (B.VVV.dom \<mu>\<nu>\<tau>) =
	+ \<a>\<^sub>B (B.dom (fst \<mu>\<nu>\<tau>)) (B.dom (fst (snd \<mu>\<nu>\<tau>))) (B.dom (snd (snd \<mu>\<nu>\<tau>)))"
	+ using assms 1 B.\<alpha>_def B.VVV.dom_char B.VV.dom_char VVV.arr_char VV.arr_char
	+ B.VxVxV.dom_char inclusion
	+ apply simp
	+ by (metis (no_types, lifting) B.hseqE arr_dom calculation(2) dom_char src_dom trg_dom)
	+ moreover have "Arr (\<a>\<^sub>B (B.dom (fst \<mu>\<nu>\<tau>)) (B.dom (fst (snd \<mu>\<nu>\<tau>)))
	+ (B.dom (snd (snd \<mu>\<nu>\<tau>))))"
	+ proof -
	+ have "B.VVV.ide (B.VVV.dom \<mu>\<nu>\<tau>)"
	+ using 1 B.VVV.ide_dom by blast
	+ thus ?thesis
	+ using assms B.\<alpha>_def B.VVV.arr_char B.VV.arr_char B.VVV.ide_char B.VV.ide_char
	+ dom_closed assoc_closed
	+ by (metis (no_types, lifting) "1" B.ide_dom B.src_dom B.trg_dom VV.arr_char VVV.arrE
	+ arr_char)
	+ qed
	+ ultimately show ?thesis by argo
	+ qed
	+ moreover have "B.seq (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>))
	+ (\<alpha>\<^sub>S\<^sub>B (B.VVV.dom \<mu>\<nu>\<tau>))"
	+ using assms 1 VVV.arr_char VV.arr_char B.VxVxV.dom_char
	+ apply simp
	+ by (metis (no_types, lifting) B.VV.arrE B.VVV.arrE B.assoc_is_natural_1
	+ B.\<alpha>.preserves_reflects_arr arr_dom dom_simp src_dom trg_dom)
	+ ultimately show ?thesis
	+ using comp_closed by auto
	+ qed
	+ qed
	+
	+ lemma lunit_closed':
	+ assumes "Arr f"
	+ shows "Arr (B.\<ll> f)"
	+ proof -
	+ have 1: "arr f \<and> arr (B.\<ll> (B.dom f))"
	+ using assms arr_char lunit_closed dom_closed B.ide_dom inclusion by simp
	+ moreover have "B.dom f = B.cod (B.\<ll> (B.dom f))"
	+ using 1 arr_char B.\<ll>.preserves_cod inclusion by simp
	+ moreover have "B.\<ll> f = f \<cdot> B.\<ll> (B.dom f)"
	+ using assms 1 B.\<ll>.is_natural_1 inclusion comp_char arr_char by simp
	+ ultimately show ?thesis
	+ using arr_char comp_closed cod_char seqI by auto
	+ qed
	+
	+ lemma runit_closed':
	+ assumes "Arr f"
	+ shows "Arr (B.\<rr> f)"
	+ proof -
	+ have 1: "arr f \<and> arr (B.\<rr> (B.dom f))"
	+ using assms arr_char runit_closed dom_closed B.ide_dom inclusion
	+ by simp
	+ moreover have "B.dom f = B.cod (B.\<rr> (B.dom f))"
	+ using 1 arr_char B.\<ll>.preserves_cod inclusion by simp
	+ moreover have "B.\<rr> f = f \<cdot> B.\<rr> (B.dom f)"
	+ using assms 1 B.\<rr>.is_natural_1 inclusion comp_char arr_char by simp
	+ ultimately show ?thesis
	+ using arr_char comp_closed cod_char seqI by auto
	+ qed
	+
	+ interpretation natural_isomorphism VVV.comp \<open>(\<cdot>)\<close> HoHV HoVH \<alpha>\<^sub>S\<^sub>B
	+ proof
	+ fix \<mu>\<nu>\<tau>
	+ show "\<not> VVV.arr \<mu>\<nu>\<tau> \<Longrightarrow> \<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> = null"
	+ by simp
	+ assume \<mu>\<nu>\<tau>: "VVV.arr \<mu>\<nu>\<tau>"
	+ have 1: "B.VVV.arr \<mu>\<nu>\<tau>"
	+ using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char arr_char
	+ src_def trg_def inclusion
	+ by auto
	+ show "dom (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = HoHV (VVV.dom \<mu>\<nu>\<tau>)"
	+ proof -
	+ have "dom (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = B.HoHV (B.VVV.dom \<mu>\<nu>\<tau>)"
	+ using \<mu>\<nu>\<tau> 1 arr_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
	+ B.\<alpha>_def assoc_closed'
	+ by simp
	+ also have "... = HoHV (VVV.dom \<mu>\<nu>\<tau>)"
	+ proof -
	+ have "HoHV (VVV.dom \<mu>\<nu>\<tau>) = HoHV (VxVxV.dom \<mu>\<nu>\<tau>)"
	+ using \<mu>\<nu>\<tau> VVV.dom_char VV.arr_char src_def trg_def VVV.arr_char
	+ by simp
	+ also have "... = B.HoHV (B.VVV.dom \<mu>\<nu>\<tau>)"
	+ using \<mu>\<nu>\<tau> VVV.dom_char VVV.arr_char VV.arr_char src_def trg_def
	+ HoHV_def B.HoHV_def arr_char B.VVV.arr_char B.VVV.dom_char B.VV.arr_char
	+ dom_closed hcomp_closed hcomp_def inclusion
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ show "cod (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = HoVH (VVV.cod \<mu>\<nu>\<tau>)"
	+ proof -
	+ have "cod (\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>) = B.HoVH (B.VVV.cod \<mu>\<nu>\<tau>)"
	+ using \<mu>\<nu>\<tau> 1 arr_char VVV.arr_char VV.arr_char B.VVV.arr_char B.VV.arr_char
	+ B.\<alpha>_def assoc_closed'
	+ by simp
	+ also have "... = HoVH (VVV.cod \<mu>\<nu>\<tau>)"
	+ proof -
	+ have "HoVH (VVV.cod \<mu>\<nu>\<tau>) = HoVH (VxVxV.cod \<mu>\<nu>\<tau>)"
	+ using \<mu>\<nu>\<tau> VVV.cod_char VV.arr_char src_def trg_def VVV.arr_char
	+ by simp
	+ also have "... = B.HoVH (B.VVV.cod \<mu>\<nu>\<tau>)"
	+ using \<mu>\<nu>\<tau> VVV.cod_char VV.arr_char src_def trg_def VVV.arr_char
	+ HoVH_def B.HoVH_def arr_char B.VVV.arr_char B.VVV.cod_char B.VV.arr_char
	+ cod_closed hcomp_closed hcomp_def inclusion
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ have 3: "Arr (fst \<mu>\<nu>\<tau>) \<and> Arr (fst (snd \<mu>\<nu>\<tau>)) \<and> Arr (snd (snd \<mu>\<nu>\<tau>)) \<and>
	+ src\<^sub>B (fst \<mu>\<nu>\<tau>) = trg\<^sub>B (fst (snd \<mu>\<nu>\<tau>)) \<and>
	+ src\<^sub>B (fst (snd \<mu>\<nu>\<tau>)) = trg\<^sub>B (snd (snd \<mu>\<nu>\<tau>))"
	+ using \<mu>\<nu>\<tau> VVV.arr_char VV.arr_char src_def trg_def arr_char by auto
	+ show "HoVH \<mu>\<nu>\<tau> \<cdot> \<alpha>\<^sub>S\<^sub>B (VVV.dom \<mu>\<nu>\<tau>) = \<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>"
	+ proof -
	+ have "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> = (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>)) \<cdot>\<^sub>B
	+ \<a>\<^sub>B (B.dom (fst \<mu>\<nu>\<tau>)) (B.dom (fst (snd \<mu>\<nu>\<tau>))) (B.dom (snd (snd \<mu>\<nu>\<tau>)))"
	+ using 3 inclusion B.assoc_is_natural_1 [of "fst \<mu>\<nu>\<tau>" "fst (snd \<mu>\<nu>\<tau>)" "snd (snd \<mu>\<nu>\<tau>)"]
	+ by (simp add: \<mu>\<nu>\<tau>)
	+ also have "... = (fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>) \<star> snd (snd \<mu>\<nu>\<tau>)) \<cdot>
	+ \<a>\<^sub>B (dom (fst \<mu>\<nu>\<tau>)) (dom (fst (snd \<mu>\<nu>\<tau>))) (dom (snd (snd \<mu>\<nu>\<tau>)))"
	+ using 1 3 \<mu>\<nu>\<tau> hcomp_closed assoc_closed dom_closed hcomp_def comp_def inclusion
	+ comp_char dom_char VVV.arr_char VV.arr_char
	+ apply simp
	+ using B.hcomp_simps(2-3) by presburger
	+ also have "... = HoVH \<mu>\<nu>\<tau> \<cdot> \<alpha>\<^sub>S\<^sub>B (VVV.dom \<mu>\<nu>\<tau>)"
	+ using \<mu>\<nu>\<tau> B.\<alpha>_def HoVH_def VVV.dom_char VV.dom_char VxVxV.dom_char
	+ apply simp
	+ by (metis (no_types, lifting) VV.arr_char VVV.arrE VVV.arr_dom VxV.dom_char
	+ dom_simp)
	+ finally show ?thesis by argo
	+ qed
	+ show "\<alpha>\<^sub>S\<^sub>B (VVV.cod \<mu>\<nu>\<tau>) \<cdot> HoHV \<mu>\<nu>\<tau> = \<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau>"
	+ proof -
	+ have "\<alpha>\<^sub>S\<^sub>B \<mu>\<nu>\<tau> =
	+ \<a>\<^sub>B (B.cod (fst \<mu>\<nu>\<tau>)) (B.cod (fst (snd \<mu>\<nu>\<tau>))) (B.cod (snd (snd \<mu>\<nu>\<tau>))) \<cdot>\<^sub>B
	+ (fst \<mu>\<nu>\<tau> \<star>\<^sub>B fst (snd \<mu>\<nu>\<tau>)) \<star>\<^sub>B snd (snd \<mu>\<nu>\<tau>)"
	+ using 3 inclusion B.assoc_is_natural_2 [of "fst \<mu>\<nu>\<tau>" "fst (snd \<mu>\<nu>\<tau>)" "snd (snd \<mu>\<nu>\<tau>)"]
	+ by (simp add: \<mu>\<nu>\<tau>)
	+ also have "... = \<a>\<^sub>B (cod (fst \<mu>\<nu>\<tau>)) (cod (fst (snd \<mu>\<nu>\<tau>))) (cod (snd (snd \<mu>\<nu>\<tau>))) \<cdot>
	+ ((fst \<mu>\<nu>\<tau> \<star> fst (snd \<mu>\<nu>\<tau>)) \<star> snd (snd \<mu>\<nu>\<tau>)) "
	+ using 1 3 \<mu>\<nu>\<tau> hcomp_closed assoc_closed cod_closed hcomp_def comp_def inclusion
	+ comp_char cod_char VVV.arr_char VV.arr_char
	+ by simp
	+ also have "... = \<alpha>\<^sub>S\<^sub>B (VVV.cod \<mu>\<nu>\<tau>) \<cdot> HoHV \<mu>\<nu>\<tau>"
	+ using \<mu>\<nu>\<tau> B.\<alpha>_def HoHV_def VVV.cod_char VV.cod_char VxVxV.cod_char
	+ VVV.arr_char VV.arr_char arr_cod src_cod trg_cod
	+ by simp
	+ finally show ?thesis by argo
	+ qed
	+ next
	+ fix fgh
	+ assume fgh: "VVV.ide fgh"
	+ show "iso (\<alpha>\<^sub>S\<^sub>B fgh)"
	+ proof -
	+ have 1: "B.arr (fst (snd fgh)) \<and> B.arr (snd (snd fgh)) \<and>
	+ src\<^sub>B (fst (snd fgh)) = trg\<^sub>B (snd (snd fgh)) \<and>
	+ src\<^sub>B (fst fgh) = trg\<^sub>B (fst (snd fgh))"
	+ using fgh VVV.ide_char VVV.arr_char VV.arr_char src_def trg_def
	+ arr_char inclusion
	+ by auto
	+ have 2: "B.ide (fst fgh) \<and> B.ide (fst (snd fgh)) \<and> B.ide (snd (snd fgh))"
	+ using fgh VVV.ide_char ide_char by blast
	+ have "\<alpha>\<^sub>S\<^sub>B fgh = \<a>\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))"
	+ using fgh B.\<alpha>_def by simp
	+ moreover have "B.VVV.ide fgh"
	+ using fgh 1 2 VVV.ide_char B.VVV.ide_char VVV.arr_char B.VVV.arr_char
	+ src_def trg_def inclusion arr_char B.VV.arr_char
	+ by simp
	+ moreover have "Arr (\<a>\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh)))"
	+ using fgh 1 VVV.ide_char VVV.arr_char VV.arr_char src_def trg_def
	+ arr_char assoc_closed' B.\<alpha>_def
	+ by simp
	+ moreover have "Arr (B.inv (\<a>\<^sub>B (fst fgh) (fst (snd fgh)) (snd (snd fgh))))"
	+ using fgh 1 VVV.ide_char VVV.arr_char VV.arr_char src_def trg_def
	+ arr_char assoc'_closed
	+ by (simp add: VVV.arr_char "2" B.VVV.ide_char calculation(2))
	+ ultimately show ?thesis
	+ using fgh iso_char B.\<alpha>.components_are_iso by auto
	+ qed
	+ qed
	+
	+ interpretation L: endofunctor \<open>(\<cdot>)\<close> L
	+ using endofunctor_L by auto
	+ interpretation R: endofunctor \<open>(\<cdot>)\<close> R
	+ using endofunctor_R by auto
	+
	+ interpretation L: faithful_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> L
	+ proof
	+ fix f f'
	+ assume par: "par f f'"
	+ assume eq: "L f = L f'"
	+ have "B.par f f'"
	+ using par inclusion arr_char by fastforce
	+ moreover have "B.L f = B.L f'"
	+ proof -
	+ have "\<forall>a. Arr a \<longrightarrow> B.arr a"
	+ by (simp add: inclusion)
	+ moreover have 1: "\<forall>a. arr a \<longrightarrow> (if arr a then hseq (trg a) a else arr null)"
	+ using L.preserves_arr by presburger
	+ moreover have "Arr f \<and> Arr (trg f) \<and> trg\<^sub>B f = src\<^sub>B (trg f)"
	+ by (meson 1 hcomp_def hseq_char' par)
	+ ultimately show ?thesis
	+ by (metis (no_types) eq hcomp_def hseq_char' par trg_def)
	+ qed
	+ ultimately show "f = f'"
	+ using B.L.is_faithful by blast
	+ qed
	+ interpretation L: full_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> L
	+ proof
	+ fix f f' \<nu>
	+ assume f: "ide f" and f': "ide f'" and \<nu>: "\<guillemotleft>\<nu> : L f \<Rightarrow> L f'\<guillemotright>"
	+ have 1: "L f = trg\<^sub>B f \<star>\<^sub>B f \<and> L f' = trg\<^sub>B f' \<star>\<^sub>B f'"
	+ using f f' hcomp_def trg_def arr_char ide_char trg_closed by simp
	+ have 2: "\<guillemotleft>\<nu> : trg\<^sub>B f \<star>\<^sub>B f \<Rightarrow>\<^sub>B trg\<^sub>B f' \<star>\<^sub>B f'\<guillemotright>"
	+ using 1 f f' \<nu> hcomp_def trg_def src_def inclusion
	+ dom_char cod_char hseq_char' arr_char ide_char trg_closed null_char
	+ by (simp add: arr_char in_hom_char)
	+ show "\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> L \<mu> = \<nu>"
	+ proof -
	+ let ?\<mu> = "B.\<ll> f' \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B B.inv (B.\<ll> f)"
	+ have \<mu>: "\<guillemotleft>?\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
	+ using f f' \<nu> 2 B.\<ll>_ide_simp lunit'_closed lunit_closed' ide_char by auto
	+ thus ?thesis
	+ using f f' \<nu> in_hom_char arr_char comp_closed ide_char
	+ lunit'_closed lunit_closed
	+ by (metis (no_types, lifting) B.arrI B.seqE in_homE)
	+ qed
	+ have \<mu>_eq: "?\<mu> = B.\<ll> f' \<cdot> \<nu> \<cdot> B.inv (B.\<ll> f)"
	+ proof -
	+ have "?\<mu> = B.\<ll> f' \<cdot> \<nu> \<cdot>\<^sub>B B.inv (B.\<ll> f)"
	+ using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
	+ lunit'_closed lunit_closed
	+ by (metis (no_types, lifting) B.seqE in_homE)
	+ also have "... = B.\<ll> f' \<cdot> \<nu> \<cdot> B.inv (B.\<ll> f)"
	+ using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
	+ lunit'_closed lunit_closed
	+ by (metis (no_types, lifting) B.seqE in_homE)
	+ finally show ?thesis by simp
	+ qed
	+ have "L ?\<mu> = \<nu>"
	+ proof -
	+ have "L ?\<mu> = trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>"
	+ using \<mu> \<mu>_eq hcomp_def trg_def inclusion arr_char trg_closed by auto
	+ also have "... = (trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>) \<cdot>\<^sub>B (B.inv (B.\<ll> f) \<cdot>\<^sub>B B.\<ll> f)"
	+ proof -
	+ have "B.inv (B.\<ll> f) \<cdot>\<^sub>B B.\<ll> f = trg\<^sub>B f \<star>\<^sub>B f"
	+ using f ide_char B.comp_inv_arr B.inv_is_inverse by auto
	+ moreover have "B.dom (trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>) = trg\<^sub>B f \<star>\<^sub>B f"
	+ using f \<mu> \<mu>_eq ide_char arr_char B.trg_dom [of ?\<mu>] B.hseqI' by fastforce
	+ ultimately show ?thesis
	+ using \<mu> \<mu>_eq B.comp_arr_dom in_hom_char B.hseqI' by auto
	+ qed
	+ also have "... = ((trg\<^sub>B ?\<mu> \<star>\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.inv (B.\<ll> f)) \<cdot>\<^sub>B B.\<ll> f"
	+ using B.comp_assoc by simp
	+ also have "... = (B.inv (B.\<ll> f') \<cdot>\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.\<ll> f"
	+ using \<mu> \<mu>_eq B.\<ll>'.naturality [of ?\<mu>] by auto
	+ also have "... = (B.inv (B.\<ll> f') \<cdot>\<^sub>B B.\<ll> f') \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B (B.inv (B.\<ll> f) \<cdot>\<^sub>B B.\<ll> f)"
	+ using \<mu> \<mu>_eq arr_char arrI comp_simp B.comp_assoc by metis
	+ also have "... = \<nu>"
	+ using f f' \<nu> 2 B.comp_arr_dom B.comp_cod_arr ide_char
	+ B.\<ll>.components_are_iso B.\<ll>_ide_simp B.comp_inv_arr'
	+ by auto
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using \<mu> by auto
	+ qed
	+ qed
	+
	+ interpretation R: faithful_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> R
	+ proof
	+ fix f f'
	+ assume par: "par f f'"
	+ assume eq: "R f = R f'"
	+ have "B.par f f'"
	+ using par inclusion arr_char by fastforce
	+ moreover have "B.R f = B.R f'"
	+ proof -
	+ have "\<forall>a. Arr a \<longrightarrow> B.arr a"
	+ by (simp add: inclusion)
	+ moreover have 1: "\<forall>a. arr a \<longrightarrow> (if arr a then hseq a (src a) else arr null)"
	+ using R.preserves_arr by presburger
	+ moreover have "Arr f \<and> Arr (src f) \<and> trg\<^sub>B (src f) = src\<^sub>B f"
	+ by (meson 1 hcomp_def hseq_char' par)
	+ ultimately show ?thesis
	+ by (metis (no_types) eq hcomp_def hseq_char' par src_def)
	+ qed
	+ ultimately show "f = f'"
	+ using B.R.is_faithful by blast
	+ qed
	+ interpretation R: full_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> R
	+ proof
	+ fix f f' \<nu>
	+ assume f: "ide f" and f': "ide f'" and \<nu>: "\<guillemotleft>\<nu> : R f \<Rightarrow> R f'\<guillemotright>"
	+ have 1: "R f = f \<star>\<^sub>B src\<^sub>B f \<and> R f' = f' \<star>\<^sub>B src\<^sub>B f'"
	+ using f f' hcomp_def src_def arr_char ide_char src_closed by simp
	+ have 2: "\<guillemotleft>\<nu> : f \<star>\<^sub>B src\<^sub>B f \<Rightarrow>\<^sub>B f' \<star>\<^sub>B src\<^sub>B f'\<guillemotright>"
	+ using 1 f f' \<nu> hcomp_def trg_def src_def inclusion
	+ dom_char cod_char hseq_char' arr_char ide_char trg_closed null_char
	+ by (simp add: arr_char in_hom_char)
	+ show "\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> R \<mu> = \<nu>"
	+ proof -
	+ let ?\<mu> = "B.\<rr> f' \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B B.inv (B.\<rr> f)"
	+ have \<mu>: "\<guillemotleft>?\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
	+ proof -
	+ have "\<guillemotleft>?\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright>"
	+ using f f' \<nu> 2 B.\<rr>_ide_simp runit'_closed runit_closed' ide_char by auto
	+ thus ?thesis
	+ using f f' \<nu> in_hom_char [of ?\<mu> f f'] arr_char comp_closed ide_char
	+ runit'_closed runit_closed
	+ apply auto
	+ by fastforce
	+ qed
	+ have \<mu>_eq: "?\<mu> = B.\<rr> f' \<cdot> \<nu> \<cdot> B.inv (B.\<rr> f)"
	+ proof -
	+ have "?\<mu> = B.\<rr> f' \<cdot> \<nu> \<cdot>\<^sub>B B.inv (B.\<rr> f)"
	+ using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
	+ runit'_closed runit_closed
	+ by (metis (no_types, lifting) B.seqE in_homE)
	+ also have "... = B.\<rr> f' \<cdot> \<nu> \<cdot> B.inv (B.\<rr> f)"
	+ using f f' \<nu> \<mu> arr_char inclusion comp_char comp_closed ide_char
	+ runit'_closed runit_closed
	+ by (metis (no_types, lifting) B.arrI B.comp_in_homE in_hom_char)
	+ finally show ?thesis by simp
	+ qed
	+ have "R ?\<mu> = \<nu>"
	+ proof -
	+ have "R ?\<mu> = ?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>"
	+ using \<mu> \<mu>_eq hcomp_def src_def inclusion arr_char src_closed by auto
	+ also have "... = (?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>) \<cdot>\<^sub>B (B.inv (B.\<rr> f) \<cdot>\<^sub>B B.\<rr> f)"
	+ proof -
	+ have "B.inv (B.\<rr> f) \<cdot>\<^sub>B B.\<rr> f = f \<star>\<^sub>B src\<^sub>B f"
	+ using f ide_char B.comp_inv_arr B.inv_is_inverse by auto
	+ moreover have "B.dom (?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>) = f \<star>\<^sub>B src\<^sub>B f"
	+ using f \<mu> \<mu>_eq ide_char arr_char B.src_dom [of ?\<mu>] B.hseqI' by fastforce
	+ ultimately show ?thesis
	+ using \<mu> \<mu>_eq B.comp_arr_dom in_hom_char B.hseqI' by auto
	+ qed
	+ also have "... = ((?\<mu> \<star>\<^sub>B src\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.inv (B.\<rr> f)) \<cdot>\<^sub>B B.\<rr> f"
	+ using B.comp_assoc by simp
	+ also have "... = (B.inv (B.\<rr> f') \<cdot>\<^sub>B ?\<mu>) \<cdot>\<^sub>B B.\<rr> f"
	+ using \<mu> \<mu>_eq B.\<rr>'.naturality [of ?\<mu>] by auto
	+ also have "... = (B.inv (B.\<rr> f') \<cdot>\<^sub>B B.\<rr> f') \<cdot>\<^sub>B \<nu> \<cdot>\<^sub>B (B.inv (B.\<rr> f) \<cdot>\<^sub>B B.\<rr> f)"
	+ using \<mu> \<mu>_eq arr_char arrI comp_simp B.comp_assoc by metis
	+ also have "... = \<nu>"
	+ using f f' \<nu> 2 B.comp_arr_dom B.comp_cod_arr ide_char
	+ B.\<ll>.components_are_iso B.\<ll>_ide_simp B.comp_inv_arr'
	+ by auto
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using \<mu> by blast
	+ qed
	+ qed
	+
	+ interpretation bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
	+ proof
	+ show "\<And>a. obj a \<Longrightarrow> \<guillemotleft>\<i> a : a \<star> a \<rightarrow> a\<guillemotright>"
	+ proof -
	+ fix a
	+ assume a: "obj a"
	+ have 1: "trg\<^sub>B a = src\<^sub>B a"
	+ using a obj_def src_def trg_def B.obj_def arr_char
	+ by (metis horizontal_homs.objE horizontal_homs_axioms)
	+ have 2: "Arr (\<i> a)"
	+ using a 1 obj_def src_def trg_def in_hom_char B.unit_in_hom
	+ arr_char hcomp_def B.obj_def ide_char objE hcomp_closed
	+ by (metis (no_types, lifting) B.\<ll>_ide_simp B.unitor_coincidence(1) inclusion lunit_closed)
	+ show "\<guillemotleft>\<i> a : a \<star> a \<rightarrow> a\<guillemotright>"
	+ using a 1 2 obj_def src_def trg_def in_hom_char B.unit_in_hom
	+ arr_char hcomp_def B.obj_def ide_char hcomp_closed
	+ apply (elim objE) by auto
	+ qed
	+ show "\<And>a. obj a \<Longrightarrow> iso (\<i> a)"
	+ proof -
	+ fix a
	+ assume a: "obj a"
	+ have 1: "trg\<^sub>B a = src\<^sub>B a"
	+ using a obj_def src_def trg_def B.obj_def arr_char
	+ by (metis horizontal_homs.objE horizontal_homs_axioms)
	+ have 2: "Arr (\<i> a)"
	+ using a 1 obj_def src_def trg_def in_hom_char B.unit_in_hom
	+ arr_char hcomp_def B.obj_def ide_char objE hcomp_closed
	+ by (metis (no_types, lifting) B.\<ll>_ide_simp B.unitor_coincidence(1) inclusion lunit_closed)
	+ have "iso (B.\<ll> a)"
	+ using a 2 obj_def B.iso_unit iso_char arr_char lunit_closed lunit'_closed B.iso_lunit
	+ apply simp
	+ by (metis (no_types, lifting) B.\<ll>.components_are_iso B.ide_src inclusion src_def)
	+ thus "iso (\<i> a)"
	+ using a 2 obj_def B.iso_unit iso_char arr_char B.unitor_coincidence
	+ apply simp
	+ by (metis (no_types, lifting) B.\<ll>_ide_simp B.ide_src B.obj_src inclusion src_def)
	+ qed
	+ show "\<And>f g h k. \<lbrakk> ide f; ide g; ide h; ide k;
	+ src f = trg g; src g = trg h; src h = trg k \<rbrakk> \<Longrightarrow>
	+ (f \<star> \<a> g h k) \<cdot> \<a> f (g \<star> h) k \<cdot> (\<a> f g h \<star> k) =
	+ \<a> f g (h \<star> k) \<cdot> \<a> (f \<star> g) h k"
	+ using B.pentagon VVV.arr_char VV.arr_char hcomp_def assoc_closed arr_char comp_char
	+ hcomp_closed comp_closed ide_char inclusion src_def trg_def
	+ by simp
	+ qed
	+
	+ proposition is_bicategory:
	+ shows "bicategory (\<cdot>) (\<star>) \<a> \<i> src trg"
	+ ..
	+
	+ lemma obj_char:
	+ shows "obj a \<longleftrightarrow> Arr a \<and> B.obj a"
	+ using obj_def src_def arr_char
	+ by (simp add: B.obj_def inclusion)
	+
	+ end
	+
	+ sublocale subbicategory \<subseteq> bicategory \<open>(\<cdot>)\<close> \<open>(\<star>)\<close> \<a> \<i> src trg
	+ using is_bicategory by auto
	+
	+ subsection "The Sub-bicategory of Endo-arrows of an Object"
	+
	+ text \<open>
	+ We now consider the sub-bicategory consisting of all arrows having the same
	+ object \<open>a\<close> both as their source and their target and we show that the resulting structure
	+ is a monoidal category. We actually prove a slightly more general result,
	+ in which the unit of the monoidal category is taken to be an arbitrary isomorphism
	+ \<open>\<guillemotleft>\<omega> : w \<star>\<^sub>B w \<Rightarrow> w\<guillemotright>\<close> with \<open>w\<close> isomorphic to \<open>a\<close>, rather than the particular choice
	+ \<open>\<guillemotleft>\<i>[a] : a \<star>\<^sub>B a \<Rightarrow> a\<guillemotright>\<close> made by the ambient bicategory.
	+ \<close>
	+
	+ locale subbicategory_at_object =
	+ B: bicategory V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B +
	+ subbicategory V H \<a>\<^sub>B \<i> src\<^sub>B trg\<^sub>B \<open>\<lambda>\<mu>. B.arr \<mu> \<and> src\<^sub>B \<mu> = a \<and> trg\<^sub>B \<mu> = a\<close>
	+ for V :: "'a comp" (infixr "\<cdot>\<^sub>B" 55)
	+ and H :: "'a comp" (infixr "\<star>\<^sub>B" 55)
	+ and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>\<^sub>B[_, _, _]")
	+ and \<i> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src\<^sub>B :: "'a \<Rightarrow> 'a"
	+ and trg\<^sub>B :: "'a \<Rightarrow> 'a"
	+ and a :: "'a"
	+ and w :: "'a"
	+ and \<omega> :: "'a" +
	+ assumes obj_a: "B.obj a"
	+ and isomorphic_a_w: "B.isomorphic a w"
	+ and \<omega>_in_vhom: "\<guillemotleft>\<omega> : w \<star>\<^sub>B w \<Rightarrow> w\<guillemotright>"
	+ and \<omega>_is_iso: "B.iso \<omega>"
	+ begin
	+
	+ notation hcomp (infixr "\<star>" 53)
	+
	+ lemma arr_simps:
	+ assumes "arr \<mu>"
	+ shows "src \<mu> = a" and "trg \<mu> = a"
	+ apply (metis (no_types, lifting) arrE assms src_def)
	+ by (metis (no_types, lifting) arrE assms trg_def)
	+
	+ lemma \<omega>_simps [simp]:
	+ shows "arr \<omega>"
	+ and "src \<omega> = a" and "trg \<omega> = a"
	+ and "dom \<omega> = w \<star>\<^sub>B w" and "cod \<omega> = w"
	+ using isomorphic_a_w \<omega>_in_vhom in_hom_char arr_simps by auto
	+
	+ lemma ide_w:
	+ shows "B.ide w"
	+ using isomorphic_a_w B.isomorphic_def by auto
	+
	+ lemma w_simps [simp]:
	+ shows "ide w" and "B.ide w"
	+ and "src w = a" and "trg w = a" and "src\<^sub>B w = a" and "trg\<^sub>B w = a"
	+ and "dom w = w" and "cod w = w"
	+ proof -
	+ show w: "ide w"
	+ using \<omega>_in_vhom ide_cod by blast
	+ show "B.ide w"
	+ using w ide_char by simp
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : a \<Rightarrow>\<^sub>B w\<guillemotright> \<and> B.iso \<phi>"
	+ using isomorphic_a_w B.isomorphic_def by auto
	+ show "src\<^sub>B w = a"
	+ using obj_a w \<phi> B.src_cod by force
	+ show "trg\<^sub>B w = a"
	+ using obj_a w \<phi> B.src_cod by force
	+ show "src w = a"
	+ using `src\<^sub>B w = a` ide_w src_def
	+ by (simp add: \<open>trg\<^sub>B w = a\<close>)
	+ show "trg w = a"
	+ using `src\<^sub>B w = a` ide_w trg_def
	+ by (simp add: \<open>trg\<^sub>B w = a\<close>)
	+ show "dom w = w"
	+ using w by simp
	+ show "cod w = w"
	+ using w by simp
	+ qed
	+
	+ lemma VxV_arr_eq_VV_arr:
	+ shows "VxV.arr f \<longleftrightarrow> VV.arr f"
	+ using inclusion VxV.arr_char VV.arr_char arr_char src_def trg_def
	+ by auto
	+
	+ lemma VxV_comp_eq_VV_comp:
	+ shows "VxV.comp = VV.comp"
	+ proof -
	+ have "\<And>f g. VxV.comp f g = VV.comp f g"
	+ proof -
	+ fix f g
	+ show "VxV.comp f g = VV.comp f g"
	+ unfolding VV.comp_def
	+ using VxV.comp_char arr_simps(1) arr_simps(2)
	+ apply (cases "seq (fst f) (fst g)", cases "seq (snd f) (snd g)")
	+ apply (elim seqE)
	+ by auto
	+ qed
	+ thus ?thesis by blast
	+ qed
	+
	+ lemma VxVxV_arr_eq_VVV_arr:
	+ shows "VxVxV.arr f \<longleftrightarrow> VVV.arr f"
	+ using VVV.arr_char VV.arr_char src_def trg_def inclusion arr_char
	+ by auto
	+
	+ lemma VxVxV_comp_eq_VVV_comp:
	+ shows "VxVxV.comp = VVV.comp"
	+ proof -
	+ have "\<And>f g. VxVxV.comp f g = VVV.comp f g"
	+ proof -
	+ fix f g
	+ show "VxVxV.comp f g = VVV.comp f g"
	+ proof (cases "VxVxV.seq f g")
	+ assume 1: "\<not> VxVxV.seq f g"
	+ have "VxVxV.comp f g = VxVxV.null"
	+ using 1 VxVxV.ext by blast
	+ also have "... = (null, null, null)"
	+ using VxVxV.null_char VxV.null_char by simp
	+ also have "... = VVV.null"
	+ using VVV.null_char VV.null_char by simp
	+ also have "... = VVV.comp f g"
	+ proof -
	+ have "\<not> VVV.seq f g"
	+ using 1 VVV.seq_char by blast
	+ thus ?thesis
	+ by (metis (no_types, lifting) VVV.ext)
	+ qed
	+ finally show ?thesis by simp
	+ next
	+ assume 1: "VxVxV.seq f g"
	+ have 2: "B.arr (fst f) \<and> B.arr (fst (snd f)) \<and> B.arr (snd (snd f)) \<and>
	+ src\<^sub>B (fst f) = a \<and> src\<^sub>B (fst (snd f)) = a \<and> src\<^sub>B (snd (snd f)) = a \<and>
	+ trg\<^sub>B (fst f) = a \<and> trg\<^sub>B (fst (snd f)) = a \<and> trg\<^sub>B (snd (snd f)) = a"
	+ using 1 VxVxV.seq_char VxV.seq_char arr_char by blast
	+ have 3: "B.arr (fst g) \<and> B.arr (fst (snd g)) \<and> B.arr (snd (snd g)) \<and>
	+ src\<^sub>B (fst g) = a \<and> src\<^sub>B (fst (snd g)) = a \<and> src\<^sub>B (snd (snd g)) = a \<and>
	+ trg\<^sub>B (fst g) = a \<and> trg\<^sub>B (fst (snd g)) = a \<and> trg\<^sub>B (snd (snd g)) = a"
	+ using 1 VxVxV.seq_char VxV.seq_char arr_char by blast
	+ have 4: "B.seq (fst f) (fst g) \<and> B.seq (fst (snd f)) (fst (snd g)) \<and>
	+ B.seq (snd (snd f)) (snd (snd g))"
	+ using 1 VxVxV.seq_char VxV.seq_char seq_char by blast
	+ have 5: "VxVxV.comp f g =
	+ (fst f \<cdot> fst g, fst (snd f) \<cdot> fst (snd g), snd (snd f) \<cdot> snd (snd g))"
	+ using 1 2 3 4 VxVxV.seqE VxVxV.comp_char VxV.comp_char seq_char arr_char
	+ by (metis (no_types, lifting))
	+ also have "... = VVV.comp f g"
	+ using 1 2 3 5 VVV.comp_char VV.comp_char VVV.arr_char VV.arr_char arr_char
	+ src_def trg_def
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ qed
	+ thus ?thesis by blast
	+ qed
	+
	+ interpretation H: "functor" VxV.comp \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close>
	+ using H.functor_axioms hcomp_def VxV_comp_eq_VV_comp by simp
	+
	+ interpretation H: binary_endofunctor \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> ..
	+
	+ lemma HoHV_eq_ToTC:
	+ shows "HoHV = H.ToTC"
	+ using HoHV_def H.ToTC_def VVV.arr_char VV.arr_char src_def trg_def inclusion arr_char
	+ by auto
	+
	+ lemma HoVH_eq_ToCT:
	+ shows "HoVH = H.ToCT"
	+ using HoVH_def H.ToCT_def VVV.arr_char VV.arr_char src_def trg_def inclusion arr_char
	+ by auto
	+
	+ interpretation ToTC: "functor" VxVxV.comp \<open>(\<cdot>)\<close> H.ToTC
	+ using HoHV_eq_ToTC VxVxV_comp_eq_VVV_comp HoHV.functor_axioms by simp
	+ interpretation ToCT: "functor" VxVxV.comp \<open>(\<cdot>)\<close> H.ToCT
	+ using HoVH_eq_ToCT VxVxV_comp_eq_VVV_comp HoVH.functor_axioms by simp
	+
	+ interpretation \<alpha>: natural_isomorphism VxVxV.comp \<open>(\<cdot>)\<close> H.ToTC H.ToCT \<alpha>
	+ unfolding \<alpha>_def
	+ using \<alpha>.natural_isomorphism_axioms HoHV_eq_ToTC HoVH_eq_ToCT \<alpha>_def
	+ VxVxV_comp_eq_VVV_comp
	+ by simp
	+
	+ interpretation L: endofunctor \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (w, f) \<star> snd (w, f)\<close>
	+ proof
	+ fix f
	+ show "\<not> arr f \<Longrightarrow> fst (w, f) \<star> snd (w, f) = null"
	+ using arr_char hcomp_def by auto
	+ assume f: "arr f"
	+ show "hseq (fst (w, f)) (snd (w, f))"
	+ using f hseq_char arr_char src_def trg_def \<omega>_in_vhom cod_char by simp
	+ show "dom (fst (w, f) \<star> snd (w, f)) = fst (w, dom f) \<star> snd (w, dom f)"
	+ using f arr_char hcomp_def B.hseqI' by simp
	+ show "cod (fst (w, f) \<star> snd (w, f)) = fst (w, cod f) \<star> snd (w, cod f)"
	+ using f arr_char hcomp_def B.hseqI' by simp
	+ next
	+ fix f g
	+ assume fg: "seq g f"
	+ show "fst (w, g \<cdot> f) \<star> snd (w, g \<cdot> f) = (fst (w, g) \<star> snd (w, g)) \<cdot> (fst (w, f) \<star> snd (w, f))"
	+ by (simp add: fg whisker_left)
	+ qed
	+
	+ interpretation L': equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (w, f) \<star> snd (w, f)\<close>
	+ proof -
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi>"
	+ using isomorphic_a_w B.isomorphic_symmetric by force
	+ have "\<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright>"
	+ using \<phi> in_hom_char
	+ by (metis (no_types, lifting) B.in_homE B.src_cod B.src_src B.trg_cod B.trg_trg
	+ \<omega>_in_vhom arr_char arr_cod cod_simp)
	+ hence \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi> \<and> \<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright> \<and> iso \<phi>"
	+ using \<phi> iso_char arr_char by auto
	+ interpret \<l>: natural_isomorphism \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close>
	+ \<open>\<lambda>f. fst (w, f) \<star> snd (w, f)\<close> map \<open>\<lambda>f. \<ll> f \<cdot> (\<phi> \<star> dom f)\<close>
	+ proof
	+ fix \<mu>
	+ show "\<not> arr \<mu> \<Longrightarrow> \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>) = null"
	+ using \<phi> arr_char dom_char ext
	+ apply simp
	+ using comp_null(2) hcomp_def by fastforce
	+ assume \<mu>: "arr \<mu>"
	+ have 1: "hseq \<phi> (dom \<mu>)"
	+ proof (intro hseqI)
	+ show "in_hhom (dom \<mu>) a a"
	+ using \<mu> arr_char src_dom trg_dom src_def trg_def by simp
	+ show "in_hhom \<phi> a a"
	+ using \<phi> arr_char src_dom trg_dom src_def trg_def by auto
	+ qed
	+ have 2: "hseq \<phi> (B.dom \<mu>)"
	+ proof (intro hseqI)
	+ show "in_hhom (B.dom \<mu>) a a"
	+ using \<mu> arr_char src_dom trg_dom src_def trg_def by simp
	+ show "in_hhom \<phi> a a"
	+ using \<phi> arr_char src_dom trg_dom src_def trg_def by auto
	+ qed
	+ have 3: "seq (\<ll> \<mu>) (\<phi> \<star> dom \<mu>)"
	+ using \<mu> \<phi> 1 2
	+ apply (intro seqI hseqI')
	+ apply auto
	+ proof -
	+ have "B.dom (\<ll> \<mu>) = a \<star> dom \<mu>"
	+ using \<mu> 2 \<ll>.preserves_dom arr_simps(2) by auto
	+ also have "... = B.cod (\<phi> \<star> B.dom \<mu>)"
	+ using \<mu> \<phi> 2 hcomp_simps(4) cod_dom in_homE by auto
	+ finally show "B.dom (\<ll> \<mu>) = B.cod (\<phi> \<star> B.dom \<mu>)"
	+ by blast
	+ qed
	+ show "dom (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = fst (w, dom \<mu>) \<star> snd (w, dom \<mu>)"
	+ proof -
	+ have "dom (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = dom \<phi> \<star> dom \<mu>"
	+ using \<mu> 3 hcomp_simps(3) dom_comp
	+ by (metis (no_types, lifting) dom_dom seqE)
	+ also have "... = fst (w, dom \<mu>) \<star> snd (w, dom \<mu>)"
	+ using \<omega>_in_vhom \<phi>
	+ by (metis (no_types, lifting) in_homE prod.sel(1) prod.sel(2))
	+ finally show ?thesis by simp
	+ qed
	+ show "cod (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = map (cod \<mu>)"
	+ proof -
	+ have "seq (\<ll> \<mu>) (\<phi> \<star> dom \<mu>)"
	+ using 3 by simp
	+ hence "cod (\<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)) = cod (\<ll> \<mu>)"
	+ using cod_comp by blast
	+ also have "... = map (cod \<mu>)"
	+ using \<mu> by blast
	+ finally show ?thesis by blast
	+ qed
	+ show "map \<mu> \<cdot> \<ll> (dom \<mu>) \<cdot> (\<phi> \<star> dom (dom \<mu>)) = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
	+ proof -
	+ (*
	+ * TODO: The automatic simplification of dom to B.dom prevents the application
	+ * of dom_dom here.
	+ *)
	+ have "map \<mu> \<cdot> \<ll> (dom \<mu>) \<cdot> (\<phi> \<star> dom (dom \<mu>)) =
	+ (map \<mu> \<cdot> \<ll> (dom \<mu>)) \<cdot> (\<phi> \<star> dom (dom \<mu>))"
	+ using comp_assoc by simp
	+ also have "... = (map \<mu> \<cdot> \<ll> (dom \<mu>)) \<cdot> (\<phi> \<star> dom \<mu>)"
	+ using \<mu> dom_dom by simp
	+ also have "... = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
	+ using \<mu> \<phi> \<ll>.is_natural_1 by auto
	+ finally show ?thesis by blast
	+ qed
	+ show "(\<ll> (cod \<mu>) \<cdot> (\<phi> \<star> dom (cod \<mu>))) \<cdot> (fst (w, \<mu>) \<star> snd (w, \<mu>)) = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
	+ proof -
	+ have "(\<ll> (cod \<mu>) \<cdot> (\<phi> \<star> dom (cod \<mu>))) \<cdot> (fst (w, \<mu>) \<star> snd (w, \<mu>)) =
	+ (\<ll> (cod \<mu>) \<cdot> (\<phi> \<star> B.cod \<mu>)) \<cdot> (w \<star> \<mu>)"
	+ using \<mu> \<phi> dom_char arr_char \<omega>_in_vhom by simp
	+ also have "... = \<ll> (cod \<mu>) \<cdot> (\<phi> \<cdot> w \<star> B.cod \<mu> \<cdot> \<mu>)"
	+ proof -
	+ have "seq \<phi> w"
	+ using \<phi> \<omega>_in_vhom w_simps(1) by blast
	+ moreover have 2: "seq (B.cod \<mu>) \<mu>"
	+ using \<mu> seq_char by (simp add: comp_cod_arr)
	+ moreover have "src \<phi> = trg (B.cod \<mu>)"
	+ using \<mu> \<phi> 1 2
	+ by (metis (no_types, lifting) hseqE trg_dom vseq_implies_hpar(2))
	+ ultimately show ?thesis
	+ using interchange comp_assoc by simp
	+ qed
	+ also have "... = \<ll> (cod \<mu>) \<cdot> (\<phi> \<star> \<mu>)"
	+ using \<mu> \<phi> \<omega>_in_vhom comp_arr_dom comp_cod_arr cod_simp
	+ apply (elim conjE in_homE) by auto
	+ also have "... = (\<ll> (cod \<mu>) \<cdot> (cod \<phi> \<star> \<mu>)) \<cdot> (\<phi> \<star> dom \<mu>)"
	+ proof -
	+ have "seq (cod \<phi>) \<phi>"
	+ using \<phi> arr_cod_iff_arr dom_cod iso_is_arr seqI by presburger
	+ moreover have "seq \<mu> (dom \<mu>)"
	+ using \<mu> by (simp add: comp_arr_dom)
	+ moreover have "src (cod \<phi>) = trg \<mu>"
	+ using \<mu> \<phi> arr_cod arr_simps(1-2) iso_is_arr by auto
	+ ultimately show ?thesis
	+ using \<mu> \<phi> interchange [of "cod \<phi>" \<phi> \<mu> "dom \<mu>"] comp_assoc
	+ by (simp add: comp_arr_dom comp_cod_arr iso_is_arr)
	+ qed
	+ also have "... = \<ll> \<mu> \<cdot> (\<phi> \<star> dom \<mu>)"
	+ proof -
	+ have "L \<mu> = cod \<phi> \<star> \<mu>"
	+ using \<mu> \<phi> arr_simps(2) in_homE by auto
	+ hence "\<ll> (cod \<mu>) \<cdot> (cod \<phi> \<star> \<mu>) = \<ll> \<mu>"
	+ using \<mu> \<ll>.is_natural_2 [of \<mu>] by simp
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ next
	+ show "\<And>f. ide f \<Longrightarrow> iso (\<ll> f \<cdot> (\<phi> \<star> dom f))"
	+ proof -
	+ fix f
	+ assume f: "ide f"
	+ have "iso (\<ll> f)"
	+ using f iso_lunit by simp
	+ moreover have "iso (\<phi> \<star> dom f)"
	+ using \<phi> f src_def trg_def ide_char arr_char
	+ apply (intro iso_hcomp, simp_all)
	+ by (metis (no_types, lifting) in_homE)
	+ moreover have "seq (\<ll> f) (\<phi> \<star> dom f)"
	+ proof (intro seqI')
	+ show " \<guillemotleft>\<ll> f : a \<star> f \<Rightarrow> f\<guillemotright>"
	+ using f lunit_in_hom(2) \<ll>_ide_simp ide_char arr_char trg_def by simp
	+ show "\<guillemotleft>\<phi> \<star> dom f : w \<star> f \<Rightarrow> a \<star> f\<guillemotright>"
	+ using \<phi> f ide_char arr_char hcomp_def src_def trg_def obj_a ide_in_hom
	+ in_hom_char
	+ by (intro hcomp_in_vhom, auto)
	+ qed
	+ ultimately show "iso (\<ll> f \<cdot> (\<phi> \<star> dom f))"
	+ using isos_compose by simp
	+ qed
	+ qed
	+ show "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (w, f) \<star> snd (w, f))"
	+ using \<l>.natural_isomorphism_axioms L.isomorphic_to_identity_is_equivalence by simp
	+ qed
	+ interpretation L: equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (cod \<omega>, f) \<star> snd (cod \<omega>, f)\<close>
	+ proof -
	+ have "(\<lambda>f. fst (cod \<omega>, f) \<star> snd (cod \<omega>, f)) = (\<lambda>f. fst (w, f) \<star> snd (w, f))"
	+ using \<omega>_in_vhom by simp
	+ thus "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (cod \<omega>, f) \<star> snd (cod \<omega>, f))"
	+ using L'.equivalence_functor_axioms by simp
	+ qed
	+
	+ interpretation R: endofunctor \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (f, w) \<star> snd (f, w)\<close>
	+ proof
	+ fix f
	+ show "\<not> arr f \<Longrightarrow> fst (f, w) \<star> snd (f, w) = null"
	+ using arr_char hcomp_def by auto
	+ assume f: "arr f"
	+ show "hseq (fst (f, w)) (snd (f, w))"
	+ using f hseq_char arr_char src_def trg_def \<omega>_in_vhom cod_char isomorphic_a_w
	+ B.isomorphic_def in_hom_char
	+ by simp
	+ show "dom (fst (f, w) \<star> snd (f, w)) = fst (dom f, w) \<star> snd (dom f, w)"
	+ using f arr_char dom_char cod_char hcomp_def \<omega>_in_vhom B.hseqI' by simp
	+ show "cod (fst (f, w) \<star> snd (f, w)) = fst (cod f, w) \<star> snd (cod f, w)"
	+ using f arr_char dom_char cod_char hcomp_def \<omega>_in_vhom B.hseqI' by simp
	+ next
	+ fix f g
	+ assume fg: "seq g f"
	+ have 1: "a \<cdot>\<^sub>B a = a"
	+ using obj_a by auto
	+ show "fst (g \<cdot> f, w) \<star> snd (g \<cdot> f, w) = (fst (g, w) \<star> snd (g, w)) \<cdot> (fst (f, w) \<star> snd (f, w))"
	+ by (simp add: fg whisker_right)
	+ qed
	+
	+ interpretation R': equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (f, w) \<star> snd (f, w)\<close>
	+ proof -
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi>"
	+ using isomorphic_a_w B.isomorphic_symmetric by force
	+ have "\<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright>"
	+ using \<phi> in_hom_char
	+ by (metis (no_types, lifting) B.in_homE B.src_cod B.src_src B.trg_cod B.trg_trg
	+ \<omega>_in_vhom arr_char arr_cod cod_simp)
	+ hence \<phi>: "\<guillemotleft>\<phi> : w \<Rightarrow>\<^sub>B a\<guillemotright> \<and> B.iso \<phi> \<and> \<guillemotleft>\<phi> : w \<Rightarrow> a\<guillemotright> \<and> iso \<phi>"
	+ using \<phi> iso_char arr_char by auto
	+ interpret \<r>: natural_isomorphism comp comp
	+ \<open>\<lambda>f. fst (f, w) \<star> snd (f, w)\<close> map \<open>\<lambda>f. \<rr> f \<cdot> (dom f \<star> \<phi>)\<close>
	+ proof
	+ fix \<mu>
	+ show "\<not> arr \<mu> \<Longrightarrow> \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>) = null"
	+ using \<phi> arr_char dom_char ext
	+ apply simp
	+ using comp_null(2) hcomp_def by fastforce
	+ assume \<mu>: "arr \<mu>"
	+ have 1: "hseq \<phi> (dom \<mu>)"
	+ proof (intro hseqI)
	+ show "in_hhom (dom \<mu>) a a"
	+ using \<mu> arr_char src_dom trg_dom src_def trg_def by simp
	+ show "in_hhom \<phi> a a"
	+ using \<phi> arr_char src_dom trg_dom src_def trg_def by auto
	+ qed
	+ have 2: "hseq (B.dom \<mu>) \<phi>"
	+ using \<mu> \<phi> 1 src_dom [of \<mu>]
	+ apply (intro hseqI')
	+ by (auto simp add: arr_simps(1) vconn_implies_hpar(2))
	+ have 3: "seq (\<rr> \<mu>) (dom \<mu> \<star> \<phi>)"
	+ using \<mu> \<phi> 1 2
	+ apply (intro seqI hseqI')
	+ apply auto
	+ proof -
	+ have "B.dom (\<rr> \<mu>) = dom \<mu> \<star> a"
	+ using \<mu> 2 \<rr>.preserves_dom arr_simps(1) by auto
	+ also have "... = B.cod (B.dom \<mu> \<star> \<phi>)"
	+ using \<mu> \<phi> 2 hcomp_simps(4) cod_dom in_homE by auto
	+ finally show "B.dom (\<rr> \<mu>) = B.cod (B.dom \<mu> \<star> \<phi>)"
	+ by blast
	+ qed
	+ show "dom (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = fst (dom \<mu>, w) \<star> snd (dom \<mu>, w)"
	+ proof -
	+ have "dom (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = dom \<mu> \<star> dom \<phi>"
	+ using \<mu> 3 hcomp_simps(3) dom_comp
	+ by (metis (no_types, lifting) dom_dom seqE)
	+ also have "... = fst (dom \<mu>, w) \<star> snd (dom \<mu>, w)"
	+ using \<omega>_in_vhom \<phi>
	+ by (metis (no_types, lifting) in_homE prod.sel(1) prod.sel(2))
	+ finally show ?thesis by simp
	+ qed
	+ show "cod (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = map (cod \<mu>)"
	+ proof -
	+ have "seq (\<rr> \<mu>) (dom \<mu> \<star> \<phi>)"
	+ using 3 by simp
	+ hence "cod (\<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)) = cod (\<rr> \<mu>)"
	+ using cod_comp by blast
	+ also have "... = map (cod \<mu>)"
	+ using \<mu> by blast
	+ finally show ?thesis by blast
	+ qed
	+ show "map \<mu> \<cdot> \<rr> (dom \<mu>) \<cdot> (dom (dom \<mu>) \<star> \<phi>) = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
	+ proof -
	+ have "map \<mu> \<cdot> \<rr> (dom \<mu>) \<cdot> (dom (dom \<mu>) \<star> \<phi>) =
	+ (map \<mu> \<cdot> \<rr> (dom \<mu>)) \<cdot> (dom (dom \<mu>) \<star> \<phi>)"
	+ using comp_assoc by simp
	+ also have "... = (map \<mu> \<cdot> \<rr> (dom \<mu>)) \<cdot> (dom \<mu> \<star> \<phi>)"
	+ using \<mu> dom_dom by simp
	+ also have "... = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
	+ using \<mu> \<phi> \<rr>.is_natural_1 by auto
	+ finally show ?thesis by blast
	+ qed
	+ show "(\<rr> (cod \<mu>) \<cdot> (dom (cod \<mu>) \<star> \<phi>)) \<cdot> (fst (\<mu>, w) \<star> snd (\<mu>, w)) = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
	+ proof -
	+ have "(\<rr> (cod \<mu>) \<cdot> (dom (cod \<mu>) \<star> \<phi>)) \<cdot> (fst (\<mu>, w) \<star> snd (\<mu>, w)) =
	+ (\<rr> (cod \<mu>) \<cdot> (B.cod \<mu> \<star> \<phi>)) \<cdot> (\<mu> \<star> w)"
	+ using \<mu> \<phi> dom_char arr_char \<omega>_in_vhom by simp
	+ also have "... = \<rr> (cod \<mu>) \<cdot> (B.cod \<mu> \<cdot> \<mu> \<star> \<phi> \<cdot> w)"
	+ proof -
	+ have 2: "seq \<phi> w"
	+ using \<phi> \<omega>_in_vhom w_simps(1) by blast
	+ moreover have "seq (B.cod \<mu>) \<mu>"
	+ using \<mu> seq_char by (simp add: comp_cod_arr)
	+ moreover have "src (B.cod \<mu>) = trg \<phi>"
	+ using \<mu> \<phi> 2
	+ by (metis (no_types, lifting) arrE cod_closed src_def vseq_implies_hpar(2)
	+ w_simps(4))
	+ ultimately show ?thesis
	+ using interchange comp_assoc by simp
	+ qed
	+ also have "... = \<rr> (cod \<mu>) \<cdot> (\<mu> \<star> \<phi>)"
	+ using \<mu> \<phi> \<omega>_in_vhom comp_arr_dom comp_cod_arr cod_simp
	+ apply (elim conjE in_homE) by auto
	+ also have "... = (\<rr> (cod \<mu>) \<cdot> (\<mu> \<star> cod \<phi>)) \<cdot> (dom \<mu> \<star> \<phi>)"
	+ proof -
	+ have "(\<mu> \<star> cod \<phi>) \<cdot> (dom \<mu> \<star> \<phi>) = \<mu> \<star> \<phi>"
	+ proof -
	+ have "seq \<mu> (dom \<mu>)"
	+ using \<mu> by (simp add: comp_arr_dom)
	+ moreover have "seq (cod \<phi>) \<phi>"
	+ using \<phi> iso_is_arr arr_cod dom_cod by auto
	+ moreover have "src \<mu> = trg (cod \<phi>)"
	+ using \<mu> \<phi> 2
	+ by (metis (no_types, lifting) arr_simps(1) arr_simps(2) calculation(2) seqE)
	+ ultimately show ?thesis
	+ using \<mu> \<phi> iso_is_arr comp_arr_dom comp_cod_arr
	+ interchange [of \<mu> "dom \<mu>" "cod \<phi>" \<phi>]
	+ by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<rr> \<mu> \<cdot> (dom \<mu> \<star> \<phi>)"
	+ proof -
	+ have "\<mu> \<star> cod \<phi> = R \<mu>"
	+ using \<mu> \<phi> arr_simps(1) in_homE by auto
	+ hence "\<rr> (cod \<mu>) \<cdot> (\<mu> \<star> cod \<phi>) = \<rr> \<mu>"
	+ using \<mu> \<phi> \<rr>.is_natural_2 by simp
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ next
	+ show "\<And>f. ide f \<Longrightarrow> iso (\<rr> f \<cdot> (dom f \<star> \<phi>))"
	+ proof -
	+ fix f
	+ assume f: "ide f"
	+ have 1: "iso (\<rr> f)"
	+ using f iso_lunit by simp
	+ moreover have 2: "iso (dom f \<star> \<phi>)"
	+ using \<phi> f src_def trg_def ide_char arr_char
	+ apply (intro iso_hcomp, simp_all)
	+ by (metis (no_types, lifting) in_homE)
	+ moreover have "seq (\<rr> f) (dom f \<star> \<phi>)"
	+ proof (intro seqI')
	+ show "\<guillemotleft>\<rr> f : f \<star> a \<Rightarrow> f\<guillemotright>"
	+ using f runit_in_hom(2) \<rr>_ide_simp ide_char arr_char src_def by simp
	+ show "\<guillemotleft>dom f \<star> \<phi> : f \<star> w \<Rightarrow> f \<star> a\<guillemotright>"
	+ using \<phi> f ide_char arr_char hcomp_def src_def trg_def obj_a ide_in_hom
	+ in_hom_char
	+ by (intro hcomp_in_vhom, auto)
	+ qed
	+ ultimately show "iso (\<rr> f \<cdot> (dom f \<star> \<phi>))"
	+ using isos_compose by simp
	+ qed
	+ qed
	+ show "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (f, w) \<star> snd (f, w))"
	+ using \<r>.natural_isomorphism_axioms R.isomorphic_to_identity_is_equivalence by simp
	+ qed
	+ interpretation R: equivalence_functor \<open>(\<cdot>)\<close> \<open>(\<cdot>)\<close> \<open>\<lambda>f. fst (f, cod \<omega>) \<star> snd (f, cod \<omega>)\<close>
	+ proof -
	+ have "(\<lambda>f. fst (f, cod \<omega>) \<star> snd (f, cod \<omega>)) = (\<lambda>f. fst (f, w) \<star> snd (f, w))"
	+ using \<omega>_in_vhom by simp
	+ thus "equivalence_functor (\<cdot>) (\<cdot>) (\<lambda>f. fst (f, cod \<omega>) \<star> snd (f, cod \<omega>))"
	+ using R'.equivalence_functor_axioms by simp
	+ qed
	+
	+ interpretation M: monoidal_category \<open>(\<cdot>)\<close> \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> \<alpha> \<omega>
	+ proof
	+ show "\<guillemotleft>\<omega> : fst (cod \<omega>, cod \<omega>) \<star> snd (cod \<omega>, cod \<omega>) \<Rightarrow> cod \<omega>\<guillemotright>"
	+ using \<omega>_in_vhom hcomp_def arr_char by auto
	+ show "iso \<omega>"
	+ using \<omega>_is_iso iso_char arr_char inv_char \<omega>_in_vhom by auto
	+ show "\<And>f g h k. \<lbrakk> ide f; ide g; ide h; ide k \<rbrakk> \<Longrightarrow>
	+ (fst (f, \<alpha> (g, h, k)) \<star> snd (f, \<alpha> (g, h, k))) \<cdot>
	+ \<alpha> (f, hcomp (fst (g, h)) (snd (g, h)), k) \<cdot>
	+ (fst (\<alpha> (f, g, h), k) \<star> snd (\<alpha> (f, g, h), k)) =
	+ \<alpha> (f, g, fst (h, k) \<star> snd (h, k)) \<cdot> \<alpha> (fst (f, g) \<star> snd (f, g), h, k)"
	+ proof -
	+ fix f g h k
	+ assume f: "ide f" and g: "ide g" and h: "ide h" and k: "ide k"
	+ have 1: "VVV.arr (f, g, h) \<and> VVV.arr (g, h, k)"
	+ using f g h k VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char
	+ by simp
	+ have 2: "VVV.arr (f, g \<star> h, k)"
	+ using f g h k 1 HoHV_def VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char
	+ VxV.arrI VxVxV.arrI VxVxV_comp_eq_VVV_comp hseqI'
	+ by auto
	+ have 3: "VVV.arr (f, g, h \<star> k)"
	+ using f g h k 1 VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char
	+ VxV.arrI VxVxV.arrI VxVxV_comp_eq_VVV_comp hseqI' H.preserves_reflects_arr
	+ by auto
	+ have 4: "VVV.arr (f \<star> g, h, k)"
	+ using f g h k VVV.arr_char VV.arr_char src_def trg_def ide_char arr_char hseq_char
	+ VxV.arrI VxVxV.arrI VxVxV_comp_eq_VVV_comp
	+ by force
	+ have "(fst (f, \<alpha> (g, h, k)) \<star> snd (f, \<alpha> (g, h, k))) \<cdot>
	+ \<alpha> (f, fst (g, h) \<star> snd (g, h), k) \<cdot>
	+ (fst (\<alpha> (f, g, h), k) \<star> snd (\<alpha> (f, g, h), k)) =
	+ (f \<star> \<a>\<^sub>B[g, h, k]) \<cdot> \<a>\<^sub>B[f, g \<star> h, k] \<cdot> (\<a>\<^sub>B[f, g, h] \<star> k)"
	+ unfolding \<alpha>_def by (simp add: 1 2)
	+ also have "... = (f \<star>\<^sub>B \<a>\<^sub>B g h k) \<cdot> \<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot> (\<a>\<^sub>B f g h \<star>\<^sub>B k)"
	+ unfolding hcomp_def
	+ using f g h k src_def trg_def arr_char
	+ using assoc_closed ide_char by auto
	+ also have "... = (f \<star>\<^sub>B \<a>\<^sub>B g h k) \<cdot>\<^sub>B \<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B (\<a>\<^sub>B f g h \<star>\<^sub>B k)"
	+ proof -
	+ have "arr (f \<star>\<^sub>B \<a>\<^sub>B g h k)"
	+ using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
	+ moreover have "arr (\<a>\<^sub>B f (g \<star>\<^sub>B h) k)"
	+ using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
	+ moreover have "arr (\<a>\<^sub>B f g h \<star>\<^sub>B k)"
	+ using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
	+ moreover have "arr (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B (\<a>\<^sub>B f g h \<star>\<^sub>B k))"
	+ unfolding arr_char
	+ apply (intro conjI)
	+ using ide_char arr_char assoc_closed f g h hcomp_closed k B.HoHV_def B.HoVH_def
	+ apply (intro B.seqI)
	+ apply simp_all
	+ proof -
	+ have 1: "B.arr (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B \<a>\<^sub>B f g h \<star>\<^sub>B k)"
	+ using f g h k ide_char arr_char B.hseqI' B.HoHV_def B.HoVH_def
	+ apply (intro B.seqI)
	+ by auto
	+ show "src\<^sub>B (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B \<a>\<^sub>B f g h \<star>\<^sub>B k) = a"
	+ using 1 f g h k arr_char B.src_vcomp B.vseq_implies_hpar(1) by fastforce
	+ show "trg\<^sub>B (\<a>\<^sub>B f (g \<star>\<^sub>B h) k \<cdot>\<^sub>B \<a>\<^sub>B f g h \<star>\<^sub>B k) = a"
	+ using "1" arr_char calculation(2-3) by auto
	+ qed
	+ ultimately show ?thesis
	+ using B.ext comp_char by (metis (no_types, lifting))
	+ qed
	+ also have "... = \<a>\<^sub>B f g (h \<star>\<^sub>B k) \<cdot>\<^sub>B \<a>\<^sub>B (f \<star>\<^sub>B g) h k"
	+ using f g h k src_def trg_def arr_char ide_char B.pentagon
	+ using "4" \<alpha>_def hcomp_def by auto
	+ also have "... = \<a>\<^sub>B f g (h \<star>\<^sub>B k) \<cdot> \<a>\<^sub>B (f \<star>\<^sub>B g) h k"
	+ proof -
	+ have "arr (\<a>\<^sub>B (f \<star>\<^sub>B g) h k)"
	+ using ide_char arr_char assoc_closed f g h hcomp_closed k by simp
	+ moreover have "arr (\<a>\<^sub>B f g (h \<star>\<^sub>B k))"
	+ using ide_char arr_char assoc_closed f g h hcomp_closed k by fastforce
	+ ultimately show ?thesis
	+ using B.ext comp_char by auto
	+ qed
	+ also have "... = \<a>\<^sub>B[f, g, fst (h, k) \<star> snd (h, k)] \<cdot> \<a>\<^sub>B[fst (f, g) \<star> snd (f, g), h, k]"
	+ unfolding hcomp_def
	+ using f g h k src_def trg_def arr_char ide_char by simp
	+ also have "... = \<alpha> (f, g, fst (h, k) \<star> snd (h, k)) \<cdot> \<alpha> (fst (f, g) \<star> snd (f, g), h, k)"
	+ unfolding \<alpha>_def using 1 2 3 4 by simp
	+ finally show "(fst (f, \<alpha> (g, h, k)) \<star> snd (f, \<alpha> (g, h, k))) \<cdot>
	+ \<alpha> (f, fst (g, h) \<star> snd (g, h), k) \<cdot>
	+ (fst (\<alpha> (f, g, h), k) \<star> snd (\<alpha> (f, g, h), k)) =
	+ \<alpha> (f, g, fst (h, k) \<star> snd (h, k)) \<cdot> \<alpha> (fst (f, g) \<star> snd (f, g), h, k)"
	+ by simp
	+ qed
	+ qed
	+
	+ proposition is_monoidal_category:
	+ shows "monoidal_category (\<cdot>) (\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>) \<alpha> \<omega>"
	+ ..
	+
	+ end
	+
	+ text \<open>
	+ In a bicategory, the ``objects'' are essentially arbitrarily chosen representatives
	+ of their isomorphism classes. Choosing any other representatives results in an
	+ equivalent structure. Each object \<open>a\<close> is additionally equipped with an arbitrarily chosen
	+ unit isomorphism \<open>\<guillemotleft>\<iota> : a \<star> a \<Rightarrow> a\<guillemotright>\<close>. For any \<open>(a, \<iota>)\<close> and \<open>(a', \<iota>')\<close>,
	+ where \<open>a\<close> and \<open>a'\<close> are isomorphic to the same object, there exists a unique isomorphism
	+ \<open>\<guillemotleft>\<psi>: a \<Rightarrow> a'\<guillemotright>\<close> that is compatible with the chosen unit isomorphisms \<open>\<iota>\<close> and \<open>\<iota>'\<close>.
	+ We have already proved this property for monoidal categories, which are bicategories
	+ with just one ``object''. Here we use that already-proven property to establish its
	+ generalization to arbitary bicategories, by exploiting the fact that if \<open>a\<close> is an object
	+ in a bicategory, then the sub-bicategory consisting of all \<open>\<mu>\<close> such that
	+ \<open>src \<mu> = a = trg \<mu>\<close>, is a monoidal category.
	+
	+ At some point it would potentially be nicer to transfer the proof for monoidal
	+ categories to obtain a direct, ``native'' proof of this fact for bicategories.
	+ \<close>
	+
	+ lemma (in bicategory) unit_unique_upto_unique_iso:
	+ assumes "obj a"
	+ and "isomorphic a w"
	+ and "\<guillemotleft>\<omega> : w \<star> w \<Rightarrow> w\<guillemotright>"
	+ and "iso \<omega>"
	+ shows "\<exists>!\<psi>. \<guillemotleft>\<psi> : a \<Rightarrow> w\<guillemotright> \<and> iso \<psi> \<and> \<psi> \<cdot> \<i>[a] = \<omega> \<cdot> (\<psi> \<star> \<psi>)"
	+ proof -
	+ have \<omega>_in_hhom: "\<guillemotleft>\<omega> : a \<rightarrow> a\<guillemotright>"
	+ using assms
	+ apply (intro in_hhomI)
	+ apply auto
	+ apply (metis src_cod in_homE isomorphic_implies_hpar(3) objE)
	+ by (metis trg_cod in_homE isomorphic_implies_hpar(4) objE)
	+ interpret S: subbicategory V H \<a> \<i> src trg \<open>\<lambda>\<mu>. arr \<mu> \<and> src \<mu> = a \<and> trg \<mu> = a\<close>
	+ using assms iso_unit in_homE isoE isomorphicE VVV.arr_char VV.arr_char hseqI'
	+ apply unfold_locales
	+ apply auto[7]
	+ proof
	+ fix f g h
	+ assume f: "(arr f \<and> src f = a \<and> trg f = a) \<and> ide f"
	+ and g: "(arr g \<and> src g = a \<and> trg g = a) \<and> ide g"
	+ and h: "(arr h \<and> src h = a \<and> trg h = a) \<and> ide h"
	+ and fg: "src f = trg g" and gh: "src g = trg h"
	+ show "arr (\<a>[f, g, h])"
	+ using assms f g h fg gh by auto
	+ show "src (\<a>[f, g, h]) = a \<and> trg (\<a>[f, g, h]) = a"
	+ using assms f g h fg gh by auto
	+ show "arr (inv (\<a>[f, g, h])) \<and> src (inv (\<a>[f, g, h])) = a \<and> trg (inv (\<a>[f, g, h])) = a"
	+ using assms f g h fg gh \<alpha>.preserves_hom src_dom trg_dom by simp
	+ next
	+ fix f
	+ assume f: "arr f \<and> src f = a \<and> trg f = a"
	+ assume ide_left: "ide f"
	+ show "arr (\<ll> f) \<and> src (\<ll> f) = a \<and> trg (\<ll> f) = a"
	+ using f assms(1) \<ll>.preserves_hom src_cod [of "\<ll> f"] trg_cod [of "\<ll> f"] by simp
	+ show "arr (inv (\<ll> f)) \<and> src (inv (\<ll> f)) = a \<and> trg (inv (\<ll> f)) = a"
	+ using f ide_left assms(1) \<ll>'.preserves_hom src_dom [of "\<ll>'.map f"] trg_dom [of "\<ll>'.map f"]
	+ by simp
	+ show "arr (\<rr> f) \<and> src (\<rr> f) = a \<and> trg (\<rr> f) = a"
	+ using f assms(1) \<rr>.preserves_hom src_cod [of "\<rr> f"] trg_cod [of "\<rr> f"] by simp
	+ show "arr (inv (\<rr> f)) \<and> src (inv (\<rr> f)) = a \<and> trg (inv (\<rr> f)) = a"
	+ using f ide_left assms(1) \<rr>'.preserves_hom src_dom [of "\<rr>'.map f"] trg_dom [of "\<rr>'.map f"]
	+ by simp
	+ qed
	+ interpret S: subbicategory_at_object V H \<a> \<i> src trg a a \<open>\<i>[a]\<close>
	+ proof
	+ show "obj a" by fact
	+ show "isomorphic a a"
	+ using assms(1) isomorphic_reflexive by blast
	+ show "S.in_hom \<i>[a] (a \<star> a) a"
	+ by (metis (no_types, lifting) S.hcomp_def S.obj_char S.unit_in_vhom assms(1)
	+ obj_def obj_self_composable(1) seq_if_composable)
	+ show "iso \<i>[a]"
	+ using assms iso_unit by simp
	+ qed
	+ interpret S\<^sub>\<omega>: subbicategory_at_object V H \<a> \<i> src trg a w \<omega>
	+ proof
	+ show "obj a" by fact
	+ show "iso \<omega>" by fact
	+ show "isomorphic a w"
	+ using assms by simp
	+ show "S.in_hom \<omega> (w \<star> w) w"
	+ using assms S.arr_char S.dom_char S.cod_char \<omega>_in_hhom
	+ by (intro S.in_homI, auto)
	+ qed
	+ interpret M: monoidal_category S.comp \<open>\<lambda>\<mu>\<nu>. S.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> S.\<alpha> \<open>\<i>[a]\<close>
	+ using S.is_monoidal_category by simp
	+ interpret M\<^sub>\<omega>: monoidal_category S.comp \<open>\<lambda>\<mu>\<nu>. S.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> S.\<alpha> \<omega>
	+ using S\<^sub>\<omega>.is_monoidal_category by simp
	+ interpret M: monoidal_category_with_alternate_unit
	+ S.comp \<open>\<lambda>\<mu>\<nu>. S.hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> S.\<alpha> \<open>\<i>[a]\<close> \<omega> ..
	+ have 1: "M\<^sub>\<omega>.unity = w"
	+ using assms M\<^sub>\<omega>.unity_def S.cod_char S.arr_char
	+ by (metis (no_types, lifting) S.in_homE S\<^sub>\<omega>.\<omega>_in_vhom)
	+ have 2: "M.unity = a"
	+ using assms M.unity_def S.cod_char S.arr_char by simp
	+ have "\<exists>!\<psi>. S.in_hom \<psi> a w \<and> S.iso \<psi> \<and> S.comp \<psi> \<i>[a] = S.comp \<omega> (M.tensor \<psi> \<psi>)"
	+ using assms 1 2 M.unit_unique_upto_unique_iso M.unity_def M\<^sub>\<omega>.unity_def S.cod_char
	+ by simp
	+ show "\<exists>!\<psi>. \<guillemotleft>\<psi> : a \<Rightarrow> w\<guillemotright> \<and> iso \<psi> \<and> \<psi> \<cdot> \<i>[a] = \<omega> \<cdot> (\<psi> \<star> \<psi>)"
	+ proof -
	+ have 1: "\<And>\<psi>. S.in_hom \<psi> a w \<longleftrightarrow> \<guillemotleft>\<psi> : a \<Rightarrow> w\<guillemotright>"
	+ using assms S.in_hom_char S.arr_char
	+ by (metis (no_types, lifting) S.ideD(1) S.w_simps(1) S\<^sub>\<omega>.w_simps(1) in_homE
	+ src_dom trg_dom)
	+ moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> S.iso \<psi> \<longleftrightarrow> iso \<psi>"
	+ using assms S.in_hom_char S.arr_char S.iso_char by auto
	+ moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> M.tensor \<psi> \<psi> = \<psi> \<star> \<psi>"
	+ using assms S.in_hom_char S.arr_char S.hcomp_def by simp
	+ moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> S.comp \<psi> \<i>[a] = \<psi> \<cdot> \<i>[a]"
	+ using assms S.in_hom_char S.comp_char by auto
	+ moreover have "\<And>\<psi>. S.in_hom \<psi> a w \<Longrightarrow> S.comp \<omega> (M.tensor \<psi> \<psi>) = \<omega> \<cdot> (\<psi> \<star> \<psi>)"
	+ using assms S.in_hom_char S.arr_char S.hcomp_def S.comp_char S.dom_char S.cod_char
	+ by (metis (no_types, lifting) M\<^sub>\<omega>.arr_tensor S\<^sub>\<omega>.\<omega>_simps(1) calculation(3) ext)
	+ ultimately show ?thesis
	+ by (metis (no_types, lifting) M.unit_unique_upto_unique_iso M.unity_def M\<^sub>\<omega>.unity_def
	+ S.\<omega>_in_vhom S.in_homE S\<^sub>\<omega>.\<omega>_in_vhom)
	+ qed
	+ qed
	+
	+end
	diff --git a/thys/Bicategory/Tabulation.thy b/thys/Bicategory/Tabulation.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/Tabulation.thy
	@@ -0,0 +1,6178 @@
	+(* Title: Tabulation
	+ Author: Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
	+ Maintainer: Eugene W. Stark <stark@cs.stonybrook.edu>
	+*)
	+
	+section "Tabulations"
	+
	+theory Tabulation
	+imports CanonicalIsos InternalAdjunction ConcreteCategory
	+begin
	+
	+ text \<open>
	+ A ``tabulation'' is a kind of bicategorical limit that associates with a 1-cell \<open>r\<close>
	+ a triple \<open>(f, \<rho>, g)\<close>, where \<open>f\<close> and \<open>g\<close> are 1-cells having a common source,
	+ and \<open>\<rho>\<close> is a $2$-cell from \<open>g\<close> to \<open>r \<cdot> f\<close>, such that a certain biuniversal property
	+ is satisfied.
	+ The notion was introduced in a study of bicategories of spans and relations by
	+ Carboni, Kasangian, and Street \cite{carboni-et-al} (hereinafter, ``CKS''),
	+ who named it after a related,
	+ but different notion previously used by Freyd in his study of the algebra of relations.
	+ One can find motivation for the concept of tabulation by considering the problem of
	+ trying to find some kind of universal way of factoring a 1-cell \<open>r\<close>, up to isomorphism,
	+ as the composition \<open>g \<cdot> f\<^sup>\<close> of a map \<open>g\<close> and the right adjoint \<open>f\<^sup>\<close> of a map \<open>f\<close>.
	+ In order to be able to express this as a bicategorical limit, CKS consider,
	+ instead of an isomorphism \<open>\<guillemotleft>\<phi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>\<close>, its transpose
	+ \<open>\<rho> : g \<Rightarrow> r \<star> f\<close> under the adjunction \<open>f \<stileturn> f\<^sup>*\<close>.
	+ \<close>
	+
	+ subsection "Definition of Tabulation"
	+
	+ text \<open>
	+ The following locale sets forth the ``signature'' of the data involved in a tabulation,
	+ and establishes some basic facts.
	+$$\xymatrix{
	+ & \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \xtwocell[ddd]{}\omit{^\rho}
	+ \ar[ddl] _{g}
	+ \ar[ddr] ^{f}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll] ^{r}
	+ \\
	+ &
	+}$$
	+ \<close>
	+
	+ locale tabulation_data =
	+ bicategory +
	+ fixes r :: 'a
	+ and \<rho> :: 'a
	+ and f :: 'a
	+ and g :: 'a
	+ assumes ide_base: "ide r"
	+ and ide_leg0: "ide f"
	+ and tab_in_vhom': "\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>"
	+ begin
	+
	+ lemma base_in_hom [intro]:
	+ shows "\<guillemotleft>r : src r \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>r : r \<Rightarrow> r\<guillemotright>"
	+ using ide_base by auto
	+
	+ lemma base_simps [simp]:
	+ shows "ide r" and "arr r"
	+ and "dom r = r" and "cod r = r"
	+ using ide_base by auto
	+
	+ lemma tab_in_hom [intro]:
	+ shows "\<guillemotleft>\<rho> : src f \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>"
	+ using tab_in_vhom' src_dom [of \<rho>] trg_dom [of \<rho>] base_in_hom apply auto
	+ by (metis arr_cod comp_cod_arr hcomp_simps(1-2) in_hhom_def in_homE src_cod
	+ vseq_implies_hpar(2))
	+
	+ lemma ide_leg1:
	+ shows "ide g"
	+ using tab_in_hom by auto
	+
	+ lemma leg1_in_hom [intro]:
	+ shows "\<guillemotleft>g : src f \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>g : g \<Rightarrow> g\<guillemotright>"
	+ using ide_leg1 apply auto
	+ using tab_in_hom ide_dom [of \<rho>]
	+ apply (elim conjE in_homE) by auto
	+
	+ lemma leg1_simps [simp]:
	+ shows "ide g" and "arr g"
	+ and "src g = src f" and "trg g = trg r"
	+ and "dom g = g"and "cod g = g"
	+ using ide_leg1 leg1_in_hom by auto
	+
	+ lemma tab_simps [simp]:
	+ shows "arr \<rho>" and "src \<rho> = src f" and "trg \<rho> = trg r"
	+ and "dom \<rho> = g" and "cod \<rho> = r \<star> f"
	+ using tab_in_hom by auto
	+
	+ lemma leg0_in_hom [intro]:
	+ shows "\<guillemotleft>f : src f \<rightarrow> src r\<guillemotright>" and "\<guillemotleft>f : f \<Rightarrow> f\<guillemotright>"
	+ using ide_leg0 apply auto
	+ using tab_in_hom ide_cod [of \<rho>] hseq_char [of r f]
	+ apply (elim conjE in_homE) by auto
	+
	+ lemma leg0_simps [simp]:
	+ shows "ide f" and "arr f"
	+ and "trg f = src r"
	+ and "dom f = f" and "cod f = f"
	+ using ide_leg0 leg0_in_hom by auto
	+
	+ text \<open>
	+ The following function, which composes \<open>\<rho>\<close> with a 2-cell \<open>\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>\<close> to obtain
	+ a 2-cell \<open>\<guillemotleft>(r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"\<close>,
	+ occurs frequently in the sequel.
	+ \<close>
	+
	+ abbreviation (input) composite_cell
	+ where "composite_cell w \<theta> \<equiv> (r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w)"
	+
	+ lemma composite_cell_in_hom:
	+ assumes "ide w" and "\<guillemotleft>w : src u \<rightarrow> src f\<guillemotright>" and "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
	+ shows "\<guillemotleft>composite_cell w \<theta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
	+ proof (intro comp_in_homI)
	+ show "\<guillemotleft>\<rho> \<star> w : g \<star> w \<Rightarrow> (r \<star> f) \<star> w\<guillemotright>"
	+ using assms tab_in_hom
	+ apply (elim conjE in_hhomE in_homE)
	+ by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<a>[r, f, w] : (r \<star> f) \<star> w \<Rightarrow> r \<star> f \<star> w\<guillemotright>"
	+ using assms ide_base ide_leg0 tab_in_hom by fastforce
	+ show "\<guillemotleft>r \<star> \<theta> : r \<star> f \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
	+ using assms ide_base ide_leg0 tab_in_hom hseqI'
	+ apply (elim conjE in_hhomE in_homE)
	+ by (intro hcomp_in_vhom, auto)
	+ qed
	+
	+ text \<open>
	+ We define some abbreviations for various combinations of conditions that occur in the
	+ hypotheses and conclusions of the tabulation axioms.
	+ \<close>
	+
	+ abbreviation (input) uw\<theta>\<omega>
	+ where "uw\<theta>\<omega> u w \<theta> \<omega> \<equiv> ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
	+
	+ abbreviation (input) uw\<theta>\<omega>\<nu>
	+ where "uw\<theta>\<omega>\<nu> u w \<theta> \<omega> \<nu> \<equiv>
	+ ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ (r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> = \<omega>"
	+
	+ abbreviation (input) uw\<theta>w'\<theta>'\<beta>
	+ where "uw\<theta>w'\<theta>'\<beta> u w \<theta> w' \<theta>' \<beta> \<equiv>
	+ ide u \<and> ide w \<and> ide w' \<and>
	+ \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright> \<and>
	+ (r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) = (r \<star> \<theta>') \<cdot> \<a>[r, f, w'] \<cdot> (\<rho> \<star> w') \<cdot> \<beta>"
	+
	+ end
	+
	+ text \<open>
	+ CKS define two notions of tabulation.
	+ The first, which they call simply ``tabulation'', is restricted to triples \<open>(f, \<rho>, g)\<close>
	+ where the ``input leg'' \<open>f\<close> is a map, and assumes only a weak form of the biuniversal
	+ property that only applies to \<open>(u, \<omega>, v)\<close> for which u is a map.
	+ The second notion, which they call ``wide tabulation'', concerns arbitrary \<open>(f, \<rho>, g)\<close>,
	+ and assumes a strong form of the biuniversal property that applies to all \<open>(u, \<omega>, v)\<close>.
	+ On its face, neither notion implies the other: ``tabulation'' has the stronger assumption
	+ that \<open>f\<close> is a map, but requires a weaker biuniversal property, and ``wide tabulation''
	+ omits the assumption on \<open>f\<close>, but requires a stronger biuniversal property.
	+ CKS Proposition 1(c) states that if \<open>(f, \<rho>, g)\<close> is a wide tabulation,
	+ then \<open>f\<close> is automatically a map. This is in fact true, but it took me a long time to
	+ reconstruct the details of the proof.
	+
	+ CKS' definition of ``bicategory of spans'' uses their notion ``tabulation'',
	+ presumably because it is only applied in situations where maps are involved and it is more
	+ desirable to have axioms that involve a weaker biuniversal property rather than a stronger one.
	+ However I am more interested in ``wide tabulation'', as it is in some sense the nicer notion,
	+ and since I have had to establish various kinds of preservation results that I don't want
	+ to repeat for both tabulation and wide tabulation, I am using wide tabulation everywhere,
	+ calling it simply ``tabulation''. The fact that the ``input leg'' of a tabulation must
	+ be a map is an essential ingredient throughout.
	+
	+ I have attempted to follow CKS variable naming conventions as much as possible in this
	+ development to avoid confusion when comparing with their paper, even though these are
	+ sometimes at odds with what I have been using elsewhere in this document.
	+ \<close>
	+
	+ locale tabulation =
	+ tabulation_data +
	+ assumes T1: "\<And>u \<omega>.
	+ \<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
	+ \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
	+ and T2: "\<And>u w w' \<theta> \<theta>' \<beta>.
	+ \<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
	+ composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
	+ \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+
	+ text \<open>
	+$$
	+\textbf{T1:}\qquad\qquad
	+\xy/u67pt/
	+\xymatrix{
	+ & {\scriptstyle{{\rm src}~\omega}}
	+ \xlowertwocell[ddddl]{}_{{\rm dom}~\omega\hspace{20pt}}{^\nu}
	+ \xuppertwocell[ddddr]{}^{u}{^\theta}
	+ \ar@ {.>}[dd]^{w}
	+ \\
	+ \\
	+ & \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \xtwocell[ddd]{}\omit{^\rho}
	+ \ar[ddl] _{g}
	+ \ar[ddr] ^{f}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll] ^{r}
	+ \\
	+ &
	+}
	+\endxy
	+\;\;=\;\;
	+\xy/u33pt/
	+\xymatrix{
	+ & \scriptstyle{{\rm src}~\omega} \xtwocell[ddd]{}\omit{^\omega}
	+ \ar[ddl] _{{\rm dom}~\omega}
	+ \ar[ddr] ^{u}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll] ^{r}
	+ \\
	+ &
	+}
	+\endxy
	+$$
	+ \<close>
	+
	+ text \<open>
	+ The following definition includes the additional axiom \<open>T0\<close>, which states that
	+ the ``input leg'' \<open>f\<close> is a map.
	+ \<close>
	+
	+ locale tabulation_data_with_T0 =
	+ tabulation_data +
	+ T0: map_in_bicategory V H \<a> \<i> src trg f
	+ begin
	+
	+ abbreviation \<eta> where "\<eta> \<equiv> T0.\<eta>"
	+ abbreviation \<epsilon> where "\<epsilon> \<equiv> T0.\<epsilon>"
	+
	+ text \<open>
	+ If \<open>\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>\<close> is a 2-cell and \<open>f\<close> is a map, then \<open>\<guillemotleft>T0.trnr\<^sub>\<epsilon> r \<rho> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>\<close>,
	+ where \<open>T0.trnr\<^sub>\<epsilon> r \<rho>\<close> is the adjoint transpose of \<open>\<rho>\<close>.
	+ We will show (CKS Proposition 1(d)) that if \<open>\<rho>\<close> is a tabulation,
	+ then \<open>\<psi> = T0.trnr\<^sub>\<epsilon> r \<rho>\<close> is an isomorphism. However, regardless of whether \<open>\<rho>\<close> is a
	+ tabulation, the mapping \<open>\<rho> \<mapsto> \<psi>\<close> is injective, and we can recover \<open>\<rho>\<close> by the formula:
	+ \<open>\<rho> = (\<psi> \<star> f) \<cdot> T0.trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)\<close>. The proof requires only \<open>T0\<close> and the ``syntactic''
	+ properties of the tabulation data, and in particular does not require the tabulation
	+ conditions \<open>T1\<close> and \<open>T2\<close>. In case \<open>\<rho>\<close> is in fact a tabulation, then this formula can
	+ be interpreted as expressing that \<open>\<rho>\<close> is obtained by transposing the identity
	+ \<open>\<guillemotleft>g \<star> f\<^sup>* : g \<star> f\<^sup>* \<Rightarrow> g \<star> f\<^sup>\<guillemotright>\<close> to obtain a 2-cell \<open>\<guillemotleft>T0.trnr\<^sub>\<eta> g (g \<star> f\<^sup>) : g \<Rightarrow> (g \<star> f\<^sup>*) \<star> f\<guillemotright>\<close>
	+ (which may be regarded as the canonical tabulation of \<open>g \<star> f\<^sup>*\<close>), and then composing
	+ with the isomorphism \<open>\<guillemotleft>\<psi> \<star> f : (g \<star> f\<^sup>*) \<star> f \<Rightarrow> r \<star> f\<guillemotright>\<close> to obtain a tabulation of \<open>r\<close>.
	+ This fact will end up being very important in establishing the characterization of
	+ bicategories of spans. Strangely, CKS doesn't make any explicit mention of it.
	+ \<close>
	+
	+ lemma rep_in_hom [intro]:
	+ shows "\<guillemotleft>T0.trnr\<^sub>\<epsilon> r \<rho> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>"
	+ proof (unfold T0.trnr\<^sub>\<epsilon>_def, intro comp_in_homI)
	+ show "\<guillemotleft>\<rho> \<star> f\<^sup>* : g \<star> f\<^sup>* \<Rightarrow> (r \<star> f) \<star> f\<^sup>*\<guillemotright>"
	+ using tab_in_hom T0.antipar(1) hseqI' by auto
	+ show "\<guillemotleft>\<a>[r, f, f\<^sup>] : (r \<star> f) \<star> f\<^sup> \<Rightarrow> r \<star> f \<star> f\<^sup>*\<guillemotright>"
	+ using T0.antipar(1) T0.antipar(2) by auto
	+ show "\<guillemotleft>r \<star> \<epsilon> : r \<star> f \<star> f\<^sup>* \<Rightarrow> r \<star> src r\<guillemotright>"
	+ using T0.antipar by (intro hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<r>[r] : r \<star> src r \<Rightarrow> r\<guillemotright>"
	+ by auto
	+ qed
	+
	+ lemma \<rho>_in_terms_of_rep:
	+ shows "\<rho> = (T0.trnr\<^sub>\<epsilon> r \<rho> \<star> f) \<cdot> T0.trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)"
	+ proof -
	+ have "(T0.trnr\<^sub>\<epsilon> r \<rho> \<star> f) \<cdot> T0.trnr\<^sub>\<eta> g (g \<star> f\<^sup>*) =
	+ (\<r>[r] \<cdot> composite_cell f\<^sup>* \<epsilon> \<star> f) \<cdot> ((g \<star> f\<^sup>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>, f] \<cdot> (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
	+ unfolding T0.trnr\<^sub>\<epsilon>_def T0.trnr\<^sub>\<eta>_def by simp
	+ text \<open>
	+$$
	+\xy/u67pt/
	+\xymatrix{
	+ & \scriptstyle{{\rm src}~g \;=\;{\rm src}~f}
	+ \ar[ddl]_{g} \ar[ddr]^{f} \xtwocell[ddd]{}\omit{^\rho}
	+ &
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll]^{r}
	+ \\
	+ & &
	+}
	+\endxy
	+\;\;=\;\;
	+\xy/u133pt/
	+\xymatrix{
	+ & & \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \ar[dd]
	+ \xtwocell[dddddddl]{}\omit{^\rho}
	+ \xlowertwocell[ddddll]{}_{g}{^{\hspace{20pt}{\rm r}^{-1}[g]}}
	+ \xuppertwocell[ddddrr]{}^{f}{\omit} & &
	+ \xtwocell[dddddddlll]{}\omit{^\epsilon}
	+ \xtwocell[ddddll]{}\omit{^\eta}
	+ \\
	+ & \\
	+ & & \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \ar[dd]^{f} \ar[ddll]_{g}
	+ & \\
	+ & & & \\
	+ \scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll]^{r}
	+ & &
	+ \scriptstyle{{\rm src}~r} \ar[ll] \ar[uull]_{f^\ast}
	+ \xuppertwocell[llll]{}^{r}<20>{^{\hspace{20pt}{\rm r}[r]}}
	+ \\
	+ & & \\
	+ & & \\
	+ & & & & \\
	+}
	+\endxy
	+$$
	+ \<close>
	+ also have "... = (\<r>[r] \<cdot> composite_cell f\<^sup>* \<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f] \<cdot> (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
	+ proof -
	+ have "((g \<star> f\<^sup>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>, f] = \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f]"
	+ using comp_cod_arr T0.antipar by simp
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = (\<r>[r] \<star> f) \<cdot> (composite_cell f\<^sup>* \<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f] \<cdot> (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
	+ using comp_assoc T0.antipar whisker_right [of "f" "\<r>[r]" "composite_cell f\<^sup>* \<epsilon>"]
	+ by fastforce
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>] \<star> f) \<cdot> ((\<rho> \<star> f\<^sup>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>*, f] \<cdot>
	+ (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
	+ using T0.antipar whisker_right [of "f" "(r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>]" "\<rho> \<star> f\<^sup>"] comp_assoc
	+ by fastforce
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[r, f, f\<^sup>*] \<star> f) \<cdot>
	+ ((\<rho> \<star> f\<^sup>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>, f] \<cdot> (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
	+ using T0.antipar whisker_right [of "f" "r \<star> \<epsilon>" "\<a>[r, f, f\<^sup>*]"] comp_assoc by fastforce
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[r, f, f\<^sup>*] \<star> f) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>, f] \<cdot> (\<rho> \<star> f\<^sup> \<star> f) \<cdot> (g \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
	+ proof -
	+ have "((\<rho> \<star> f\<^sup>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sup>, f] = \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>, f] \<cdot> (\<rho> \<star> f\<^sup> \<star> f)"
	+ using assoc'_naturality [of \<rho> "f\<^sup>*" "f"] T0.antipar by simp
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
	+ (\<a>[r, f, f\<^sup>] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>, f] \<cdot>
	+ ((r \<star> f) \<star> \<eta>) \<cdot> (\<rho> \<star> src (f)) \<cdot> \<r>\<^sup>-\<^sup>1[g]"
	+ proof -
	+ have "(\<rho> \<star> f\<^sup>* \<star> f) \<cdot> (g \<star> \<eta>) = ((r \<star> f) \<star> \<eta>) \<cdot> (\<rho> \<star> src (f))"
	+ using comp_arr_dom comp_cod_arr T0.antipar interchange [of \<rho> "g" "f\<^sup>* \<star> f" \<eta>]
	+ interchange [of "r \<star> f" \<rho> \<eta> "src (f)"]
	+ by auto
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[r, f, f\<^sup>] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>, f] \<cdot>
	+ ((r \<star> f) \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f] \<cdot> \<rho>"
	+ using runit'_naturality [of \<rho>] by simp
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f] \<cdot>
	+ ((r \<star> f) \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f] \<cdot> \<rho>"
	+ proof -
	+ have "(\<a>[r, f, f\<^sup>] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>, f] =
	+ \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f]"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>*, f] =
	+ (\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f]) \<cdot> \<a>[r, f, f\<^sup> \<star> f]"
	+ using pentagon' [of r "f" "f\<^sup>*" "f"] T0.antipar iso_inv_iso iso_assoc comp_assoc
	+ invert_side_of_triangle(2)
	+ [of "((\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>, f]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f])"
	+ "\<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>, f]" "\<a>\<^sup>-\<^sup>1[r, f, f\<^sup> \<star> f]"]
	+ by fastforce
	+ hence "(\<a>[r, f, f\<^sup>] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sup>, f] =
	+ ((\<a>[r, f, f\<^sup>] \<star> f) \<cdot> (\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>] \<star> f)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f]"
	+ using comp_assoc by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f]) \<cdot> \<a>[r, f, f\<^sup>* \<star> f]"
	+ proof -
	+ have "(\<a>[r, f, f\<^sup>] \<star> f) \<cdot> (\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f] =
	+ ((r \<star> f \<star> f\<^sup>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>, f]"
	+ using comp_cod_arr comp_assoc iso_assoc comp_arr_inv T0.antipar
	+ whisker_right [of "f" "\<a>[r, f, f\<^sup>]" "\<a>\<^sup>-\<^sup>1[r, f, f\<^sup>]"] comp_assoc_assoc'
	+ by simp
	+ also have "... = \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f]"
	+ using comp_cod_arr T0.antipar by auto
	+ finally show ?thesis
	+ using comp_assoc by metis
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = (\<r>[r] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<epsilon> \<star> f) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]) \<cdot> (r \<star> f \<star> \<eta>) \<cdot> \<a>[r, f, src (f)] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f] \<cdot> \<rho>"
	+ proof -
	+ have "((r \<star> \<epsilon>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sup>*, f] = \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<epsilon> \<star> f)"
	+ using assoc'_naturality [of r \<epsilon> "f"] by auto
	+ moreover have "\<a>[r, f, f\<^sup>* \<star> f] \<cdot> ((r \<star> f) \<star> \<eta>) = (r \<star> f \<star> \<eta>) \<cdot> \<a>[r, f, src (f)]"
	+ using assoc_naturality [of r "f" \<eta>] T0.antipar by auto
	+ ultimately show ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = (\<r>[r] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> (\<epsilon> \<star> f) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<cdot> (f \<star> \<eta>)) \<cdot> \<a>[r, f, src (f)] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f] \<cdot> \<rho>"
	+ proof -
	+ have "seq \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] (f \<star> \<eta>)"
	+ using T0.antipar by force
	+ moreover have "seq (\<epsilon> \<star> f) (\<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<cdot> (f \<star> \<eta>))"
	+ using T0.antipar by fastforce
	+ ultimately have "(r \<star> \<epsilon> \<star> f) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]) \<cdot> (r \<star> f \<star> \<eta>) =
	+ r \<star> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<cdot> (f \<star> \<eta>)"
	+ using T0.antipar whisker_left [of r "\<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f]" "f \<star> \<eta>"]
	+ whisker_left [of r "\<epsilon> \<star> f" "\<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<cdot> (f \<star> \<eta>)"]
	+ by auto
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = (\<r>[r] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot>
	+ \<a>[r, f, src (f)] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f] \<cdot> \<rho>"
	+ using T0.triangle_left by simp
	+ also have "... = ((\<r>[r] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f])) \<cdot>
	+ ((r \<star> \<r>[f]) \<cdot> \<a>[r, f, src (f)] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f]) \<cdot> \<rho>"
	+ using whisker_left [of r "\<l>\<^sup>-\<^sup>1[f]" "\<r>[f]"] comp_assoc by simp
	+ also have "... = ((r \<star> \<l>[f]) \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f])) \<cdot> (\<r>[r \<star> f] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f]) \<cdot> \<rho>"
	+ using triangle' [of r "f"] runit_hcomp [of r "f"] comp_assoc by simp
	+ also have "... = \<rho>"
	+ proof -
	+ have "(r \<star> \<l>[f]) \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f]) = r \<star> f"
	+ using iso_lunit comp_arr_inv' whisker_left [of r "\<l>[f]" "\<l>\<^sup>-\<^sup>1[f]"] by simp
	+ moreover have "(\<r>[r \<star> f] \<cdot> \<r>\<^sup>-\<^sup>1[r \<star> f]) = r \<star> f"
	+ using iso_runit inv_is_inverse comp_arr_inv' by auto
	+ ultimately show ?thesis
	+ using comp_cod_arr by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+
	+ end
	+
	+ text \<open>
	+ The following corresponds to what CKS call ``tabulation''; it supposes axiom \<open>T0\<close>,
	+ but involves weaker versions of \<open>T1\<close> and \<open>T2\<close>. I am calling it ``narrow tabulation''.
	+ \<close>
	+
	+ locale narrow_tabulation =
	+ tabulation_data_with_T0 +
	+ assumes T1: "\<And>u \<omega>.
	+ \<lbrakk> is_left_adjoint u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
	+ \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
	+ and T2: "\<And>u w w' \<theta> \<theta>' \<beta>.
	+ \<lbrakk> is_left_adjoint u; ide w; ide w';
	+ \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
	+ composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
	+ \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+
	+ text \<open>
	+ The next few locales are used to bundle up some routine consequences of
	+ the situations described by the hypotheses and conclusions of the tabulation axioms,
	+ so we don't have to keep deriving them over and over again in each context,
	+ and also so as to keep the simplification rules oriented consistently with each other.
	+ \<close>
	+
	+ locale uw\<theta> =
	+ tabulation_data +
	+ fixes u :: 'a
	+ and w :: 'a
	+ and \<theta> :: 'a
	+ assumes uw\<theta>: "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
	+ begin
	+
	+ lemma ide_u:
	+ shows "ide u"
	+ using uw\<theta> by force
	+
	+ lemma u_in_hom [intro]:
	+ shows "\<guillemotleft>u : src u \<rightarrow> src r\<guillemotright>"
	+ using uw\<theta> ide_u ide_cod [of \<theta>] hseq_char [of f w]
	+ apply (intro in_hhomI, simp_all)
	+ by (metis arr_dom leg0_simps(3) in_homE trg_cod trg_dom hcomp_simps(2))
	+
	+ lemma u_simps [simp]:
	+ shows "ide u" and "arr u"
	+ and "trg u = src r"
	+ and "dom u = u" and "cod u = u"
	+ using ide_u u_in_hom by auto
	+
	+ lemma ide_w:
	+ shows "ide w"
	+ using uw\<theta> by auto
	+
	+ lemma w_in_hom [intro]:
	+ shows "\<guillemotleft>w : src u \<rightarrow> src f\<guillemotright>" and "\<guillemotleft>w : w \<Rightarrow> w\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>w : w \<Rightarrow> w\<guillemotright>"
	+ using ide_w by auto
	+ show "\<guillemotleft>w : src u \<rightarrow> src f\<guillemotright>"
	+ proof
	+ show "arr w" using ide_w by simp
	+ show "src w = src u"
	+ using uw\<theta> ide_dom [of \<theta>] hseq_char [of f w]
	+ by (metis arr_dom in_homE src_cod src_dom hcomp_simps(1))
	+ show "trg w = src f"
	+ using uw\<theta> ide_dom [of \<theta>] hseq_char [of f w]
	+ by (metis arr_dom in_homE)
	+ qed
	+ qed
	+
	+ lemma w_simps [simp]:
	+ shows "ide w" and "arr w"
	+ and "src w = src u" and "trg w = src f"
	+ and "dom w = w" and "cod w = w"
	+ using ide_w w_in_hom by auto
	+
	+ lemma \<theta>_in_hom [intro]:
	+ shows "\<guillemotleft>\<theta> : src u \<rightarrow> src r\<guillemotright>" and "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
	+ using uw\<theta> by simp
	+ show "\<guillemotleft>\<theta> : src u \<rightarrow> src r\<guillemotright>"
	+ using uw\<theta> src_dom trg_dom hcomp_simps(1-2) by fastforce
	+ qed
	+
	+ lemma \<theta>_simps [simp]:
	+ shows "arr \<theta>" and "src \<theta> = src u" and "trg \<theta> = src r"
	+ and "dom \<theta> = f \<star> w" and "cod \<theta> = u"
	+ using \<theta>_in_hom by auto
	+
	+ end
	+
	+ locale uw\<theta>\<omega> =
	+ uw\<theta> +
	+ fixes \<omega> :: 'a
	+ assumes uw\<theta>\<omega>: "uw\<theta>\<omega> u w \<theta> \<omega>"
	+ begin
	+
	+ lemma \<omega>_in_hom [intro]:
	+ shows "\<guillemotleft>\<omega> : src w \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<omega> : src w \<rightarrow> trg r\<guillemotright>"
	+ using uw\<theta>\<omega> src_cod [of \<omega>] trg_cod [of \<omega>]
	+ apply (elim conjE in_homE)
	+ by simp
	+ show "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
	+ using uw\<theta>\<omega> by auto
	+ qed
	+
	+ lemma \<omega>_simps [simp]:
	+ shows "arr \<omega>" and "src \<omega> = src w" and "trg \<omega> = trg r"
	+ and "cod \<omega> = r \<star> u"
	+ using \<omega>_in_hom by auto
	+
	+ end
	+
	+ locale uw\<theta>\<omega>\<nu> =
	+ uw\<theta> +
	+ fixes \<omega> :: 'a
	+ and \<nu> :: 'a
	+ assumes uw\<theta>\<omega>\<nu>: "uw\<theta>\<omega>\<nu> u w \<theta> \<omega> \<nu>"
	+ begin
	+
	+ lemma \<nu>_in_hom [intro]:
	+ shows "\<guillemotleft>\<nu> : src u \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright>"
	+ using uw\<theta>\<omega>\<nu> by auto
	+ show "\<guillemotleft>\<nu> : src u \<rightarrow> trg r\<guillemotright>"
	+ proof
	+ show 1: "arr \<nu>"
	+ using uw\<theta>\<omega>\<nu> by auto
	+ show "src \<nu> = src u"
	+ proof -
	+ have "src \<nu> = src (cod \<nu>)"
	+ using 1 uw\<theta>\<omega>\<nu> src_cod [of \<nu>] by simp
	+ also have "... = src u"
	+ using uw\<theta>\<omega>\<nu> by auto
	+ finally show ?thesis by simp
	+ qed
	+ show "trg \<nu> = trg r"
	+ proof -
	+ have "trg \<nu> = trg (cod \<nu>)"
	+ using 1 uw\<theta>\<omega>\<nu> src_cod [of \<nu>] by simp
	+ also have "... = trg r"
	+ using uw\<theta>\<omega>\<nu> by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+
	+ lemma \<nu>_simps [simp]:
	+ shows "iso \<nu>" and "arr \<nu>" and "src \<nu> = src u" and "trg \<nu> = trg r"
	+ and "cod \<nu> = g \<star> w"
	+ using uw\<theta>\<omega>\<nu> \<nu>_in_hom by auto
	+
	+ sublocale uw\<theta>\<omega>
	+ proof (unfold_locales, intro conjI)
	+ show "ide w"
	+ using uw\<theta>\<omega>\<nu> by simp
	+ show "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
	+ using uw\<theta>\<omega>\<nu> by simp
	+ have "\<guillemotleft>(r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> : dom \<nu> \<Rightarrow> r \<star> u\<guillemotright>"
	+ using ide_base ide_leg0 ide_w by fastforce
	+ thus "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
	+ using uw\<theta>\<omega>\<nu> by auto
	+ qed
	+
	+ end
	+
	+
	+ locale uw\<theta>w'\<theta>' =
	+ tabulation_data V H \<a> \<iota> src trg r \<rho> f g +
	+ uw\<theta>: uw\<theta> V H \<a> \<iota> src trg r \<rho> f g u w \<theta> +
	+ uw'\<theta>': uw\<theta> V H \<a> \<iota> src trg r \<rho> f g u w' \<theta>'
	+ for V :: "'a comp" (infixr "\<cdot>" 55)
	+ and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 53)
	+ and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
	+ and \<iota> :: "'a \<Rightarrow> 'a" ("\<i>[_]")
	+ and src :: "'a \<Rightarrow> 'a"
	+ and trg :: "'a \<Rightarrow> 'a"
	+ and r :: 'a
	+ and \<rho> :: 'a
	+ and f :: 'a
	+ and g :: 'a
	+ and u :: 'a
	+ and w :: 'a
	+ and \<theta> :: 'a
	+ and w' :: 'a
	+ and \<theta>' :: 'a
	+
	+ locale uw\<theta>w'\<theta>'\<gamma> =
	+ uw\<theta>w'\<theta>' +
	+ fixes \<gamma> :: 'a
	+ assumes \<gamma>_in_vhom: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
	+ and "\<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ begin
	+
	+ lemma \<gamma>_in_hom [intro]:
	+ shows "\<guillemotleft>\<gamma> : src u \<rightarrow> src f\<guillemotright>" and "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
	+ using \<gamma>_in_vhom by simp
	+ show "\<guillemotleft>\<gamma> : src u \<rightarrow> src f\<guillemotright>"
	+ proof
	+ show "arr \<gamma>"
	+ using \<gamma>_in_vhom by auto
	+ show "src \<gamma> = src u"
	+ using \<gamma>_in_vhom src_dom [of \<gamma>]
	+ apply (elim in_homE) by simp
	+ show "trg \<gamma> = src f"
	+ using \<gamma>_in_vhom trg_dom [of \<gamma>]
	+ apply (elim in_homE) by simp
	+ qed
	+ qed
	+
	+ lemma \<gamma>_simps [simp]:
	+ shows "arr \<gamma>"
	+ and "src \<gamma> = src u" and "trg \<gamma> = src f"
	+ and "dom \<gamma> = w" and "cod \<gamma> = w'"
	+ using \<gamma>_in_hom by auto
	+
	+ end
	+
	+ locale uw\<theta>w'\<theta>'\<beta> =
	+ uw\<theta>w'\<theta>' +
	+ fixes \<beta> :: 'a
	+ assumes uw\<theta>w'\<theta>'\<beta>: "uw\<theta>w'\<theta>'\<beta> u w \<theta> w' \<theta>' \<beta>"
	+ begin
	+
	+ lemma \<beta>_in_hom [intro]:
	+ shows "\<guillemotleft>\<beta> : src u \<rightarrow> trg r\<guillemotright>" and "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
	+ proof -
	+ show "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
	+ using uw\<theta>w'\<theta>'\<beta> by auto
	+ show "\<guillemotleft>\<beta> : src u \<rightarrow> trg r\<guillemotright>"
	+ using uw\<theta>w'\<theta>'\<beta> src_dom [of \<beta>] trg_dom [of \<beta>] hseq_char [of g w]
	+ apply (elim conjE in_homE) by auto
	+ qed
	+
	+ lemma \<beta>_simps [simp]:
	+ shows "arr \<beta>" and "src \<beta> = src u" and "trg \<beta> = trg r"
	+ and "dom \<beta> = g \<star> w" and "cod \<beta> = g \<star> w'"
	+ using \<beta>_in_hom by auto
	+
	+ end
	+
	+ subsection "Tabulations yield Factorizations"
	+
	+ text \<open>
	+ If \<open>(f, \<rho>, g)\<close> is a (wide) tabulation, then \<open>f\<close> is automatically a map;
	+ this is CKS Proposition 1(c).
	+ The proof sketch provided by CKS is only three lines long, and for a long time I
	+ was only able to prove one of the two triangle identities.
	+ Finally, after gaining a lot of experience with the definitions I saw how to prove
	+ the other.
	+ CKS say nothing about the extra step that seems to be required.
	+ \<close>
	+
	+ context tabulation
	+ begin
	+
	+ text \<open>
	+ The following is used in order to allow us to apply the coherence theorem
	+ to shortcut proofs of equations between canonical arrows.
	+ \<close>
	+
	+ interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ lemma satisfies_T0:
	+ shows "is_left_adjoint f"
	+ proof -
	+ text \<open>
	+ The difficulty is filling in details left out by CKS, and accounting for the
	+ fact that they have suppressed unitors and associators everywhere.
	+ In addition, their typography generally uses only parentheses, with no explicit
	+ operation symbols to distinguish between horizontal and vertical composition.
	+ In some cases, for example the statement of T2 in the definition of tabulation,
	+ this makes it difficult for someone not very experienced with the definitions to
	+ reconstruct the correct formulas.
	+ \<close>
	+ text \<open>
	+ CKS say to first apply \<open>T1\<close> with \<open>u = src r\<close>, \<open>v = r\<close>, and \<open>\<rho>' = r\<close>.
	+ However, \<open>\<guillemotleft>r : r \<Rightarrow> r\<guillemotright>\<close>, not \<open>\<guillemotleft>r : r \<Rightarrow> r \<star> src r\<guillemotright>\<close>, so we have to take \<open>\<rho>' = \<r>\<^sup>-\<^sup>1[r]\<close>.
	+ \<close>
	+ obtain f\<^sub>a \<epsilon> \<nu>
	+ where f\<^sub>a: "ide f\<^sub>a \<and> \<guillemotleft>\<epsilon> : f \<star> f\<^sub>a \<Rightarrow> src r\<guillemotright> \<and> \<guillemotleft>\<nu> : r \<Rightarrow> g \<star> f\<^sub>a\<guillemotright> \<and> iso \<nu> \<and>
	+ composite_cell f\<^sub>a \<epsilon> \<cdot> \<nu> = \<r>\<^sup>-\<^sup>1[r]"
	+ using T1 [of "src r" "\<r>\<^sup>-\<^sup>1[r]"] runit'_in_hom [of r] ide_base comp_assoc by auto
	+ have f\<^sub>a': "composite_cell f\<^sub>a \<epsilon> \<cdot> \<nu> = \<r>\<^sup>-\<^sup>1[r]"
	+ using f\<^sub>a by simp
	+ have f\<^sub>a: "ide f\<^sub>a \<and> \<guillemotleft>\<epsilon> : f \<star> f\<^sub>a \<Rightarrow> src r\<guillemotright> \<and> \<guillemotleft>\<nu> : r \<Rightarrow> g \<star> f\<^sub>a\<guillemotright> \<and> iso \<nu>"
	+ using f\<^sub>a by simp
	+ have 1: "src f\<^sub>a = trg f"
	+ using f\<^sub>a f\<^sub>a' comp_assoc
	+ by (metis arr_inv leg0_simps(3) ide_base in_homE iso_runit seqE src_dom
	+ hcomp_simps(1) vseq_implies_hpar(1))
	+ have 2: "trg f\<^sub>a = src g"
	+ using f\<^sub>a by force
	+ have \<epsilon>: "\<guillemotleft>\<epsilon> : f \<star> f\<^sub>a \<Rightarrow> trg f\<guillemotright> \<and> \<guillemotleft>\<epsilon> : trg f \<rightarrow> trg f\<guillemotright> \<and>
	+ arr \<epsilon> \<and> src \<epsilon> = trg f \<and> trg \<epsilon> = trg f \<and> dom \<epsilon> = f \<star> f\<^sub>a \<and> cod \<epsilon> = trg f"
	+ using f\<^sub>a src_cod [of \<epsilon>] trg_cod [of \<epsilon>] 1 2 by fastforce
	+ have \<nu>: "\<guillemotleft>\<nu> : r \<Rightarrow> g \<star> f\<^sub>a\<guillemotright> \<and> \<guillemotleft>\<nu> : trg f \<rightarrow> trg g\<guillemotright> \<and>
	+ arr \<nu> \<and> src \<nu> = trg f \<and> trg \<nu> = trg g \<and> dom \<nu> = r \<and> cod \<nu> = g \<star> f\<^sub>a"
	+ using f\<^sub>a by force
	+ text \<open>
	+ Next, CKS say to apply \<open>T2\<close> with \<open>w = trg f\<^sub>a = src f\<close>, \<open>w' = f\<^sub>a \<star> f\<close>, \<open>u = f\<close>,
	+ to obtain the unit and the adjunction conditions, but they don't say explicitly
	+ what to use for \<open>\<theta>\<close>, \<open>\<theta>'\<close>, and \<open>\<beta>\<close>.
	+ We need \<open>\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>\<close> and \<open>\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>\<close>;
	+ \emph{i.e.}~\<open>\<guillemotleft>\<theta> : f \<star> trg f\<^sub>a \<Rightarrow> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<theta>' : f \<star> f\<^sub>a \<star> f \<Rightarrow> f\<guillemotright>\<close>.
	+ Evidently, we may take \<open>\<theta> = \<rho>[f]\<close> and \<open>\<theta>' = \<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]\<close>.
	+
	+ What should be taken for \<open>\<beta>\<close>? Reconstructing this is a little bit more difficult.
	+ \<open>T2\<close> requires \<open>\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>\<close>, hence \<open>\<guillemotleft>\<beta> : g \<star> trg f\<^sub>a \<Rightarrow> g \<star> f\<^sub>a \<star> f\<guillemotright>\<close>.
	+ We have the isomorphism \<open>\<guillemotleft>\<nu> : r \<Rightarrow> g \<star> f\<^sub>a\<guillemotright>\<close> from \<open>T1\<close>. Also \<open>\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>\<close>.
	+ So \<open>\<guillemotleft>\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g] : g \<star> trg f\<^sub>a \<Rightarrow> g \<star> f\<^sub>a \<star> f\<guillemotright>\<close>,
	+ suggesting that we take \<open>\<beta> = \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g]\<close>.
	+ Now, to apply \<open>T2\<close> we need to satisfy the equation:
	+ \[
	+ \<open>(r \<star> \<theta>) \<cdot> \<a>[r, f, trg f\<^sub>a] \<cdot> (\<rho> \<star> trg f\<^sub>a ) =
	+ (r \<star> \<theta>') \<cdot> \<a>[r, f, f\<^sub>a \<star> f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> f) \<cdot> \<beta>\<close>;
	+ \]
	+ that is, with our choice of \<open>\<theta>\<close>, \<open>\<theta>'\<close>, and \<open>\<beta>\<close>:
	+
	+ \<open>(r \<star> \<r>[f]) \<cdot> \<a>[r, f, trg f\<^sub>a] \<cdot> (\<rho> \<star> trg f\<^sub>a ) =
	+ (r \<star> \<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> \<a>[r, f, f\<^sub>a \<star> f] \<cdot> (\<rho> \<cdot> (f\<^sub>a \<star> f)) \<cdot>
	+ \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g]\<close>.
	+
	+ It is not too difficult to get the idea of showing that the left-hand side
	+ is equal to \<open>\<rho> \<cdot> \<r>[g]\<close> (note that \<open>trg f\<^sub>a = src f = src g]\<close> and \<open>trg f = src r\<close>),
	+ so we should also try to prove that the right-hand side is equal to this as well.
	+ What we have to work with is the equation:
	+ \[
	+ \<open>\<r>\<^sup>-\<^sup>1[r] = (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sub>a] \<cdot> (\<rho> \<star> f\<^sub>a ) \<cdot> \<nu>\<close>.
	+ \]
	+ After some pondering, I realized that to apply this to the right-hand side of the
	+ equation to be shown requires that we re-associate everything to the left,
	+ so that f stands alone on the right.
	+ \<close>
	+ let ?\<beta> = "\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g]"
	+ let ?\<theta> = "\<r>[f]"
	+ let ?\<theta>' = "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]"
	+ have \<beta>: "\<guillemotleft>?\<beta> : g \<star> src g \<Rightarrow> g \<star> f\<^sub>a \<star> f\<guillemotright> \<and> \<guillemotleft>?\<beta> : src f \<rightarrow> trg g\<guillemotright> \<and>
	+ src ?\<beta> = src g \<and> trg ?\<beta> = trg g \<and> dom ?\<beta> = g \<star> src g \<and> cod ?\<beta> = g \<star> f\<^sub>a \<star> f"
	+ proof -
	+ have 3: "\<guillemotleft>?\<beta> : g \<star> src g \<Rightarrow> g \<star> f\<^sub>a \<star> f\<guillemotright>"
	+ using f\<^sub>a 1 2 by fastforce
	+ moreover have "\<guillemotleft>?\<beta> : src f \<rightarrow> trg g\<guillemotright>"
	+ using 1 2 3 f\<^sub>a by auto
	+ ultimately show ?thesis
	+ by (auto simp add: in_hhom_def)
	+ qed
	+ have \<theta>': "\<guillemotleft>?\<theta>' : f \<star> f\<^sub>a \<star> f \<Rightarrow> f\<guillemotright>"
	+ using f\<^sub>a 1 2 \<epsilon> by fastforce
	+ have A: "composite_cell (trg f\<^sub>a) \<r>[f] = composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> ?\<beta>"
	+ proof -
	+ have "composite_cell (trg f\<^sub>a) \<r>[f] = \<rho> \<cdot> \<r>[g]"
	+ using 2 runit_hcomp runit_naturality [of \<rho>] comp_assoc by simp
	+ also have "... = composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> ?\<beta>"
	+ proof -
	+ have "composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> ?\<beta> =
	+ (composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> \<a>[g, f\<^sub>a, f]) \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g]"
	+ using comp_assoc by simp
	+ also have "... = \<rho> \<cdot> \<r>[g]"
	+ proof -
	+ have "(composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> \<a>[g, f\<^sub>a, f]) \<cdot> (\<nu> \<star> f) = r \<star> f"
	+ proof -
	+ have "(composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> \<a>[g, f\<^sub>a, f]) \<cdot> (\<nu> \<star> f) =
	+ \<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sub>a] \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> \<nu> \<star> f"
	+ proof -
	+ have "(composite_cell (f\<^sub>a \<star> f) ?\<theta>' \<cdot> \<a>[g, f\<^sub>a, f]) \<cdot> (\<nu> \<star> f) =
	+ (r \<star> \<l>[f]) \<cdot> (r \<star> \<epsilon> \<star> f) \<cdot>
	+ composite_cell (f\<^sub>a \<star> f) \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f))"
	+ using f\<^sub>a 1 2 \<epsilon> hseqI' whisker_left comp_assoc by auto
	+ also have "... = (\<r>[r] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<epsilon> \<star> f) \<cdot>
	+ composite_cell (f\<^sub>a \<star> f) \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f))"
	+ using f\<^sub>a 1 2 comp_assoc by (simp add: triangle')
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f] \<cdot>
	+ composite_cell (f\<^sub>a \<star> f) \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f))"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r, src r, f] \<cdot> (r \<star> \<epsilon> \<star> f) = ((r \<star> \<epsilon>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f]"
	+ using f\<^sub>a \<epsilon> assoc'_naturality [of r \<epsilon> f] by auto
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
	+ (\<a>[r, f, f\<^sub>a] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> f) \<cdot>
	+ \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)"
	+ proof -
	+ have "(\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f] \<cdot>
	+ composite_cell (f\<^sub>a \<star> f) \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)) =
	+ (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> \<a>[r, f, f\<^sub>a \<star> f]) \<cdot>
	+ (\<rho> \<star> f\<^sub>a \<star> f) \<cdot> \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)"
	+ by (simp add: comp_assoc)
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
	+ ((\<a>[r, f, f\<^sub>a] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f]) \<cdot>
	+ (\<rho> \<star> f\<^sub>a \<star> f) \<cdot> \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> \<a>[r, f, f\<^sub>a \<star> f] =
	+ (\<a>[r, f, f\<^sub>a] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f]"
	+ proof -
	+ (* No need to calculate manually, apply the coherence theorem. *)
	+ have "\<a>\<^sup>-\<^sup>1[r, f \<star> f\<^sub>a, f] \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> \<a>[r, f, f\<^sub>a \<star> f] =
	+ \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^sub>a\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sub>a\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sub>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using f\<^sub>a 1 2 \<a>'_def \<alpha>_def assoc'_eq_inv_assoc by auto
	+ also have "... = \<lbrace>(\<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sub>a\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sub>a\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
	+ using f\<^sub>a 1 2 by (intro E.eval_eqI, auto)
	+ also have "... = (\<a>[r, f, f\<^sub>a] \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f]"
	+ using f\<^sub>a 1 2 \<a>'_def \<alpha>_def assoc'_eq_inv_assoc by auto
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[r, f, f\<^sub>a] \<star> f) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> f) \<cdot> \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)"
	+ by (simp add: comp_assoc)
	+ finally show ?thesis by blast
	+ qed
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot>
	+ (\<a>[r, f, f\<^sub>a] \<star> f) \<cdot> ((\<rho> \<star> f\<^sub>a) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sub>a, f] \<cdot>
	+ \<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[r \<star> f, f\<^sub>a, f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> f) = ((\<rho> \<star> f\<^sub>a) \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sub>a, f]"
	+ using f\<^sub>a 1 2 assoc'_naturality [of \<rho> f\<^sub>a f] by auto
	+ thus ?thesis
	+ by (metis comp_assoc)
	+ qed
	+ also have "... = (\<r>[r] \<star> f) \<cdot> ((r \<star> \<epsilon>) \<star> f) \<cdot> (\<a>[r, f, f\<^sub>a] \<star> f) \<cdot>
	+ ((\<rho> \<star> f\<^sub>a) \<star> f) \<cdot> (\<nu> \<star> f)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[g, f\<^sub>a, f] \<cdot> \<a>[g, f\<^sub>a, f] = (g \<star> f\<^sub>a) \<star> f"
	+ using f\<^sub>a 1 2 comp_assoc_assoc' by auto
	+ moreover have "((g \<star> f\<^sub>a) \<star> f) \<cdot> (\<nu> \<star> f) = \<nu> \<star> f"
	+ by (simp add: \<nu> comp_cod_arr hseqI')
	+ ultimately show ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = (\<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sub>a] \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> \<nu>) \<star> f"
	+ proof -
	+ have "arr (\<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sub>a] \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> \<nu>)"
	+ using f\<^sub>a' comp_assoc by auto
	+ thus ?thesis
	+ using whisker_right by fastforce
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ also have "... = (\<r>[r] \<cdot> \<r>\<^sup>-\<^sup>1[r]) \<star> f"
	+ using f\<^sub>a' comp_assoc by simp
	+ also have "... = r \<star> f"
	+ using ide_base by (simp add: comp_arr_inv')
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using ide_leg0 ide_leg1 tab_in_hom comp_cod_arr comp_assoc tab_simps(5) arrI
	+ by metis
	+ qed
	+ finally show ?thesis by argo
	+ qed
	+ finally show ?thesis by argo
	+ qed
	+ obtain \<eta> where \<eta>: "\<guillemotleft>\<eta> : trg f\<^sub>a \<Rightarrow> f\<^sub>a \<star> f\<guillemotright> \<and> ?\<beta> = g \<star> \<eta> \<and>
	+ (\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> (f \<star> \<eta>) = \<r>[f]"
	+ using \<beta> \<theta>' A 1 2 f\<^sub>a runit_in_hom ide_leg0 ide_hcomp src.preserves_ide
	+ T2 [of "trg f\<^sub>a" "f\<^sub>a \<star> f" "\<r>[f]" f "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]" ?\<beta>] comp_assoc
	+ leg1_simps(3)
	+ by metis
	+ have \<eta>': "?\<beta> = g \<star> \<eta> \<and> (\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f]) \<cdot> (f \<star> \<eta>) = \<r>[f]"
	+ using \<eta> by simp
	+ have \<eta>: "\<guillemotleft>\<eta> : trg f\<^sub>a \<Rightarrow> f\<^sub>a \<star> f\<guillemotright> \<and> \<guillemotleft>\<eta> : src f \<rightarrow> src f\<guillemotright> \<and>
	+ arr \<eta> \<and> src \<eta> = src f \<and> trg \<eta> = src f \<and> dom \<eta> = trg f\<^sub>a \<and> cod \<eta> = f\<^sub>a \<star> f"
	+ using \<eta> \<beta> 2 by force
	+
	+ have "adjunction_in_bicategory V H \<a> \<i> src trg f f\<^sub>a \<eta> \<epsilon>"
	+ proof
	+ show "ide f" using ide_leg0 by simp
	+ show "ide f\<^sub>a" using f\<^sub>a by blast
	+ show \<eta>_in_hom: "\<guillemotleft>\<eta> : src f \<Rightarrow> f\<^sub>a \<star> f\<guillemotright>"
	+ using \<eta> 2 by simp
	+ show \<epsilon>_in_hom: "\<guillemotleft>\<epsilon> : f \<star> f\<^sub>a \<Rightarrow> src f\<^sub>a\<guillemotright>"
	+ using f\<^sub>a 1 by simp
	+ show *: "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
	+ using ide_leg0 iso_lunit invert_side_of_triangle(1) \<eta>' comp_assoc by auto
	+
	+ text \<open>
	+ We have proved one of the triangle identities; now we have to show the other.
	+ This part, not mentioned by CKS, took me a while to discover.
	+ Apply \<open>T2\<close> again, this time with the following:
	+ \[\begin{array}{l}
	+ \<open>w = src f \<star> f\<^sub>a\<close>,\\
	+ \<open>\<theta> = (\<epsilon> \<star> \<epsilon>) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)\<close>,\\
	+ \<open>w' = f\<^sub>a \<star> trg\<close>,\\
	+ \<open>\<theta>' = \<epsilon> \<star> trg f\<close>,\\
	+ \<open>\<beta> = g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]\<close>
	+ \end{array}\]
	+ Then the conditions for \<open>\<gamma>\<close> are satisfied by both
	+ \<open>\<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]\<close> and \<open>(f\<^sub>a \<star> \<epsilon>) \<cdot> \<a>[f\<^sub>a, f, f\<^sub>a] \<cdot> (\<eta> \<star> f\<^sub>a)\<close> so they are equal,
	+ as required.
	+ \<close>
	+ show "(f\<^sub>a \<star> \<epsilon>) \<cdot> \<a>[f\<^sub>a, f, f\<^sub>a] \<cdot> (\<eta> \<star> f\<^sub>a) = \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"
	+ proof -
	+ let ?u = "trg f \<star> trg f"
	+ let ?w = "src f \<star> f\<^sub>a"
	+ let ?w' = "f\<^sub>a \<star> trg f"
	+ let ?\<theta> = "(\<epsilon> \<star> \<epsilon>) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)"
	+ let ?\<theta>' = "(\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f]"
	+ let ?\<beta> = "g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"
	+ let ?\<gamma> = "\<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"
	+ let ?\<gamma>' = "(f\<^sub>a \<star> \<epsilon>) \<cdot> \<a>[f\<^sub>a, f, f\<^sub>a] \<cdot> (\<eta> \<star> f\<^sub>a)"
	+ have \<theta>_eq': "?\<theta> = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ proof -
	+ have "?\<theta> = (trg f \<star> \<epsilon>) \<cdot> (\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a])) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)"
	+ using interchange [of "trg f" \<epsilon> \<epsilon> "f \<star> f\<^sub>a"] comp_arr_dom comp_cod_arr comp_assoc
	+ by (simp add: \<epsilon>)
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> (\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot>
	+ (\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]) \<cdot>
	+ (f \<star> \<eta> \<star> f\<^sub>a)"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) =
	+ \<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]"
	+ proof -
	+ have "(\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> ((\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a])) \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]) =
	+ \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"
	+ using 1 2 \<open>ide f\<^sub>a\<close> ide_leg0 iso_inv_iso iso_assoc hseqI'
	+ invert_side_of_triangle(1)
	+ [of "((\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]) \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a])"
	+ "\<a>\<^sup>-\<^sup>1[f \<star> f\<^sub>a, f, f\<^sub>a]" "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"]
	+ pentagon' comp_assoc by auto
	+ hence "(\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> ((\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a])) =
	+ \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a])"
	+ using 1 2 \<open>ide f\<^sub>a\<close> iso_inv_iso
	+ invert_side_of_triangle(2)
	+ [of "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]" "\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> ((\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a])"
	+ "f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]"]
	+ by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> ((\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot> \<a>[f \<star> f\<^sub>a, f, f\<^sub>a]) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a] \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)"
	+ using comp_assoc by simp
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot>
	+ ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (f \<star> \<eta>) \<star> f\<^sub>a) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ proof -
	+ have "((\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot> \<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a) =
	+ (\<a>[trg f, f, f\<^sub>a] \<cdot> ((\<epsilon> \<star> f) \<star> f\<^sub>a)) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot>
	+ ((f \<star> \<eta>) \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ using assoc_naturality [of \<epsilon> f f\<^sub>a] assoc'_naturality [of f \<eta> f\<^sub>a]
	+ by (simp add: 2 \<epsilon> \<eta> \<open>ide f\<^sub>a\<close> comp_assoc)
	+ also have "... = \<a>[trg f, f, f\<^sub>a] \<cdot>
	+ (((\<epsilon> \<star> f) \<star> f\<^sub>a) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> ((f \<star> \<eta>) \<star> f\<^sub>a)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ using comp_assoc by simp
	+ also have "... = \<a>[trg f, f, f\<^sub>a] \<cdot>
	+ ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (f \<star> \<eta>) \<star> f\<^sub>a) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ using \<eta>' comp_assoc whisker_right \<open>ide f\<^sub>a\<close> comp_null(2) ide_leg0 ext
	+ runit_simps(1)
	+ by metis
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ using * by simp
	+ finally show ?thesis by simp
	+ qed
	+ have \<theta>_eq: "?\<theta> = (\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, src f\<^sub>a] \<cdot> (f \<star> ?\<gamma>)"
	+ proof -
	+ have "?\<theta> = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ using \<theta>_eq' by simp
	+ also have "... =
	+ (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<star> f\<^sub>a) \<cdot> (\<r>[f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ using \<open>ide f\<^sub>a\<close> whisker_right comp_assoc by auto
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> ((\<a>[trg f, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[trg f, f, f\<^sub>a]) \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> f\<^sub>a])) \<cdot>
	+ (f \<star> \<l>[f\<^sub>a])"
	+ using 2 \<open>ide f\<^sub>a\<close> lunit_hcomp [of f f\<^sub>a] invert_side_of_triangle(2) triangle'
	+ comp_assoc
	+ by auto
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> f\<^sub>a] \<cdot> (f \<star> \<l>[f\<^sub>a])"
	+ using f\<^sub>a 2 comp_cod_arr iso_assoc comp_arr_inv lunit_hcomp(2) lunit_hcomp(4)
	+ ide_leg0 leg1_simps(3)
	+ by metis
	+ also have "... = \<l>\<^sup>-\<^sup>1[trg f] \<cdot> \<epsilon> \<cdot> (f \<star> \<l>[f\<^sub>a])"
	+ using \<epsilon> lunit'_naturality comp_assoc by metis
	+ also have "... = \<r>\<^sup>-\<^sup>1[trg f] \<cdot> \<epsilon> \<cdot> (f \<star> \<l>[f\<^sub>a])"
	+ using unitor_coincidence by simp
	+ also have "... = (\<epsilon> \<star> trg f) \<cdot> \<r>\<^sup>-\<^sup>1[f \<star> f\<^sub>a] \<cdot> (f \<star> \<l>[f\<^sub>a])"
	+ using \<epsilon> runit'_naturality comp_assoc by metis
	+ also have "... = (\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, src f\<^sub>a] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a]) \<cdot> (f \<star> \<l>[f\<^sub>a])"
	+ using 2 \<open>ide f\<^sub>a\<close> runit_hcomp(2) comp_assoc by auto
	+ also have "... = (\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, src f\<^sub>a] \<cdot> (f \<star> ?\<gamma>)"
	+ using 2 \<open>ide f\<^sub>a\<close> whisker_left by simp
	+ finally show ?thesis by simp
	+ qed
	+ have \<theta>: "\<guillemotleft>?\<theta> : f \<star> ?w \<Rightarrow> ?u\<guillemotright>"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<eta>_in_hom \<epsilon> hseqI' by fastforce
	+ have \<theta>': "\<guillemotleft>?\<theta>' : f \<star> ?w' \<Rightarrow> ?u\<guillemotright>"
	+ using f\<^sub>a 1 2 \<epsilon> assoc'_in_hom(2) hseqI' by auto
	+ have ww': "ide ?w \<and> ide ?w'"
	+ by (simp add: 1 2 \<open>ide f\<^sub>a\<close>)
	+ have "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : ?w \<Rightarrow> ?w'\<guillemotright> \<and> ?\<beta> = g \<star> \<gamma> \<and> ?\<theta> = ?\<theta>' \<cdot> (f \<star> \<gamma>)"
	+ proof -
	+ have "\<guillemotleft>?\<beta> : g \<star> ?w \<Rightarrow> g \<star> ?w'\<guillemotright>"
	+ using \<open>ide f\<^sub>a\<close> 1 2 by auto
	+ moreover have "composite_cell ?w ?\<theta> = composite_cell ?w' ?\<theta>' \<cdot> ?\<beta>"
	+ proof -
	+ have "composite_cell ?w' ?\<theta>' \<cdot> ?\<beta> =
	+ composite_cell ?w ((\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, src f\<^sub>a] \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]))"
	+ proof -
	+ have "\<a>[r, f, f\<^sub>a \<star> trg f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> trg f) \<cdot> (g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]) =
	+ composite_cell ?w (f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a])"
	+ proof -
	+ have "\<a>[r, f, f\<^sub>a \<star> trg f] \<cdot> (\<rho> \<star> f\<^sub>a \<star> trg f) \<cdot> (g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]) =
	+ (\<a>[r, f, f\<^sub>a \<star> trg f] \<cdot> ((r \<star> f) \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a])) \<cdot> (\<rho> \<star> src f \<star> f\<^sub>a)"
	+ proof -
	+ have "(\<rho> \<star> f\<^sub>a \<star> trg f) \<cdot> (g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]) = \<rho> \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"
	+ using interchange [of \<rho> g "f\<^sub>a \<star> trg f" "\<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"]
	+ comp_arr_dom comp_cod_arr 1 2 \<open>ide f\<^sub>a\<close>
	+ by simp
	+ also have "... = ((r \<star> f) \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]) \<cdot> (\<rho> \<star> src f \<star> f\<^sub>a)"
	+ proof -
	+ have "seq (f\<^sub>a \<star> trg f) (\<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a])"
	+ using f\<^sub>a 1 2 ww' by auto
	+ thus ?thesis
	+ using interchange comp_arr_dom comp_cod_arr 1 2 \<open>ide f\<^sub>a\<close> hseqI'
	+ by (metis ww' comp_ide_arr dom_comp leg1_simps(3)
	+ lunit_simps(4) tab_simps(1) tab_simps(5))
	+ qed
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = composite_cell ?w (f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a])"
	+ using assoc_naturality [of r f "\<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]"] 1 2 \<open>ide f\<^sub>a\<close> comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ hence "composite_cell ?w' ?\<theta>' \<cdot> ?\<beta> =
	+ ((r \<star> (\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f]) \<cdot> (r \<star> f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a])) \<cdot>
	+ \<a>[r, f, src f \<star> f\<^sub>a] \<cdot> (\<rho> \<star> src f \<star> f\<^sub>a)"
	+ using comp_assoc by simp
	+ also have
	+ "... = composite_cell ?w (((\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f]) \<cdot> (f \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]))"
	+ using whisker_left 1 2 \<open>ide f\<^sub>a\<close> ide_base
	+ by (metis \<open>\<guillemotleft>(\<epsilon> \<star> \<epsilon>) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a) :
	+ f \<star> src f \<star> f\<^sub>a \<Rightarrow> trg f \<star> trg f\<guillemotright>\<close>
	+ \<theta>_eq arrI comp_assoc)
	+ finally show ?thesis
	+ using comp_assoc by (simp add: "1")
	+ qed
	+ also have "... = composite_cell ?w ?\<theta>"
	+ using \<theta>_eq by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using ww' \<theta> \<theta>' T2 [of ?w ?w' ?\<theta> ?u ?\<theta>' ?\<beta>] comp_assoc by metis
	+ qed
	+ moreover have "\<guillemotleft>?\<gamma> : ?w \<Rightarrow> ?w'\<guillemotright> \<and> ?\<beta> = g \<star> ?\<gamma> \<and> ?\<theta> = ?\<theta>' \<cdot> (f \<star> ?\<gamma>)"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<theta>_eq comp_assoc by auto
	+ moreover have "\<guillemotleft>?\<gamma>' : ?w \<Rightarrow> ?w'\<guillemotright> \<and> ?\<beta> = g \<star> ?\<gamma>' \<and> ?\<theta> = ?\<theta>' \<cdot> (f \<star> ?\<gamma>')"
	+ proof (intro conjI)
	+ show "\<guillemotleft>?\<gamma>' : ?w \<Rightarrow> ?w'\<guillemotright>"
	+ using 1 2 f\<^sub>a \<eta>_in_hom \<epsilon>_in_hom by fastforce
	+ show "?\<beta> = g \<star> ?\<gamma>'"
	+ text \<open>
	+ This equation is not immediate.
	+ To show it, we have to recall the properties from the construction of \<open>\<epsilon>\<close> and \<open>\<eta>\<close>.
	+ Use the property of \<open>\<eta>\<close> to replace \<open>g \<star> \<eta> \<star> f\<^sub>a\<close> by a 2-cell involving
	+ \<open>\<epsilon>\<close>, \<open>\<rho>\<close>, and \<open>\<nu>\<close>.
	+ Use the property \<open>(r \<star> \<epsilon>) \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> \<nu> = \<r>[r]\<close> from the construction of \<open>\<epsilon>\<close> to
	+ eliminate \<open>\<epsilon>\<close> and \<open>\<rho>\<close> in favor of inv \<open>\<nu>\<close> and canonical isomorphisms.
	+ Cancelling \<open>\<nu>\<close> and inv \<open>\<nu>\<close> leaves the canonical 2-cell \<open>g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a] \<cdot> \<l>[f\<^sub>a]\<close>.
	+ \<close>
	+ proof -
	+ have "g \<star> ?\<gamma>' = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (g \<star> \<eta> \<star> f\<^sub>a)"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<epsilon> \<eta> whisker_left
	+ by (metis \<open>\<guillemotleft>?\<gamma>' : ?w \<Rightarrow> ?w'\<guillemotright>\<close> arrI ide_leg1 seqE)
	+ also have "... = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (g \<star> \<eta> \<star> f\<^sub>a) \<cdot>
	+ \<a>[g, src f, f\<^sub>a] \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<eta> comp_arr_dom hseq_char comp_assoc_assoc'
	+ by simp
	+ also have "... = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> ((g \<star> \<eta> \<star> f\<^sub>a) \<cdot>
	+ \<a>[g, src f, f\<^sub>a]) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ using comp_assoc by simp
	+ also have "... = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot>
	+ (\<a>[g, f\<^sub>a \<star> f, f\<^sub>a] \<cdot> ((g \<star> \<eta>) \<star> f\<^sub>a)) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<epsilon> \<eta> assoc_naturality [of g \<eta> f\<^sub>a] by simp
	+ also have "... = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> \<a>[g, f\<^sub>a \<star> f, f\<^sub>a] \<cdot>
	+ (\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ using \<eta>' comp_assoc by simp
	+ also have "... = (g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot>
	+ ((g \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> \<a>[g, f\<^sub>a \<star> f, f\<^sub>a] \<cdot> (\<a>[g, f\<^sub>a, f] \<star> f\<^sub>a)) \<cdot>
	+ ((\<nu> \<star> f) \<star> f\<^sub>a) \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ proof -
	+ have "\<a>[g, f\<^sub>a, f] \<cdot> (\<nu> \<star> f) \<cdot> \<rho> \<cdot> \<r>[g] \<star> f\<^sub>a =
	+ (\<a>[g, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> ((\<nu> \<star> f) \<star> f\<^sub>a) \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> (\<r>[g] \<star> f\<^sub>a)"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<beta> \<epsilon> \<eta> whisker_right by (metis arrI seqE)
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((g \<star> f\<^sub>a \<star> \<epsilon>) \<cdot>
	+ \<a>[g, f\<^sub>a, f \<star> f\<^sub>a]) \<cdot> (\<a>[g \<star> f\<^sub>a, f, f\<^sub>a] \<cdot>
	+ ((\<nu> \<star> f) \<star> f\<^sub>a)) \<cdot> (\<rho> \<star> f\<^sub>a) \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ using 1 2 \<open>ide f\<^sub>a\<close> pentagon comp_assoc by simp
	+ also have "... = (\<a>[g, f\<^sub>a, trg f] \<cdot> ((g \<star> f\<^sub>a) \<star> \<epsilon>)) \<cdot>
	+ ((\<nu> \<star> f \<star> f\<^sub>a) \<cdot> \<a>[r, f, f\<^sub>a]) \<cdot>
	+ (\<rho> \<star> f\<^sub>a) \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ using 1 2 \<open>ide f\<^sub>a\<close> assoc_naturality [of g f\<^sub>a \<epsilon>] assoc_naturality [of \<nu> f f\<^sub>a]
	+ by (simp add: \<epsilon> \<nu>)
	+ also have "... = \<a>[g, f\<^sub>a, trg f] \<cdot> (((g \<star> f\<^sub>a) \<star> \<epsilon>) \<cdot> (\<nu> \<star> f \<star> f\<^sub>a)) \<cdot> \<a>[r, f, f\<^sub>a] \<cdot>
	+ (\<rho> \<star> f\<^sub>a) \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ using 1 2 \<open>ide f\<^sub>a\<close> assoc_naturality [of g f\<^sub>a \<epsilon>] assoc_naturality [of \<nu> f f\<^sub>a]
	+ comp_assoc
	+ by simp
	+ also have "... = \<a>[g, f\<^sub>a, trg f] \<cdot> (\<nu> \<star> trg f) \<cdot>
	+ composite_cell f\<^sub>a \<epsilon> \<cdot>
	+ (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ proof -
	+ have "((g \<star> f\<^sub>a) \<star> \<epsilon>) \<cdot> (\<nu> \<star> f \<star> f\<^sub>a) = \<nu> \<star> \<epsilon>"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<nu> \<epsilon> interchange [of "g \<star> f\<^sub>a" \<nu> \<epsilon> "f \<star> f\<^sub>a"]
	+ comp_arr_dom comp_cod_arr
	+ by simp
	+ also have "... = (\<nu> \<star> trg f) \<cdot> (r \<star> \<epsilon>)"
	+ using \<open>ide f\<^sub>a\<close> \<nu> \<epsilon> interchange [of \<nu> r "trg f" \<epsilon>] comp_arr_dom comp_cod_arr
	+ by simp
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<a>[g, f\<^sub>a, trg f] \<cdot> ((((\<nu> \<star> trg f) \<cdot> \<r>\<^sup>-\<^sup>1[r]) \<cdot> inv \<nu>) \<cdot> (\<r>[g] \<star> f\<^sub>a)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ using ide_base f\<^sub>a' comp_assoc f\<^sub>a runit'_simps(1) invert_side_of_triangle(2)
	+ comp_assoc
	+ by presburger
	+ also have "... = \<a>[g, f\<^sub>a, trg f] \<cdot> \<r>\<^sup>-\<^sup>1[g \<star> f\<^sub>a] \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ proof -
	+ have "((\<nu> \<star> trg f) \<cdot> \<r>\<^sup>-\<^sup>1[r]) \<cdot> inv \<nu> = \<r>\<^sup>-\<^sup>1[g \<star> f\<^sub>a]"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<nu> ide_base runit'_naturality [of \<nu>] comp_arr_dom
	+ by (metis f\<^sub>a ide_compE inv_is_inverse inverse_arrowsE comp_assoc
	+ runit'_simps(1) runit'_simps(4))
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = ((\<a>[g, f\<^sub>a, trg f] \<cdot> \<a>\<^sup>-\<^sup>1[g, f\<^sub>a, src f\<^sub>a]) \<cdot>
	+ (g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a])) \<cdot> (\<r>[g] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[g, src f, f\<^sub>a]"
	+ using f\<^sub>a "2" runit_hcomp \<open>ide f\<^sub>a\<close> comp_assoc by simp
	+ also have "... = (g \<star> \<r>\<^sup>-\<^sup>1[f\<^sub>a]) \<cdot> (g \<star> \<l>[f\<^sub>a])"
	+ using 1 2 comp_cod_arr \<open>ide f\<^sub>a\<close> comp_assoc_assoc' hseqI' triangle' by simp
	+ also have "... = ?\<beta>"
	+ using 2 \<open>ide f\<^sub>a\<close> whisker_left by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "?\<theta> = ?\<theta>' \<cdot> (f \<star> ?\<gamma>')"
	+ proof -
	+ have "((\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f]) \<cdot> (f \<star> (f\<^sub>a \<star> \<epsilon>) \<cdot> \<a>[f\<^sub>a, f, f\<^sub>a] \<cdot> (\<eta> \<star> f\<^sub>a)) =
	+ ((\<epsilon> \<star> trg f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f]) \<cdot> (f \<star> f\<^sub>a \<star> \<epsilon>) \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<epsilon> \<eta> whisker_left
	+ by (metis \<open>\<guillemotleft>(f\<^sub>a \<star> \<epsilon>) \<cdot> \<a>[f\<^sub>a, f, f\<^sub>a] \<cdot> (\<eta> \<star> f\<^sub>a) : src f \<star> f\<^sub>a \<Rightarrow> f\<^sub>a \<star> trg f\<guillemotright>\<close>
	+ arrI ide_leg0 seqE)
	+ also have
	+ "... = (\<epsilon> \<star> trg f) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, trg f] \<cdot> (f \<star> f\<^sub>a \<star> \<epsilon>)) \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot> (f \<star> \<eta> \<star> f\<^sub>a)"
	+ using comp_assoc by simp
	+ also have "... = ((\<epsilon> \<star> trg f) \<cdot> ((f \<star> f\<^sub>a) \<star> \<epsilon>)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) \<cdot>
	+ (f \<star> \<eta> \<star> f\<^sub>a)"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<epsilon> assoc'_naturality [of f f\<^sub>a \<epsilon>] comp_assoc by simp
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> (\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a])) \<cdot>
	+ (f \<star> \<eta> \<star> f\<^sub>a)"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<epsilon> interchange [of \<epsilon> "f \<star> f\<^sub>a" "trg f" \<epsilon>]
	+ interchange [of "trg f" \<epsilon> \<epsilon> "f \<star> f\<^sub>a"] comp_arr_dom comp_cod_arr comp_assoc
	+ by simp
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> ((\<epsilon> \<star> f \<star> f\<^sub>a) \<cdot>
	+ (\<a>[f \<star> f\<^sub>a, f, f\<^sub>a]) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]) \<cdot>
	+ (f \<star> \<eta> \<star> f\<^sub>a))"
	+ proof -
	+ have "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a] \<cdot> (f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]) =
	+ \<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]"
	+ proof -
	+ have A: "(\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a] \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]) =
	+ \<a>\<^sup>-\<^sup>1[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"
	+ using 1 2 \<open>ide f\<^sub>a\<close> pentagon' comp_assoc by fastforce
	+ hence B: "\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a] \<cdot>
	+ (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]) =
	+ \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"
	+ using A 1 2 \<open>ide f\<^sub>a\<close> iso_inv_iso
	+ invert_side_of_triangle(1)
	+ [of "(\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a] \<cdot> (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a])"
	+ "\<a>\<^sup>-\<^sup>1[f \<star> f\<^sub>a, f, f\<^sub>a]" "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"]
	+ by auto
	+ show ?thesis
	+ proof -
	+ have C: "iso (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a])"
	+ using 1 2 \<open>ide f\<^sub>a\<close> iso_inv_iso by simp
	+ moreover have "inv (f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]) = f \<star> \<a>[f\<^sub>a, f, f\<^sub>a]"
	+ using C 1 2 inv_hcomp [of f "\<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]"]
	+ \<open>ide f\<^sub>a\<close> iso_assoc' assoc'_eq_inv_assoc
	+ by fastforce
	+ ultimately show ?thesis
	+ using B 1 2 \<open>ide f\<^sub>a\<close> comp_assoc
	+ invert_side_of_triangle(2)
	+ [of "\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f \<star> f\<^sub>a]"
	+ "\<a>[f \<star> f\<^sub>a, f, f\<^sub>a] \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a \<star> f, f\<^sub>a]"
	+ "f \<star> \<a>\<^sup>-\<^sup>1[f\<^sub>a, f, f\<^sub>a]"]
	+ by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> (\<a>[trg f, f, f\<^sub>a] \<cdot>
	+ ((\<epsilon> \<star> f) \<star> f\<^sub>a)) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> ((f \<star> \<eta>) \<star> f\<^sub>a) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<open>ide f\<close> \<eta> \<epsilon> assoc_naturality [of \<epsilon> f f\<^sub>a]
	+ assoc'_naturality [of f \<eta> f\<^sub>a] comp_assoc
	+ by simp
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot>
	+ (((\<epsilon> \<star> f) \<star> f\<^sub>a) \<cdot> (\<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<star> f\<^sub>a) \<cdot> ((f \<star> \<eta>) \<star> f\<^sub>a)) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ using comp_assoc by simp
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot>
	+ ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sub>a, f] \<cdot> (f \<star> \<eta>) \<star> f\<^sub>a) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ using 1 2 \<open>ide f\<^sub>a\<close> \<open>ide f\<close> \<eta> \<epsilon> whisker_right
	+ by (metis (full_types) * \<theta> \<theta>_eq' arrI hseqE seqE)
	+ also have "... = (trg f \<star> \<epsilon>) \<cdot> \<a>[trg f, f, f\<^sub>a] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> f\<^sub>a) \<cdot> \<a>\<^sup>-\<^sup>1[f, src f, f\<^sub>a]"
	+ using * by simp
	+ also have "... = ?\<theta>"
	+ using \<theta>_eq' by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ ultimately show "?\<gamma>' = ?\<gamma>" by blast
	+ qed
	+ qed
	+ thus ?thesis
	+ using adjoint_pair_def by auto
	+ qed
	+
	+ sublocale tabulation_data_with_T0
	+ using satisfies_T0 by (unfold_locales, simp)
	+ sublocale narrow_tabulation
	+ using adjoint_pair_antipar(1) T1 T2
	+ by (unfold_locales, auto)
	+
	+ end
	+
	+ text \<open>
	+ A tabulation \<open>(f, \<rho>, g)\<close> of \<open>r\<close> yields an isomorphism \<open>\<guillemotleft>\<psi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>\<close>
	+ via adjoint transpose.
	+ The proof requires \<open>T0\<close>, in order to obtain \<open>\<psi>\<close> as the transpose of \<open>\<guillemotleft>\<rho> : g \<Rightarrow> r \<star> f\<guillemotright>\<close>.
	+ However, it uses only the weaker versions of \<open>T1\<close> and \<open>T2\<close>.
	+ \<close>
	+
	+ context narrow_tabulation
	+ begin
	+
	+ interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
	+ notation E.eval ("\<lbrace>_\<rbrace>")
	+
	+ text \<open>
	+ The following is CKS Proposition 1(d), with the statement refined to incorporate
	+ the canonical isomorphisms that they omit.
	+ Note that we can easily show using \<open>T1\<close> that there is some 1-cell \<open>f\<^sub>a\<close> and isomorphism \<open>\<psi>\<close>
	+ such that \<open>\<guillemotleft>\<psi> : f \<star> f\<^sub>a \<Rightarrow> r\<guillemotright>\<close> (this was already part of the proof that a tabulation
	+ satisfies \<open>T0\<close>). The more difficult content in the present result is that we may
	+ actually take \<open>f\<^sub>a\<close> to be the left adjoint \<open>f\<^sup>*\<close> of \<open>f\<close>.
	+ \<close>
	+
	+ lemma yields_isomorphic_representation:
	+ shows "\<guillemotleft>T0.trnr\<^sub>\<epsilon> r \<rho> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>" and "iso (T0.trnr\<^sub>\<epsilon> r \<rho>)"
	+ proof -
	+ text \<open>
	+ As stated in CKS, the first step of the proof is:
	+ \begin{quotation}
	+ ``Apply \<open>T1\<close> with \<open>X = A\<close>, \<open>u = 1\<^sub>A\<close>, \<open>v = r\<close>, \<open>\<omega> = 1\<^sub>R\<close>, to obtain \<open>f'\<close>, \<open>\<theta>': ff' \<Rightarrow> 1\<^sub>A\<close>,
	+ \<open>\<nu> : r \<simeq> g f'\<close> with \<open>1\<^sub>R = (r\<theta>')(\<rho>f')\<nu>\<close>.''
	+ \end{quotation}
	+ In our nomenclature: \<open>X = trg f\<close>, \<open>u = trg f\<close>, \<open>v = r\<close>, but \<open>\<omega> = src f\<close>
	+ does not make any sense, since we need \<open>\<guillemotleft>\<omega> : v \<Rightarrow> r \<star> u\<guillemotright>\<close>. We have to take \<open>\<omega> = \<r>\<^sup>-\<^sup>1[r]\<close>.
	+ It is not clear whether this is a typo, or whether it is a consequence of CKS having
	+ suppressed all canonical isomorphisms (unitors, in this case). The resulting equation
	+ obtained via T1 is:
	+ \[
	+ \<open>\<r>\<^sup>-\<^sup>1[r] = (r \<star> \<theta>') \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu>\<close>,
	+ \]
	+ which has \<open>\<r>\<^sup>-\<^sup>1[r]\<close> on the left-hand side, rather than \<open>1\<^sub>R\<close>, as in CKS.
	+ Also, we have inserted the omitted associativity.
	+ \<close>
	+
	+ obtain w \<theta>' \<nu> where w\<theta>'\<nu>: "ide w \<and> \<guillemotleft>\<theta>' : f \<star> w \<Rightarrow> src r\<guillemotright> \<and> \<guillemotleft>\<nu> : r \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ composite_cell w \<theta>' \<cdot> \<nu> = \<r>\<^sup>-\<^sup>1[r]"
	+ using ide_base obj_is_self_adjoint T1 [of "src r" "\<r>\<^sup>-\<^sup>1[r]"] comp_assoc by auto
	+
	+ interpret uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho> f g \<open>src r\<close> w \<theta>' \<open>\<r>\<^sup>-\<^sup>1[r]\<close> \<nu>
	+ using ide_base tab_in_hom w\<theta>'\<nu> comp_assoc by (unfold_locales, auto)
	+
	+ text \<open>
	+ CKS now say:
	+ \begin{quotation}
	+ ``Apply \<open>T2\<close> with \<open>u = 1\<^sub>A\<close>, \<open>w = f\<^sup>\<close>, \<open>w' = f'\<close>, \<open>\<theta> = \<epsilon>: ff\<^sup> \<Rightarrow> 1\<close>, \<open>\<theta>': ff' \<Rightarrow> 1\<close>,
	+ \<open>\<beta> = \<nu>(r\<epsilon>)(\<rho>f\<^sup>)\<close> to obtain \<open>\<gamma> : f\<^sup> \<Rightarrow> f'\<close> with \<open>g\<gamma> = \<nu>(r\<epsilon>)(\<rho>f\<^sup>*)\<epsilon> = \<theta>'(f\<gamma>).\<close>''
	+ \end{quotation}
	+ The last equation is mysterious, but upon consideration one eventually realizes
	+ that it is definitely a typo, and what is meant is ``\<open>g\<gamma> = \<nu>(r\<epsilon>)(\<rho>f\<^sup>*)\<close>, \<open>\<epsilon> = \<theta>'(f\<gamma>)\<close>''.
	+
	+ So, we take \<open>u = trg f\<close>, \<open>w = f\<^sup>*\<close>, \<open>w' = w\<close>, \<open>\<theta>'\<close> as obtained from \<open>T1\<close>, \<open>\<theta> = \<epsilon>\<close>,
	+ and \<open>\<beta> = \<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>] \<cdot> (\<rho> \<star> f\<^sup>)\<close>.
	+ (CKS mention neither the unitor term \<open>\<r>[r]\<close> nor the associativity \<open>\<a>[r, f, f\<^sup>*]\<close>
	+ which are required for the expression for \<open>\<beta>\<close> to make sense.)
	+ \<close>
	+
	+ let ?\<psi> = "\<r>[r] \<cdot> composite_cell f\<^sup>* \<epsilon>"
	+ show \<psi>_in_hom: "\<guillemotleft>T0.trnr\<^sub>\<epsilon> r \<rho> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>"
	+ using ide_base T0.trnr\<^sub>\<epsilon>_def rep_in_hom by simp
	+ have A: "\<guillemotleft>\<nu> \<cdot> ?\<psi> : g \<star> f\<^sup>* \<Rightarrow> g \<star> w\<guillemotright>"
	+ using ide_base T0.antipar hseq_char T0.trnr\<^sub>\<epsilon>_def rep_in_hom w\<theta>'\<nu> by auto
	+ have B: "composite_cell f\<^sup>* \<epsilon> = composite_cell w \<theta>' \<cdot> \<nu> \<cdot> ?\<psi>"
	+ using ide_base T0.antipar w\<theta>'\<nu> comp_assoc
	+ by (metis A arrI invert_side_of_triangle(1) iso_runit)
	+
	+ obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : f\<^sup>* \<Rightarrow> w\<guillemotright> \<and> \<nu> \<cdot> ?\<psi> = g \<star> \<gamma> \<and> \<epsilon> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ using A B T0.counit_in_hom obj_is_self_adjoint T0.antipar comp_assoc
	+ T2 [of "trg f" "f\<^sup>" w \<epsilon> \<theta>' "\<nu> \<cdot> \<r>[r] \<cdot> composite_cell f\<^sup> \<epsilon>"]
	+ by auto
	+ have trg_\<gamma>_eq: "trg \<gamma> = trg w"
	+ using \<gamma> by fastforce
	+
	+ text \<open>
	+ CKS say:
	+ \begin{quotation}
	+ ``The last equation implies \<open>\<gamma>: f\<^sup>* \<Rightarrow> f'\<close> is a split monic (coretraction), while
	+ the calculation:
	+ \begin{eqnarray*}
	+ \<open>(g\<gamma>)(gf\<^sup>\<theta>')(g\<eta>f')\<close> &\<open>=\<close>& \<open>\<nu>(r\<epsilon>)(\<rho>f\<^sup>)(gf\<^sup>*\<theta>')(g\<eta>f')\<close>\\
	+ &\<open>=\<close>& \<open>\<nu>(r\<epsilon>)(rff\<^sup>\<theta>')(\<rho>f\<^sup>ff')(g\<eta>f')\<close>\\
	+ &\<open>=\<close>& \<open>\<nu>(r\<theta>')(r\<epsilon>ff')(rf\<eta>f')(\<rho>f')\<close>\\
	+ &\<open>=\<close>& \<open>\<nu>(r\<theta>')(\<rho>f') = 1\<^sub>g\<^sub>f\<^sub>'\<close>,
	+ \end{eqnarray*}
	+ shows that \<open>g\<gamma>\<close> is a split epic. So \<open>g\<gamma> = \<nu>(r\<epsilon>)(\<rho>f\<^sup>): gf\<^sup> \<Rightarrow> gf'\<close> is invertible.
	+ So \<open>(r\<epsilon>)(\<rho>f\<^sup>*) = \<nu>\<^sup>-\<^sup>1(g\<gamma>)\<close> is invertible.''
	+ \end{quotation}
	+ We carry out the indicated calculations, inserting where required the canonical
	+ isomorphisms omitted by CKS. It is perhaps amusing to compare the four-line sketch
	+ given by CKS with the formalization below, but note that we have carried out the
	+ proof in full, with no hand waving about units or associativities.
	+ \<close>
	+
	+ have "section (g \<star> \<gamma>)"
	+ proof
	+ have "(g \<star> \<r>[f\<^sup>] \<cdot> (f\<^sup> \<star> \<theta>') \<cdot> \<a>[f\<^sup>, f, w] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]) \<cdot> (g \<star> \<gamma>) = g \<star> f\<^sup>"
	+ proof -
	+ have "(\<r>[f\<^sup>] \<cdot> (f\<^sup> \<star> \<theta>') \<cdot> \<a>[f\<^sup>, f, w] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]) \<cdot> \<gamma> = f\<^sup>"
	+ proof -
	+ have "(\<r>[f\<^sup>] \<cdot> (f\<^sup> \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]) \<cdot> \<gamma> =
	+ (\<r>[f\<^sup>] \<cdot> (f\<^sup> \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w] \<cdot> (\<eta> \<star> w)) \<cdot> \<l>\<^sup>-\<^sup>1[w] \<cdot> \<gamma>"
	+ using comp_assoc by auto
	+ also have "... = (\<r>[f\<^sup>] \<cdot> (f\<^sup> \<star> \<theta>') \<cdot> \<a>[f\<^sup>, f, w]) \<cdot> ((\<eta> \<star> w) \<cdot> (trg w \<star> \<gamma>)) \<cdot> \<l>\<^sup>-\<^sup>1[f\<^sup>]"
	+ using \<gamma> trg_\<gamma>_eq lunit'_naturality [of \<gamma>] comp_assoc by auto
	+ also have "... = \<r>[f\<^sup>] \<cdot> (f\<^sup> \<star> \<theta>') \<cdot> (\<a>[f\<^sup>, f, w] \<cdot> ((f\<^sup> \<star> f) \<star> \<gamma>)) \<cdot> (\<eta> \<star> f\<^sup>) \<cdot> \<l>\<^sup>-\<^sup>1[f\<^sup>]"
	+ proof -
	+ have "(\<eta> \<star> w) \<cdot> (trg w \<star> \<gamma>) = \<eta> \<star> \<gamma>"
	+ using A \<gamma> interchange comp_arr_dom comp_cod_arr
	+ by (metis T0.unit_simps(1-2) comp_ide_arr seqI' uw\<theta> w_in_hom(2) w_simps(4))
	+ also have "... = ((f\<^sup>* \<star> f) \<star> \<gamma>) \<cdot> (\<eta> \<star> f\<^sup>*)"
	+ using \<gamma> interchange comp_arr_dom comp_cod_arr T0.antipar T0.unit_simps(1,3)
	+ in_homE
	+ by metis
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<r>[f\<^sup>] \<cdot> (f\<^sup> \<star> \<theta>') \<cdot> ((f\<^sup>* \<star> f \<star> \<gamma>) \<cdot> \<a>[f\<^sup>, f, f\<^sup>]) \<cdot> (\<eta> \<star> f\<^sup>) \<cdot> \<l>\<^sup>-\<^sup>1[f\<^sup>]"
	+ using \<gamma> assoc_naturality [of "f\<^sup>*" f \<gamma>] trg_\<gamma>_eq T0.antipar by auto
	+ also have "... = \<r>[f\<^sup>] \<cdot> ((f\<^sup> \<star> \<epsilon>) \<cdot> \<a>[f\<^sup>, f, f\<^sup>] \<cdot> (\<eta> \<star> f\<^sup>)) \<cdot> \<l>\<^sup>-\<^sup>1[f\<^sup>]"
	+ using \<gamma> whisker_left trg_\<gamma>_eq hseqI' T0.antipar comp_assoc by auto
	+ also have "... = \<r>[f\<^sup>] \<cdot> (\<r>\<^sup>-\<^sup>1[f\<^sup>] \<cdot> \<l>[f\<^sup>]) \<cdot> \<l>\<^sup>-\<^sup>1[f\<^sup>]"
	+ using T0.triangle_right by simp
	+ also have "... = f\<^sup>*"
	+ using comp_assoc by (simp add: comp_arr_dom comp_arr_inv')
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using \<gamma> whisker_left [of g "\<r>[f\<^sup>] \<cdot> (f\<^sup> \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]" \<gamma>]
	+ hseqI' T0.antipar
	+ by simp
	+ qed
	+ thus "ide ((g \<star> \<r>[f\<^sup>] \<cdot> (f\<^sup> \<star> \<theta>') \<cdot> \<a>[f\<^sup>*, f, w] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]) \<cdot> (g \<star> \<gamma>))"
	+ using T0.antipar by simp
	+ qed
	+ moreover have "retraction (g \<star> \<gamma>)"
	+ proof
	+ have "\<guillemotleft>(g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>]) \<cdot> (g \<star> f\<^sup> \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]) :
	+ g \<star> w \<Rightarrow> g \<star> w\<guillemotright>"
	+ using \<gamma> T0.antipar hseq_char
	+ by (intro comp_in_hom_simp, auto)
	+ hence *: "arr ((g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
	+ (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]))"
	+ by auto
	+ show "ide ((g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>]) \<cdot> (g \<star> f\<^sup> \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
	+ (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]))"
	+ proof -
	+ have "((g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>]) \<cdot> (g \<star> f\<^sup> \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
	+ (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])) =
	+ g \<star> w"
	+ proof -
	+ have "((g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>]) \<cdot> (g \<star> f\<^sup> \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
	+ (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])) =
	+ \<nu> \<cdot> \<r>[r] \<cdot> ((r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> src f\<^sup> \<star> \<theta>') \<cdot> (r \<star> \<a>[src f\<^sup>*, f, w]) \<cdot>
	+ (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
	+ (\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(g \<star> \<gamma>) \<cdot> (g \<star> \<r>[f\<^sup>]) \<cdot> (g \<star> f\<^sup> \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
	+ (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]) =
	+ (\<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>] \<cdot> (\<rho> \<star> f\<^sup>)) \<cdot>
	+ (g \<star> \<r>[f\<^sup>]) \<cdot> (g \<star> f\<^sup> \<star> \<theta>') \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
	+ (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ using \<gamma> by auto
	+ also have "... =
	+ \<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*] \<cdot>
	+ ((\<rho> \<star> f\<^sup>) \<cdot> (g \<star> \<r>[f\<^sup>]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>')) \<cdot>
	+ (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ using comp_assoc by simp
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>*] \<cdot>
	+ (((r \<star> f) \<star> \<r>[f\<^sup>]) \<cdot> ((r \<star> f) \<star> f\<^sup> \<star> \<theta>') \<cdot> (\<rho> \<star> f\<^sup>* \<star> f \<star> w)) \<cdot>
	+ (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(\<rho> \<star> f\<^sup>) \<cdot> (g \<star> \<r>[f\<^sup>]) \<cdot> (g \<star> f\<^sup>* \<star> \<theta>') =
	+ ((r \<star> f) \<star> \<r>[f\<^sup>]) \<cdot> (\<rho> \<star> f\<^sup> \<star> src f\<^sup>) \<cdot> (g \<star> f\<^sup> \<star> \<theta>')"
	+ proof -
	+ have "(\<rho> \<star> f\<^sup>) \<cdot> (g \<star> \<r>[f\<^sup>]) = ((r \<star> f) \<star> \<r>[f\<^sup>]) \<cdot> (\<rho> \<star> f\<^sup> \<star> src f\<^sup>*)"
	+ using tab_in_hom comp_arr_dom comp_cod_arr T0.antipar(1) interchange
	+ by (metis T0.ide_right in_homE runit_simps(1,4-5))
	+ thus ?thesis
	+ by (metis comp_assoc)
	+ qed
	+ also have "... = ((r \<star> f) \<star> \<r>[f\<^sup>]) \<cdot> (\<rho> \<star> f\<^sup> \<star> \<theta>')"
	+ using comp_arr_dom comp_cod_arr hseqI' T0.antipar
	+ interchange [of \<rho> g "f\<^sup>* \<star> src f\<^sup>" "f\<^sup> \<star> \<theta>'"]
	+ by simp
	+ also have "... = ((r \<star> f) \<star> \<r>[f\<^sup>]) \<cdot> ((r \<star> f) \<star> f\<^sup> \<star> \<theta>') \<cdot> (\<rho> \<star> f\<^sup>* \<star> f \<star> w)"
	+ using comp_arr_dom comp_cod_arr hseqI' T0.antipar
	+ interchange [of "r \<star> f" \<rho> "f\<^sup>* \<star> \<theta>'" "f\<^sup>* \<star> f \<star> w"]
	+ by simp
	+ finally show ?thesis by simp
	+ qed
	+ also have "... =
	+ \<nu> \<cdot> \<r>[r] \<cdot>
	+ ((r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>] \<cdot> ((r \<star> f) \<star> \<r>[f\<^sup>]) \<cdot> ((r \<star> f) \<star> f\<^sup>* \<star> \<theta>')) \<cdot>
	+ ((\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w)) \<cdot>
	+ (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ using comp_assoc by simp
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot>
	+ ((r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> src f\<^sup> \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup> \<star> f \<star> w]) \<cdot>
	+ (((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot> ((r \<star> f) \<star> \<eta> \<star> w) \<cdot> (\<rho> \<star> trg w \<star> w)) \<cdot>
	+ (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have 1: "(r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>] \<cdot> ((r \<star> f) \<star> \<r>[f\<^sup>]) \<cdot> ((r \<star> f) \<star> f\<^sup>* \<star> \<theta>') =
	+ (r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> src f\<^sup> \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup> \<star> f \<star> w]"
	+ proof -
	+ have "(r \<star> \<epsilon>) \<cdot> \<a>[r, f, f\<^sup>] \<cdot> ((r \<star> f) \<star> \<r>[f\<^sup>]) \<cdot> ((r \<star> f) \<star> f\<^sup>* \<star> \<theta>') =
	+ (r \<star> \<epsilon>) \<cdot> (r \<star> f \<star> \<r>[f\<^sup>]) \<cdot> \<a>[r, f, f\<^sup> \<star> src f\<^sup>] \<cdot> ((r \<star> f) \<star> f\<^sup> \<star> \<theta>')"
	+ proof -
	+ have "\<a>[r, f, f\<^sup>] \<cdot> ((r \<star> f) \<star> \<r>[f\<^sup>]) = (r \<star> f \<star> \<r>[f\<^sup>]) \<cdot> \<a>[r, f, f\<^sup> \<star> src f\<^sup>*]"
	+ using assoc_naturality [of r f "\<r>[f\<^sup>*]"] T0.antipar by auto
	+ thus ?thesis
	+ using comp_assoc by metis
	+ qed
	+ also have "... = (r \<star> \<epsilon>) \<cdot> (r \<star> f \<star> \<r>[f\<^sup>]) \<cdot> (r \<star> f \<star> f\<^sup> \<star> \<theta>') \<cdot>
	+ \<a>[r, f, f\<^sup>* \<star> f \<star> w]"
	+ using assoc_naturality [of r f "f\<^sup>* \<star> \<theta>'"] T0.antipar by force
	+ also have "... = (r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, src f\<^sup>]) \<cdot>
	+ (r \<star> f \<star> f\<^sup>* \<star> \<theta>') \<cdot> \<a>[r, f, f\<^sup>* \<star> f \<star> w]"
	+ proof -
	+ have "(r \<star> \<epsilon>) \<cdot> (r \<star> f \<star> \<r>[f\<^sup>*]) =
	+ (r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, src f\<^sup>])"
	+ proof -
	+ have "(r \<star> \<epsilon>) \<cdot> (r \<star> f \<star> \<r>[f\<^sup>]) = r \<star> (\<epsilon> \<cdot> (f \<star> \<r>[f\<^sup>]))"
	+ using whisker_left hseqI' T0.antipar by simp
	+ also have "... =
	+ (r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, src f\<^sup>])"
	+ proof -
	+ have "\<epsilon> \<cdot> (f \<star> \<r>[f\<^sup>]) = \<r>[src f\<^sup>] \<cdot> (\<epsilon> \<star> src f\<^sup>) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, src f\<^sup>*]"
	+ using ide_leg0 T0.antipar runit_hcomp invert_side_of_triangle(2)
	+ hseqI' runit_naturality comp_assoc
	+ by (metis (no_types, lifting) T0.counit_simps(1-4) T0.ide_right)
	+ thus ?thesis
	+ using whisker_left hseqI' T0.antipar by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis using comp_assoc by metis
	+ qed
	+ also have "... =
	+ (r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>) \<cdot>
	+ ((r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, src f\<^sup>]) \<cdot> (r \<star> f \<star> f\<^sup>* \<star> \<theta>')) \<cdot>
	+ \<a>[r, f, f\<^sup>* \<star> f \<star> w]"
	+ using comp_assoc by simp
	+ also have "... = (r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>) \<cdot>
	+ ((r \<star> (f \<star> f\<^sup>) \<star> \<theta>') \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w])) \<cdot>
	+ \<a>[r, f, f\<^sup>* \<star> f \<star> w]"
	+ proof -
	+ have "(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, src f\<^sup>]) \<cdot> (r \<star> f \<star> f\<^sup>* \<star> \<theta>') =
	+ (r \<star> (f \<star> f\<^sup>) \<star> \<theta>') \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w])"
	+ proof -
	+ have "(r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, src f\<^sup>]) \<cdot> (r \<star> f \<star> f\<^sup>* \<star> \<theta>') =
	+ r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, src f\<^sup>] \<cdot> (f \<star> f\<^sup>* \<star> \<theta>')"
	+ using whisker_left hseqI' T0.antipar by simp
	+ also have "... = r \<star> ((f \<star> f\<^sup>) \<star> \<theta>') \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]"
	+ using assoc'_naturality [of f "f\<^sup>*" \<theta>'] T0.antipar by auto
	+ also have "... = (r \<star> (f \<star> f\<^sup>) \<star> \<theta>') \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w])"
	+ using whisker_left hseqI' T0.antipar by auto
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> \<epsilon> \<star> src f\<^sup>) \<cdot> (r \<star> (f \<star> f\<^sup>*) \<star> \<theta>') \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup> \<star> f \<star> w]"
	+ using comp_assoc by simp
	+ also have "... =
	+ (r \<star> \<r>[src f\<^sup>]) \<cdot> ((r \<star> \<epsilon> \<star> src f\<^sup>) \<cdot> (r \<star> (f \<star> f\<^sup>*) \<star> \<theta>')) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup> \<star> f \<star> w]"
	+ using comp_assoc by simp
	+ also have "... = (r \<star> \<r>[src f\<^sup>]) \<cdot> ((r \<star> src f\<^sup> \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w)) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup> \<star> f \<star> w]"
	+ proof -
	+ have "(r \<star> \<epsilon> \<star> src f\<^sup>) \<cdot> (r \<star> (f \<star> f\<^sup>) \<star> \<theta>') =
	+ (r \<star> src f\<^sup>* \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w)"
	+ proof -
	+ have "(r \<star> \<epsilon> \<star> src f\<^sup>) \<cdot> (r \<star> (f \<star> f\<^sup>) \<star> \<theta>') =
	+ r \<star> (\<epsilon> \<star> src f\<^sup>) \<cdot> ((f \<star> f\<^sup>) \<star> \<theta>')"
	+ using whisker_left hseqI' T0.antipar by simp
	+ also have "... = r \<star> \<epsilon> \<star> \<theta>'"
	+ using interchange [of \<epsilon> "f \<star> f\<^sup>" "src f\<^sup>" \<theta>']
	+ T0.antipar comp_arr_dom comp_cod_arr
	+ by auto
	+ also have "... = r \<star> (src f\<^sup>* \<star> \<theta>') \<cdot> (\<epsilon> \<star> f \<star> w)"
	+ using interchange [of "src f\<^sup>*" \<epsilon> \<theta>' "f \<star> w"]
	+ T0.antipar comp_arr_dom comp_cod_arr
	+ by auto
	+ also have "... = (r \<star> src f\<^sup>* \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w)"
	+ using whisker_left hseqI' T0.antipar by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = (r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> src f\<^sup> \<star> \<theta>') \<cdot> (r \<star> \<epsilon> \<star> f \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup> \<star> f \<star> w]"
	+ using comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ have 2: "(\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w) =
	+ ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot> ((r \<star> f) \<star> \<eta> \<star> w) \<cdot> (\<rho> \<star> trg w \<star> w)"
	+ proof -
	+ have "(\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) \<cdot> (g \<star> \<eta> \<star> w) =
	+ ((\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w])) \<cdot> (g \<star> \<eta> \<star> w)"
	+ using comp_assoc by simp
	+ also have "... = (((r \<star> f) \<star> \<a>[f\<^sup>, f, w]) \<cdot> (\<rho> \<star> (f\<^sup> \<star> f) \<star> w)) \<cdot> (g \<star> \<eta> \<star> w)"
	+ proof -
	+ have "(\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) =
	+ ((r \<star> f) \<star> \<a>[f\<^sup>, f, w]) \<cdot> (\<rho> \<star> (f\<^sup> \<star> f) \<star> w)"
	+ proof -
	+ have "(\<rho> \<star> f\<^sup>* \<star> f \<star> w) \<cdot> (g \<star> \<a>[f\<^sup>*, f, w]) =
	+ \<rho> \<cdot> g \<star> (f\<^sup>* \<star> f \<star> w) \<cdot> \<a>[f\<^sup>*, f, w]"
	+ using interchange T0.antipar by auto
	+ also have "... = \<rho> \<star> \<a>[f\<^sup>*, f, w]"
	+ using comp_arr_dom comp_cod_arr T0.antipar by auto
	+ also have "... = (r \<star> f) \<cdot> \<rho> \<star> \<a>[f\<^sup>, f, w] \<cdot> ((f\<^sup> \<star> f) \<star> w)"
	+ using comp_arr_dom comp_cod_arr T0.antipar by auto
	+ also have "... = ((r \<star> f) \<star> \<a>[f\<^sup>, f, w]) \<cdot> (\<rho> \<star> (f\<^sup> \<star> f) \<star> w)"
	+ using interchange T0.antipar by auto
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = ((r \<star> f) \<star> \<a>[f\<^sup>, f, w]) \<cdot> (\<rho> \<star> (f\<^sup> \<star> f) \<star> w) \<cdot> (g \<star> \<eta> \<star> w)"
	+ using comp_assoc by simp
	+ also have "... = ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot> ((r \<star> f) \<star> \<eta> \<star> w) \<cdot> (\<rho> \<star> trg w \<star> w)"
	+ proof -
	+ have "(\<rho> \<star> (f\<^sup>* \<star> f) \<star> w) \<cdot> (g \<star> \<eta> \<star> w) = ((r \<star> f) \<star> \<eta> \<star> w) \<cdot> (\<rho> \<star> trg w \<star> w)"
	+ proof -
	+ have "(\<rho> \<star> (f\<^sup>* \<star> f) \<star> w) \<cdot> (g \<star> \<eta> \<star> w) = \<rho> \<cdot> g \<star> (f\<^sup>* \<star> f) \<cdot> \<eta> \<star> w \<cdot> w"
	+ proof -
	+ have "\<guillemotleft>g \<star> \<eta> \<star> w : g \<star> trg w \<star> w \<Rightarrow> g \<star> (f\<^sup>* \<star> f) \<star> w\<guillemotright>"
	+ by (intro hcomp_in_vhom, auto)
	+ thus ?thesis
	+ using interchange whisker_right T0.antipar by auto
	+ qed
	+ also have "... = (r \<star> f) \<cdot> \<rho> \<star> \<eta> \<cdot> trg w \<star> w \<cdot> w"
	+ using comp_arr_dom comp_cod_arr by auto
	+ also have "... = ((r \<star> f) \<star> \<eta> \<star> w) \<cdot> (\<rho> \<star> trg w \<star> w)"
	+ using interchange [of "r \<star> f" \<rho> "\<eta> \<star> w" "trg w \<star> w"]
	+ interchange [of \<eta> "trg w" w w]
	+ comp_arr_dom comp_cod_arr T0.unit_in_hom hseqI'
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ show ?thesis
	+ using 1 2 by simp
	+ qed
	+ also have "... =
	+ \<nu> \<cdot> \<r>[r] \<cdot>
	+ ((r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') \<cdot>
	+ ((r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>*, f, w])) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]) \<cdot> \<a>[r, f, f\<^sup> \<star> f \<star> w]) \<cdot>
	+ (((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
	+ (\<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot> (r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot>
	+ (r \<star> (f \<star> \<eta>) \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w]) \<cdot>
	+ (\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have 3: "r \<star> \<epsilon> \<star> f \<star> w =
	+ (r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>*, f, w])"
	+ proof -
	+ have "r \<star> \<epsilon> \<star> f \<star> w =
	+ ((r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[src r, f, w])) \<cdot> (r \<star> \<epsilon> \<star> f \<star> w)"
	+ using T0.antipar whisker_left [of r "\<a>[src r, f, w]" "\<a>\<^sup>-\<^sup>1[src r, f, w]"]
	+ comp_cod_arr hseqI' comp_assoc_assoc'
	+ by simp
	+ also have "... = (r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>*, f, w])"
	+ using assoc'_naturality [of \<epsilon> f w]
	+ whisker_left [of r "\<a>\<^sup>-\<^sup>1[src r, f, w]" "\<epsilon> \<star> f \<star> w"]
	+ whisker_left comp_assoc hseqI' T0.antipar
	+ by simp
	+ finally show ?thesis
	+ using T0.antipar by simp
	+ qed
	+ have 4: "(r \<star> f) \<star> \<eta> \<star> w =
	+ \<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot> (r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot>
	+ (r \<star> (f \<star> \<eta>) \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w]"
	+ proof -
	+ have "(r \<star> f) \<star> \<eta> \<star> w =
	+ (\<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot>
	+ ((r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w])) \<cdot>
	+ \<a>[r, f, (f\<^sup>* \<star> f) \<star> w]) \<cdot>
	+ ((r \<star> f) \<star> \<eta> \<star> w)"
	+ proof -
	+ have "ide r" by simp
	+ moreover have "seq \<a>[f, f\<^sup>* \<star> f, w] \<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w]"
	+ using T0.antipar comp_cod_arr hseqI' ide_base by simp
	+ ultimately have "(r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w]) =
	+ r \<star> \<a>[f, f\<^sup>* \<star> f, w] \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w]"
	+ using whisker_left by metis
	+ thus ?thesis
	+ using T0.antipar comp_cod_arr hseqI' comp_assoc_assoc' by simp
	+ qed
	+ also have "... =
	+ \<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot>
	+ (r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot> ((r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w]) \<cdot>
	+ (r \<star> f \<star> \<eta> \<star> w)) \<cdot>
	+ \<a>[r, f, trg w \<star> w]"
	+ using assoc_naturality [of r f "\<eta> \<star> w"] hseqI' comp_assoc by fastforce
	+ also have "... =
	+ \<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot>
	+ (r \<star> \<a>[f, f\<^sup>* \<star> f, w]) \<cdot> (r \<star> (f \<star> \<eta>) \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
	+ \<a>[r, f, trg w \<star> w]"
	+ using assoc'_naturality [of f \<eta> w] hseqI' T0.antipar comp_assoc
	+ whisker_left [of r "\<a>\<^sup>-\<^sup>1[f, f\<^sup>* \<star> f, w]" "f \<star> \<eta> \<star> w"]
	+ whisker_left [of r "(f \<star> \<eta>) \<star> w" "\<a>\<^sup>-\<^sup>1[f, trg w, w]"]
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ show ?thesis
	+ using 3 4 T0.antipar by simp
	+ qed
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot> ((r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') \<cdot>
	+ (r \<star> \<a>[src r, f, w]) \<cdot>
	+ ((r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot>
	+ ((r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>, f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]) \<cdot>
	+ \<a>[r, f, f\<^sup>* \<star> f \<star> w] \<cdot> ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot> (r \<star> \<a>[f, f\<^sup>* \<star> f, w])) \<cdot>
	+ (r \<star> (f \<star> \<eta>) \<star> w)) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
	+ (\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ using comp_assoc T0.antipar by auto
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot> ((r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') \<cdot>
	+ (r \<star> \<a>[src r, f, w]) \<cdot>
	+ ((r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<star> w) \<cdot>
	+ (r \<star> (f \<star> \<eta>) \<star> w)) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
	+ (\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>, f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]) \<cdot>
	+ \<a>[r, f, f\<^sup>* \<star> f \<star> w] \<cdot> ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot> (r \<star> \<a>[f, f\<^sup>* \<star> f, w]) =
	+ r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<star> w"
	+ proof -
	+ text \<open>We can compress the reasoning about the associativities using coherence.\<close>
	+ have "(r \<star> \<a>\<^sup>-\<^sup>1[f \<star> f\<^sup>, f, w]) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>, f \<star> w]) \<cdot>
	+ \<a>[r, f, f\<^sup>* \<star> f \<star> w] \<cdot> ((r \<star> f) \<star> \<a>[f\<^sup>*, f, w]) \<cdot>
	+ \<a>\<^sup>-\<^sup>1[r, f, (f\<^sup>* \<star> f) \<star> w] \<cdot> (r \<star> \<a>[f, f\<^sup>* \<star> f, w]) =
	+ \<lbrace>(\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^sup>\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sup>\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sup>\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> ((\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^sup>\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, (\<^bold>\<langle>f\<^sup>\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sup>\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>])\<rbrace>"
	+ using T0.antipar \<a>'_def \<alpha>_def assoc'_eq_inv_assoc by auto
	+ also have "... = \<lbrace>\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^sup>*\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<rbrace>"
	+ using T0.antipar by (intro E.eval_eqI, auto)
	+ also have "... = r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<star> w"
	+ using T0.antipar \<a>'_def \<alpha>_def assoc'_eq_inv_assoc by simp
	+ finally show ?thesis
	+ by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot> ((r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') \<cdot>
	+ (r \<star> \<a>[src r, f, w]) \<cdot>
	+ (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
	+ (\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<star> w) \<cdot> (r \<star> (f \<star> \<eta>) \<star> w) =
	+ r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w"
	+ proof -
	+ have "(r \<star> (\<epsilon> \<star> f) \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<star> w) \<cdot> (r \<star> (f \<star> \<eta>) \<star> w) =
	+ r \<star> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, f\<^sup>*, f] \<cdot> (f \<star> \<eta>) \<star> w"
	+ using whisker_left whisker_right hseqI' T0.antipar by simp
	+ also have "... = r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w"
	+ using T0.triangle_left by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot> ((r \<star> \<r>[src f\<^sup>]) \<cdot> (r \<star> src f\<^sup> \<star> \<theta>') \<cdot> (r \<star> \<a>[src f\<^sup>*, f, w]) \<cdot>
	+ (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
	+ (\<rho> \<star> trg w \<star> w)) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w])"
	+ using T0.antipar by simp
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot>
	+ ((r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>')) \<cdot>
	+ (r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
	+ ((\<rho> \<star> trg w \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]))"
	+ using comp_assoc T0.antipar by simp
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot>
	+ ((r \<star> \<theta>') \<cdot> (r \<star> \<l>[f \<star> w])) \<cdot>
	+ (r \<star> \<a>[src r, f, w]) \<cdot> (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot>
	+ (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot> \<a>[r, f, trg w \<star> w] \<cdot>
	+ (((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w]) \<cdot> (\<rho> \<star> w))"
	+ proof -
	+ have "(r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') = (r \<star> \<theta>') \<cdot> (r \<star> \<l>[f \<star> w])"
	+ proof -
	+ have "(r \<star> \<r>[src r]) \<cdot> (r \<star> src r \<star> \<theta>') = r \<star> \<r>[src r] \<cdot> (src r \<star> \<theta>')"
	+ using whisker_left hseqI' by simp
	+ also have "... = r \<star> \<theta>' \<cdot> \<l>[f \<star> w]"
	+ using lunit_naturality [of \<theta>'] unitor_coincidence by simp
	+ also have "... = (r \<star> \<theta>') \<cdot> (r \<star> \<l>[f \<star> w])"
	+ using whisker_left by simp
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "(\<rho> \<star> trg w \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]) = ((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w]) \<cdot> (\<rho> \<star> w)"
	+ proof -
	+ have "(\<rho> \<star> trg w \<star> w) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[w]) = \<rho> \<cdot> g \<star> (trg w \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[w]"
	+ using interchange by simp
	+ also have "... = \<rho> \<star> \<l>\<^sup>-\<^sup>1[w]"
	+ using comp_arr_dom comp_cod_arr by simp
	+ also have "... = (r \<star> f) \<cdot> \<rho> \<star> \<l>\<^sup>-\<^sup>1[w] \<cdot> w"
	+ using comp_arr_dom comp_cod_arr by simp
	+ also have "... = ((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w]) \<cdot> (\<rho> \<star> w)"
	+ using interchange by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<theta>') \<cdot>
	+ ((r \<star> \<l>[f \<star> w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
	+ (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
	+ \<a>[r, f, trg w \<star> w] \<cdot> ((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w])) \<cdot>
	+ (\<rho> \<star> w)"
	+ using comp_assoc by simp
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot> (r \<star> \<theta>') \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w)"
	+ proof -
	+ have "((r \<star> \<l>[f \<star> w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
	+ (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
	+ \<a>[r, f, trg w \<star> w] \<cdot> ((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w])) =
	+ \<a>[r, f, w]"
	+ proof -
	+ have "((r \<star> \<l>[f \<star> w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
	+ (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
	+ \<a>[r, f, trg w \<star> w] \<cdot> ((r \<star> f) \<star> \<l>\<^sup>-\<^sup>1[w])) =
	+ ((r \<star> (\<l>[f] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
	+ (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
	+ (r \<star> f \<star> \<l>\<^sup>-\<^sup>1[w])) \<cdot> \<a>[r, f, w]"
	+ using comp_assoc assoc_naturality [of r f "\<l>\<^sup>-\<^sup>1[w]"] lunit_hcomp by simp
	+ also have "... = \<a>[r, f, w]"
	+ proof -
	+ have "(r \<star> (\<l>[f] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
	+ (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
	+ (r \<star> f \<star> \<l>\<^sup>-\<^sup>1[w]) =
	+ r \<star> f \<star> w"
	+ proof -
	+ text \<open>Again, get a little more mileage out of coherence.\<close>
	+ have "(r \<star> (\<l>[f] \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[trg f, f, w]) \<cdot> (r \<star> \<a>[src r, f, w]) \<cdot>
	+ (r \<star> \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, trg w, w]) \<cdot>
	+ (r \<star> f \<star> \<l>\<^sup>-\<^sup>1[w]) =
	+ \<lbrace>(\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<l>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[E.Trg \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[E.Src \<^bold>\<langle>r\<^bold>\<rangle>, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> \<^bold>\<r>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>) \<^bold>\<cdot> (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, E.Trg \<^bold>\<langle>w\<^bold>\<rangle>, \<^bold>\<langle>w\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
	+ (\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>w\<^bold>\<rangle>\<^bold>])\<rbrace>"
	+ using \<ll>_ide_simp \<rr>_ide_simp \<a>'_def \<alpha>_def assoc'_eq_inv_assoc by simp
	+ also have "... = \<lbrace>\<^bold>\<langle>r\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>w\<^bold>\<rangle>\<rbrace>"
	+ by (intro E.eval_eqI, auto)
	+ also have "... = r \<star> f \<star> w"
	+ by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using comp_cod_arr by auto
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<nu> \<cdot> \<r>[r] \<cdot> \<r>\<^sup>-\<^sup>1[r] \<cdot> inv \<nu>"
	+ proof -
	+ have "\<r>\<^sup>-\<^sup>1[r] \<cdot> inv \<nu> = (r \<star> \<theta>') \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w)"
	+ using ** w\<theta>'\<nu> ide_base ide_leg0 tab_in_hom invert_side_of_triangle(2) comp_arr_dom
	+ T0.antipar comp_assoc runit'_simps(1)
	+ by metis
	+ thus ?thesis by simp
	+ qed
	+ also have "... = g \<star> w"
	+ using ** w\<theta>'\<nu> ide_base comp_arr_inv'
	+ by (metis calculation in_homE invert_side_of_triangle(1) iso_runit iso_runit')
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ qed
	+ ultimately have 1: "iso (g \<star> \<gamma>)"
	+ using iso_iff_section_and_retraction by simp
	+ have "iso (inv (\<nu> \<cdot> \<r>[r]) \<cdot> (g \<star> \<gamma>))"
	+ proof -
	+ have "iso (inv (\<nu> \<cdot> \<r>[r]))"
	+ using w\<theta>'\<nu> \<gamma> iso_runit
	+ by (elim conjE in_homE, intro iso_inv_iso isos_compose, auto)
	+ thus ?thesis
	+ using 1 w\<theta>'\<nu> \<gamma> trg_\<gamma>_eq isos_compose iso_inv_iso hseqI'
	+ by (elim conjE in_homE, auto)
	+ qed
	+ moreover have "inv (\<nu> \<cdot> \<r>[r]) \<cdot> (g \<star> \<gamma>) = composite_cell f\<^sup>* \<epsilon>"
	+ proof -
	+ have "inv (\<nu> \<cdot> \<r>[r]) \<cdot> (g \<star> \<gamma>) = inv (\<nu> \<cdot> \<r>[r]) \<cdot> \<nu> \<cdot> \<r>[r] \<cdot> composite_cell f\<^sup>* \<epsilon>"
	+ using \<gamma> by auto
	+ also have "... = ((inv (\<nu> \<cdot> \<r>[r]) \<cdot> (\<nu> \<cdot> \<r>[r])) \<cdot> (r \<star> \<epsilon>)) \<cdot> \<a>[r, f, f\<^sup>] \<cdot> (\<rho> \<star> f\<^sup>)"
	+ using w\<theta>'\<nu> iso_inv_iso comp_assoc by auto
	+ also have "... = composite_cell f\<^sup>* \<epsilon>"
	+ proof -
	+ have "dom \<nu> = r"
	+ using w\<theta>'\<nu> by auto
	+ thus ?thesis
	+ using iso_runit w\<theta>'\<nu> isos_compose comp_cod_arr whisker_left [of r "src r" \<epsilon>]
	+ iso_inv_iso comp_inv_arr inv_is_inverse
	+ by auto
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ ultimately have "iso (composite_cell f\<^sup>* \<epsilon>)" by simp
	+ thus "iso (T0.trnr\<^sub>\<epsilon> r \<rho>)"
	+ using T0.trnr\<^sub>\<epsilon>_def ide_base runit_in_hom iso_runit isos_compose
	+ by (metis A arrI seqE)
	+ qed
	+
	+ text \<open>
	+ It is convenient to have a simpler version of the previous result for when we do
	+ not care about the details of the isomorphism.
	+ \<close>
	+
	+ lemma yields_isomorphic_representation':
	+ obtains \<psi> where "\<guillemotleft>\<psi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>" and "iso \<psi>"
	+ using yields_isomorphic_representation adjoint_pair_def by simp
	+
	+ end
	+
	+ text \<open>
	+ It is natural to ask whether if \<open>\<guillemotleft>\<psi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>\<close> is an isomorphism
	+ then \<open>\<rho> = (\<psi> \<star> f) \<cdot> T0.trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)\<close> is a tabulation of \<open>r\<close>.
	+ This is not true without additional conditions on \<open>f\<close> and \<open>g\<close>
	+ (\emph{cf.}~the comments following CKS Proposition 6).
	+ So only rather special isomorphisms \<open>\<guillemotleft>\<psi> : g \<star> f\<^sup>* \<Rightarrow> r\<guillemotright>\<close> result from tabulations of \<open>r\<close>.
	+ \<close>
	+
	+ subsection "Tabulation of a Right Adjoint"
	+
	+ text \<open>
	+ Here we obtain a tabulation of the right adjoint of a map. This is CKS Proposition 1(e).
	+ It was somewhat difficult to find the correct way to insert the unitors
	+ that CKS omit. At first I thought I could only prove this under the assumption
	+ that the bicategory is normal, but later I saw how to do it in the general case.
	+ \<close>
	+
	+ context adjunction_in_bicategory
	+ begin
	+
	+ lemma tabulation_of_right_adjoint:
	+ shows "tabulation V H \<a> \<i> src trg g \<eta> f (src f)"
	+ proof -
	+ interpret T: tabulation_data V H \<a> \<i> src trg g \<eta> f \<open>src f\<close>
	+ using unit_in_hom antipar by (unfold_locales, simp_all)
	+ show ?thesis
	+ proof
	+ show T1: "\<And>u \<omega>. \<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> g \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
	+ \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> src f \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ T.composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
	+ proof -
	+ fix u v \<omega>
	+ assume u: "ide u"
	+ assume \<omega>: "\<guillemotleft>\<omega> : v \<Rightarrow> g \<star> u\<guillemotright>"
	+ have v: "ide v"
	+ using \<omega> by auto
	+ have 1: "src g = trg u"
	+ using \<omega> by (metis arr_cod in_homE not_arr_null seq_if_composable)
	+ have 2: "src f = trg v"
	+ using \<omega> 1 u ide_right antipar(1)
	+ by (metis horizontal_homs.trg_cod horizontal_homs.trg_dom horizontal_homs_axioms
	+ hseqI' ideD(1) in_homE hcomp_simps(2))
	+ text \<open>It seems clear that we need to take \<open>w = v\<close> and \<open>\<nu> = \<l>\<^sup>-\<^sup>1[v]\<close>. \<close>
	+ let ?w = v
	+ let ?\<nu> = "\<l>\<^sup>-\<^sup>1[v]"
	+ have \<nu>: "\<guillemotleft>?\<nu> : v \<Rightarrow> src f \<star> ?w\<guillemotright> \<and> iso ?\<nu>"
	+ using v 2 iso_lunit' by auto
	+ text \<open>
	+ We need \<open>\<theta>\<close>, defined to satisfy \<open>\<guillemotleft>\<theta> : f \<star> v \<Rightarrow> u\<guillemotright>\<close> and
	+ \<open>\<omega> = (v \<star> \<theta>) \<cdot> \<a>[v, f, v] \<cdot> (\<eta> \<star> w) \<cdot> \<l>\<^sup>-\<^sup>1[v]\<close>.
	+ We have \<open>\<guillemotleft>\<omega> : v \<Rightarrow> g \<star> u\<guillemotright>\<close>, so we can get arrow \<open>\<guillemotleft>\<theta> : f \<star> v \<Rightarrow> u\<guillemotright>\<close> by adjoint transpose.
	+ Note that this uses adjoint transpose on the \emph{left}, rather than on the right.
	+ \<close>
	+ let ?\<theta> = "trnl\<^sub>\<epsilon> u \<omega>"
	+ have \<theta>: "\<guillemotleft>?\<theta> : f \<star> ?w \<Rightarrow> u\<guillemotright>"
	+ using u v antipar 1 2 \<omega> adjoint_transpose_left(2) [of u v] by auto
	+ text \<open>
	+ Now, \<open>trnl\<^sub>\<eta> v \<theta> \<equiv> (g \<star> \<theta>) \<cdot> \<a>[g, f, v] \<cdot> (\<eta> \<star> v) \<cdot> \<l>\<^sup>-\<^sup>1[v]\<close>, which suggests that
	+ we ought to have \<open>\<omega> = trnl\<^sub>\<eta> v \<theta>\<close> and \<open>\<nu> = \<l>\<^sup>-\<^sup>1[v]\<close>;
	+ \<close>
	+ have "T.composite_cell ?w ?\<theta> \<cdot> ?\<nu> = \<omega>"
	+ using u v \<omega> 1 2 adjoint_transpose_left(4) [of u v \<omega>] trnl\<^sub>\<eta>_def comp_assoc by simp
	+ thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> src f \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ T.composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
	+ using v \<theta> \<nu> antipar comp_assoc by blast
	+ qed
	+ show T2: "\<And>u w w' \<theta> \<theta>' \<beta>.
	+ \<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>;
	+ \<guillemotleft>\<beta> : src f \<star> w \<Rightarrow> src f \<star> w'\<guillemotright>;
	+ T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
	+ \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ proof -
	+ fix u w w' \<theta> \<theta>' \<beta>
	+ assume w: "ide w"
	+ assume w': "ide w'"
	+ assume \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>"
	+ assume \<theta>': "\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>"
	+ assume \<beta>: "\<guillemotleft>\<beta> : src f \<star> w \<Rightarrow> src f \<star> w'\<guillemotright>"
	+ assume E: "T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<cdot> \<beta>"
	+ interpret T: uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg g \<eta> f \<open>src f\<close> u w \<theta> w' \<theta>' \<beta>
	+ using w w' \<theta> \<theta>' \<beta> E comp_assoc by (unfold_locales, auto)
	+ have 2: "src f = trg \<beta>"
	+ using antipar by simp
	+ show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ proof -
	+ text \<open>
	+ The requirement \<open>\<beta> = src f \<star> \<gamma>\<close> means we have to essentially invert \<open>\<lambda>\<gamma>. src f \<star> \<gamma>\<close>
	+ to obtain \<open>\<gamma>\<close>. CKS say only: ``the strong form of \<open>T2\<close> is clear since \<open>g = 1\<close>"
	+ (here by ``\<open>g\<close>'' they are referring to \<open>dom \<eta>\<close>, the ``output leg'' of the span in
	+ the tabulation). This would mean that we would have to take \<open>\<gamma> = \<beta>\<close>, which doesn't
	+ work for a general bicategory (we don't necessarily have \<open>src f \<star> \<gamma> = \<gamma>\<close>).
	+ For a general bicategory, we have to take \<open>\<gamma> = \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w]\<close>.
	+ \<close>
	+ let ?\<gamma> = "\<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w]"
	+ have \<gamma>: "\<guillemotleft>?\<gamma> : w \<Rightarrow> w'\<guillemotright>"
	+ using \<beta> by simp
	+ have 3: "\<beta> = src f \<star> ?\<gamma>"
	+ proof -
	+ have "\<beta> = \<l>\<^sup>-\<^sup>1[w'] \<cdot> ?\<gamma> \<cdot> \<l>[w]"
	+ using \<beta> iso_lunit
	+ by (simp add: comp_arr_dom invert_side_of_triangle(1) comp_assoc)
	+ also have "... = \<l>\<^sup>-\<^sup>1[w'] \<cdot> \<l>[w'] \<cdot> (src f \<star> ?\<gamma>)"
	+ using \<gamma> lunit_naturality
	+ by (metis T.uw\<theta>.w_simps(4) in_homE trg_dom)
	+ also have "... = (\<l>\<^sup>-\<^sup>1[w'] \<cdot> \<l>[w']) \<cdot> (src f \<star> ?\<gamma>)"
	+ using comp_assoc by simp
	+ also have "... = src f \<star> ?\<gamma>"
	+ using \<gamma> iso_lunit comp_inv_arr comp_cod_arr
	+ by (metis T.\<beta>_simps(1) calculation comp_ide_arr inv_is_inverse inverse_arrowsE w')
	+ finally show ?thesis by simp
	+ qed
	+ have "\<theta> = \<theta>' \<cdot> (f \<star> ?\<gamma>)"
	+ proof -
	+ have "\<theta> = trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> w \<theta>)"
	+ using \<theta> adjoint_transpose_left(3) [of u w \<theta>] by simp
	+ also have "... = trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> w' \<theta>' \<cdot> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "trnl\<^sub>\<eta> w \<theta> = trnl\<^sub>\<eta> w' \<theta>' \<cdot> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w]"
	+ proof -
	+ have "trnl\<^sub>\<eta> w \<theta> \<cdot> \<l>[w] = (T.composite_cell w \<theta> \<cdot> \<l>\<^sup>-\<^sup>1[w]) \<cdot> \<l>[w]"
	+ unfolding trnl\<^sub>\<eta>_def using comp_assoc by simp
	+ also have "... = T.composite_cell w \<theta> \<cdot> (\<l>\<^sup>-\<^sup>1[w] \<cdot> \<l>[w])"
	+ using comp_assoc by simp
	+ also have 4: "... = T.composite_cell w \<theta>"
	+ using comp_arr_dom by (simp add: comp_inv_arr' hseqI')
	+ also have "... = T.composite_cell w' \<theta>' \<cdot> \<beta>"
	+ using E by simp
	+ also have "... = (T.composite_cell w' \<theta>' \<cdot> \<l>\<^sup>-\<^sup>1[w']) \<cdot> \<l>[w'] \<cdot> \<beta>"
	+ proof -
	+ have "(\<l>\<^sup>-\<^sup>1[w'] \<cdot> \<l>[w']) \<cdot> \<beta> = \<beta>"
	+ using iso_lunit \<beta> comp_cod_arr comp_assoc comp_inv_arr' by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = trnl\<^sub>\<eta> w' \<theta>' \<cdot> \<l>[w'] \<cdot> \<beta>"
	+ unfolding trnl\<^sub>\<eta>_def using comp_assoc by simp
	+ finally have "trnl\<^sub>\<eta> w \<theta> \<cdot> \<l>[w] = trnl\<^sub>\<eta> w' \<theta>' \<cdot> \<l>[w'] \<cdot> \<beta>"
	+ by simp
	+ thus ?thesis
	+ using \<beta> 4 invert_side_of_triangle(2) adjoint_transpose_left iso_lunit
	+ trnl\<^sub>\<eta>_def comp_assoc
	+ by metis
	+ qed
	+ thus ?thesis by simp
	+ qed
	+ also have "... = \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> trnl\<^sub>\<eta> w' \<theta>' \<cdot> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w])"
	+ using trnl\<^sub>\<epsilon>_def by simp
	+ also have
	+ "... = \<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> trnl\<^sub>\<eta> w' \<theta>') \<cdot> (f \<star> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w])"
	+ using ide_left ide_right w w' 2 \<beta> \<theta> antipar trnl\<^sub>\<epsilon>_def adjoint_transpose_left
	+ whisker_left
	+ by (metis T.uw\<theta>.\<theta>_simps(1) calculation hseqE seqE)
	+ also have
	+ "... = (\<l>[u] \<cdot> (\<epsilon> \<star> u) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, u] \<cdot> (f \<star> trnl\<^sub>\<eta> w' \<theta>')) \<cdot> (f \<star> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w])"
	+ using comp_assoc by simp
	+ also have "... = trnl\<^sub>\<epsilon> u (trnl\<^sub>\<eta> w' \<theta>') \<cdot> (f \<star> \<l>[w'] \<cdot> \<beta> \<cdot> \<l>\<^sup>-\<^sup>1[w])"
	+ unfolding trnl\<^sub>\<epsilon>_def by simp
	+ also have "... = \<theta>' \<cdot> (f \<star> ?\<gamma>)"
	+ using \<theta>' adjoint_transpose_left(3) by auto
	+ finally show ?thesis by simp
	+ qed
	+ hence "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ using \<gamma> 3 hcomp_obj_arr by auto
	+ moreover have "\<And>\<gamma> \<gamma>'. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>) \<and>
	+ \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>') \<Longrightarrow> \<gamma> = \<gamma>'"
	+ proof -
	+ fix \<gamma> \<gamma>'
	+ assume \<gamma>\<gamma>': "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>) \<and>
	+ \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = src f \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>')"
	+ show "\<gamma> = \<gamma>'"
	+ using \<gamma>\<gamma>' vconn_implies_hpar(2) L.is_faithful [of \<gamma> \<gamma>'] by force
	+ qed
	+ ultimately show ?thesis by blast
	+ qed
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ subsection "Preservation by Isomorphisms"
	+
	+ text \<open>
	+ Next, we show that tabulations are preserved under composition on all three sides by
	+ isomorphisms. This is something that we would expect to hold if ``tabulation'' is a
	+ properly bicategorical notion.
	+ \<close>
	+
	+ context tabulation
	+ begin
	+
	+ text \<open>
	+ Tabulations are preserved under composition of an isomorphism with the ``input leg''.
	+ \<close>
	+
	+ lemma preserved_by_input_iso:
	+ assumes "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
	+ shows "tabulation V H \<a> \<i> src trg r ((r \<star> \<phi>) \<cdot> \<rho>) f' g"
	+ proof -
	+ interpret T': tabulation_data V H \<a> \<i> src trg r \<open>(r \<star> \<phi>) \<cdot> \<rho>\<close> f'
	+ using assms(1) tab_in_hom
	+ apply unfold_locales
	+ apply auto
	+ by force
	+ show ?thesis
	+ proof
	+ show "\<And>u \<omega>. \<lbrakk> ide u; \<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
	+ \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and>
	+ iso \<nu> \<and> T'.composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
	+ proof -
	+ fix u \<omega>
	+ assume u: "ide u" and \<omega>: "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
	+ obtain w \<theta> \<nu> where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and>
	+ iso \<nu> \<and> composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
	+ using u \<omega> T1 by blast
	+ interpret T1: uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho> f g u w \<theta> \<omega> \<nu>
	+ using w\<theta>\<nu> comp_assoc by (unfold_locales, auto)
	+ have 1: "\<guillemotleft>inv \<phi> \<star> w : f' \<star> w \<Rightarrow> f \<star> w\<guillemotright>"
	+ using assms by (intro hcomp_in_vhom, auto)
	+ have "ide w \<and> \<guillemotleft>\<theta> \<cdot> (inv \<phi> \<star> w) : f' \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ T'.composite_cell w (\<theta> \<cdot> (inv \<phi> \<star> w)) \<cdot> \<nu> = \<omega>"
	+ using w\<theta>\<nu> 1
	+ apply (intro conjI)
	+ apply auto[4]
	+ proof -
	+ show "T'.composite_cell w (\<theta> \<cdot> (inv \<phi> \<star> w)) \<cdot> \<nu> = \<omega>"
	+ proof -
	+ have "T'.composite_cell w (\<theta> \<cdot> (inv \<phi> \<star> w)) \<cdot> \<nu> =
	+ (r \<star> \<theta>) \<cdot> ((r \<star> inv \<phi> \<star> w) \<cdot> \<a>[r, f', w]) \<cdot> ((r \<star> \<phi>) \<cdot> \<rho> \<star> w) \<cdot> \<nu>"
	+ using assms(1) 1 whisker_left [of r \<theta> "inv \<phi> \<star> w"] comp_assoc by auto
	+ also have "... = (r \<star> \<theta>) \<cdot> (\<a>[r, f, w] \<cdot> ((r \<star> inv \<phi>) \<star> w)) \<cdot> ((r \<star> \<phi>) \<cdot> \<rho> \<star> w) \<cdot> \<nu>"
	+ using assms assoc_naturality [of r "inv \<phi>" w]
	+ by (metis 1 T'.tab_simps(1) base_simps(3) base_simps(4) T1.w_simps(5-6)
	+ cod_inv dom_inv hseqE in_homE seqE trg_inv)
	+ also have "... = (r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> ((((r \<star> inv \<phi>) \<star> w) \<cdot> ((r \<star> \<phi>) \<star> w)) \<cdot> (\<rho> \<star> w)) \<cdot> \<nu>"
	+ using whisker_right [of w "r \<star> \<phi>" \<rho>] comp_assoc T1.ide_w vseq_implies_hpar(1)
	+ by auto
	+ also have "... = composite_cell w \<theta> \<cdot> \<nu>"
	+ proof -
	+ have "(((r \<star> inv \<phi>) \<star> w) \<cdot> ((r \<star> \<phi>) \<star> w)) \<cdot> (\<rho> \<star> w) = \<rho> \<star> w"
	+ proof -
	+ have "\<guillemotleft>r \<star> \<phi> : r \<star> f \<Rightarrow> r \<star> f'\<guillemotright>"
	+ using assms(1) by (intro hcomp_in_vhom, auto)
	+ moreover have "\<guillemotleft>r \<star> inv \<phi> : r \<star> f' \<Rightarrow> r \<star> f\<guillemotright>"
	+ using assms by (intro hcomp_in_vhom, auto)
	+ ultimately show ?thesis
	+ using comp_cod_arr
	+ by (metis T1.w_in_hom(2) tab_simps(1) tab_simps(5) assms(1-2) comp_inv_arr'
	+ in_homE leg0_simps(2) interchange base_in_hom(2) seqI')
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = \<omega>"
	+ using w\<theta>\<nu> by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ T'.composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
	+ by blast
	+ qed
	+ show "\<And>u w w' \<theta> \<theta>' \<beta>. \<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f' \<star> w' \<Rightarrow> u\<guillemotright>;
	+ \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
	+ T'.composite_cell w \<theta> = T'.composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
	+ \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>)"
	+ proof -
	+ fix u w w' \<theta> \<theta>' \<beta>
	+ assume w: "ide w" and w': "ide w'"
	+ and \<theta>: "\<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> u\<guillemotright>" and \<theta>': "\<guillemotleft>\<theta>' : f' \<star> w' \<Rightarrow> u\<guillemotright>"
	+ and \<beta>: "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
	+ and eq: "T'.composite_cell w \<theta> = T'.composite_cell w' \<theta>' \<cdot> \<beta>"
	+ interpret uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg r \<open>(r \<star> \<phi>) \<cdot> \<rho>\<close> f' g u w \<theta> w' \<theta>' \<beta>
	+ using w w' \<theta> \<theta>' \<beta> eq comp_assoc by (unfold_locales, auto)
	+ show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>)"
	+ proof -
	+ have \<phi>_w: "\<guillemotleft>\<phi> \<star> w : f \<star> w \<Rightarrow> f' \<star> w\<guillemotright>"
	+ using assms(1) by (intro hcomp_in_vhom, auto)
	+ have \<phi>_w': "\<guillemotleft>\<phi> \<star> w' : f \<star> w' \<Rightarrow> f' \<star> w'\<guillemotright>"
	+ using assms(1) by (intro hcomp_in_vhom, auto)
	+ have "\<guillemotleft>\<theta> \<cdot> (\<phi> \<star> w) : f \<star> w \<Rightarrow> u\<guillemotright>"
	+ using \<theta> assms(1) by fastforce
	+ moreover have "\<guillemotleft>\<theta>' \<cdot> (\<phi> \<star> w') : f \<star> w' \<Rightarrow> u\<guillemotright>"
	+ using \<theta>' assms(1) by fastforce
	+ moreover have "composite_cell w (\<theta> \<cdot> (\<phi> \<star> w)) = composite_cell w' (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> \<beta>"
	+ proof -
	+ have "composite_cell w (\<theta> \<cdot> (\<phi> \<star> w)) =
	+ (r \<star> \<theta>) \<cdot> ((r \<star> \<phi> \<star> w) \<cdot> \<a>[r, f, w]) \<cdot> (\<rho> \<star> w)"
	+ using assms(2) \<phi>_w \<theta> whisker_left comp_assoc by auto
	+ also have "... = (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot> ((r \<star> \<phi>) \<star> w) \<cdot> (\<rho> \<star> w)"
	+ using assms(1) assoc_naturality [of r \<phi> w] comp_assoc
	+ by (metis \<phi>_w T'.tab_simps(1) base_simps(3) base_simps(4) hseq_char
	+ in_homE seqE uw\<theta>.w_simps(5) uw\<theta>.w_simps(6))
	+ also have "... = T'.composite_cell w \<theta>"
	+ using assms(2) w whisker_right [of w] by simp
	+ also have "... = T'.composite_cell w' \<theta>' \<cdot> \<beta>"
	+ using eq by simp
	+ also have "... = (r \<star> \<theta>') \<cdot> (\<a>[r, f', w'] \<cdot> ((r \<star> \<phi>) \<star> w')) \<cdot> (\<rho> \<star> w') \<cdot> \<beta>"
	+ using assms(2) w' whisker_right [of w'] comp_assoc by simp
	+ also have "... = ((r \<star> \<theta>') \<cdot> (r \<star> \<phi> \<star> w')) \<cdot> \<a>[r, f, w'] \<cdot> (\<rho> \<star> w') \<cdot> \<beta>"
	+ using assms(1) assoc_naturality [of r \<phi> w'] comp_assoc
	+ by (metis \<phi>_w' T'.tab_simps(1) base_simps(3) base_simps(4) hseqE in_homE seqE
	+ uw'\<theta>'.w_simps(5) uw'\<theta>'.w_simps(6))
	+ also have "... = composite_cell w' (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> \<beta>"
	+ using assms(2) whisker_left [of r] \<open>\<guillemotleft>\<theta>' \<cdot> (\<phi> \<star> w') : f \<star> w' \<Rightarrow> u\<guillemotright>\<close> comp_assoc
	+ by auto
	+ finally show ?thesis by simp
	+ qed
	+ ultimately have *: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and>
	+ \<theta> \<cdot> (\<phi> \<star> w) = (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>)"
	+ using w w' \<beta> T2 by auto
	+ show ?thesis
	+ proof -
	+ have **: "\<And>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<Longrightarrow> \<theta>' \<cdot> (\<phi> \<star> w') \<cdot> (f \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = \<theta>' \<cdot> (f' \<star> \<gamma>)"
	+ proof -
	+ fix \<gamma>
	+ assume \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
	+ have "\<theta>' \<cdot> (\<phi> \<star> w') \<cdot> (f \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = \<theta>' \<cdot> (\<phi> \<star> w') \<cdot> (f \<cdot> inv \<phi> \<star> \<gamma> \<cdot> w)"
	+ using \<gamma> assms(1-2) interchange
	+ by (metis arr_inv cod_inv in_homE leg0_simps(2) leg0_simps(4) uw\<theta>.w_in_hom(2)
	+ seqI)
	+ also have "... = \<theta>' \<cdot> (\<phi> \<cdot> f \<cdot> inv \<phi> \<star> w' \<cdot> \<gamma> \<cdot> w)"
	+ using assms(1-2) interchange
	+ by (metis \<gamma> arr_inv cod_inv comp_arr_dom comp_cod_arr in_homE seqI)
	+ also have "... = \<theta>' \<cdot> (f' \<star> \<gamma>)"
	+ proof -
	+ have "\<phi> \<cdot> f \<cdot> inv \<phi> = f'"
	+ using assms(1-2) comp_cod_arr comp_arr_inv' by auto
	+ moreover have "w' \<cdot> \<gamma> \<cdot> w = \<gamma>"
	+ using \<gamma> comp_arr_dom comp_cod_arr by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ finally show "\<theta>' \<cdot> (\<phi> \<star> w') \<cdot> (f \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = \<theta>' \<cdot> (f' \<star> \<gamma>)" by simp
	+ qed
	+ obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and>
	+ \<theta> \<cdot> (\<phi> \<star> w) = (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>)"
	+ using * by blast
	+ have "\<theta> = \<theta>' \<cdot> (\<phi> \<star> w') \<cdot> (f \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w)"
	+ proof -
	+ have "seq (\<theta>' \<cdot> (\<phi> \<star> w')) (f \<star> \<gamma>)"
	+ using assms(2) \<phi>_w \<phi>_w' \<gamma> \<beta> \<theta>
	+ apply (intro seqI hseqI')
	+ apply auto
	+ by (metis seqE seqI')
	+ thus ?thesis
	+ using assms \<phi>_w \<gamma> comp_assoc invert_side_of_triangle(2) iso_hcomp
	+ by (metis hcomp_in_vhomE ide_is_iso inv_hcomp inv_ide w)
	+ qed
	+ hence "\<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>)"
	+ using \<gamma> ** by simp
	+ hence "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>)"
	+ using \<gamma> by auto
	+ moreover have "\<And>\<gamma> \<gamma>'. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>) \<and>
	+ \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>')
	+ \<Longrightarrow> \<gamma> = \<gamma>'"
	+ proof -
	+ fix \<gamma> \<gamma>'
	+ assume A: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>) \<and>
	+ \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>')"
	+ have "\<theta> \<cdot> (\<phi> \<star> w) = (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>)"
	+ proof -
	+ have "\<theta> = ((\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>)) \<cdot> (inv \<phi> \<star> w)"
	+ using A ** comp_assoc by simp
	+ thus ?thesis
	+ using assms(1-2) A iso_inv_iso
	+ by (metis comp_arr_dom comp_cod_arr in_homE comp_assoc interchange)
	+ qed
	+ moreover have "\<theta> \<cdot> (\<phi> \<star> w) = (\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>')"
	+ proof -
	+ have "\<theta> = ((\<theta>' \<cdot> (\<phi> \<star> w')) \<cdot> (f \<star> \<gamma>')) \<cdot> (inv \<phi> \<star> w)"
	+ using A ** comp_assoc by auto
	+ thus ?thesis
	+ using assms(1-2) A iso_inv_iso
	+ by (metis comp_arr_dom comp_cod_arr in_homE comp_assoc interchange)
	+ qed
	+ ultimately show "\<gamma> = \<gamma>'"
	+ using A * by blast
	+ qed
	+ ultimately show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f' \<star> \<gamma>)"
	+ by metis
	+ qed
	+ qed
	+ qed
	+ qed
	+ qed
	+
	+ text \<open>
	+ Similarly, tabulations are preserved under composition of an isomorphism with
	+ the ``output leg''.
	+ \<close>
	+
	+ lemma preserved_by_output_iso:
	+ assumes "\<guillemotleft>\<phi> : g' \<Rightarrow> g\<guillemotright>" and "iso \<phi>"
	+ shows "tabulation V H \<a> \<i> src trg r (\<rho> \<cdot> \<phi>) f g'"
	+ proof -
	+ have \<tau>\<phi>: "\<guillemotleft>\<rho> \<cdot> \<phi> : g' \<Rightarrow> r \<star> f\<guillemotright>"
	+ using assms by auto
	+ interpret T': tabulation_data V H \<a> \<i> src trg r \<open>\<rho> \<cdot> \<phi>\<close> f g'
	+ using assms(2) \<tau>\<phi> by (unfold_locales, auto)
	+ have \<phi>_in_hhom: "\<guillemotleft>\<phi> : src f \<rightarrow> trg r\<guillemotright>"
	+ using assms src_cod [of \<phi>] trg_cod [of \<phi>]
	+ by (elim in_homE, simp)
	+ show ?thesis
	+ proof
	+ fix u \<omega>
	+ assume u: "ide u" and \<omega>: "\<guillemotleft>\<omega> : dom \<omega> \<Rightarrow> r \<star> u\<guillemotright>"
	+ show "\<exists>w \<theta> \<nu>'. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu>' : dom \<omega> \<Rightarrow> g' \<star> w\<guillemotright> \<and> iso \<nu>' \<and>
	+ T'.composite_cell w \<theta> \<cdot> \<nu>' = \<omega>"
	+ proof -
	+ obtain w \<theta> \<nu> where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega> \<Rightarrow> g \<star> w\<guillemotright> \<and>
	+ iso \<nu> \<and> composite_cell w \<theta> \<cdot> \<nu> = \<omega>"
	+ using u \<omega> T1 [of u \<omega>] by auto
	+ interpret uw\<theta>\<omega>\<nu>: uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho> f g u w \<theta> \<omega> \<nu>
	+ using w\<theta>\<nu> comp_assoc by (unfold_locales, auto)
	+ let ?\<nu>' = "(inv \<phi> \<star> w) \<cdot> \<nu>"
	+ have \<nu>': "\<guillemotleft>?\<nu>' : dom \<omega> \<Rightarrow> g' \<star> w\<guillemotright>"
	+ using assms \<phi>_in_hhom uw\<theta>\<omega>\<nu>.\<nu>_in_hom
	+ by (intro comp_in_homI, auto)
	+ moreover have "iso ?\<nu>'"
	+ using assms \<nu>' w\<theta>\<nu> \<phi>_in_hhom iso_inv_iso
	+ by (intro iso_hcomp isos_compose, auto)
	+ moreover have "T'.composite_cell w \<theta> \<cdot> ?\<nu>' = \<omega>"
	+ proof -
	+ have "composite_cell w \<theta> \<cdot> ((\<phi> \<star> w) \<cdot> ?\<nu>') = \<omega>"
	+ proof -
	+ have "(\<phi> \<star> w) \<cdot> ?\<nu>' = \<nu>"
	+ using assms \<nu>' \<phi>_in_hhom whisker_right comp_cod_arr comp_assoc
	+ by (metis comp_arr_inv' in_homE leg1_simps(2) uw\<theta>\<omega>\<nu>.uw\<theta>\<omega>\<nu>)
	+ thus ?thesis
	+ using w\<theta>\<nu> by simp
	+ qed
	+ moreover have "(\<rho> \<cdot> \<phi> \<star> w) \<cdot> ?\<nu>' = (\<rho> \<star> w) \<cdot> ((\<phi> \<star> w) \<cdot> ?\<nu>')"
	+ using assms \<phi>_in_hhom whisker_right comp_assoc by simp
	+ ultimately show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ ultimately show ?thesis
	+ using w\<theta>\<nu> by blast
	+ qed
	+ next
	+ fix u w w' \<theta> \<theta>' \<beta>'
	+ assume w: "ide w" and w': "ide w'"
	+ and \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>" and \<theta>': "\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>"
	+ and \<beta>': "\<guillemotleft>\<beta>' : g' \<star> w \<Rightarrow> g' \<star> w'\<guillemotright>"
	+ and eq': "T'.composite_cell w \<theta> = T'.composite_cell w' \<theta>' \<cdot> \<beta>'"
	+ interpret uw\<theta>w'\<theta>'\<beta>: uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg r \<open>\<rho> \<cdot> \<phi>\<close> f g' u w \<theta> w' \<theta>' \<beta>'
	+ using assms w w' \<theta> \<theta>' \<beta>' eq' comp_assoc by (unfold_locales, auto)
	+ let ?\<beta> = "(\<phi> \<star> w') \<cdot> \<beta>' \<cdot> (inv \<phi> \<star> w)"
	+ have \<beta>: "\<guillemotleft>?\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
	+ using assms \<phi>_in_hhom \<beta>'
	+ by (intro comp_in_homI hcomp_in_vhom, auto)
	+ have eq: "composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> ((\<phi> \<star> w') \<cdot> \<beta>' \<cdot> (inv \<phi> \<star> w))"
	+ proof -
	+ have "composite_cell w \<theta> = (r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> ((\<rho> \<star> w) \<cdot> (\<phi> \<star> w)) \<cdot> (inv \<phi> \<star> w)"
	+ proof -
	+ have "\<rho> \<star> w = (\<rho> \<star> w) \<cdot> (\<phi> \<star> w) \<cdot> (inv \<phi> \<star> w)"
	+ using assms w \<phi>_in_hhom whisker_right comp_arr_dom comp_arr_inv'
	+ by (metis tab_simps(1) tab_simps(4) in_homE leg1_simps(2))
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = T'.composite_cell w \<theta> \<cdot> (inv \<phi> \<star> w)"
	+ using assms \<phi>_in_hhom whisker_right comp_assoc by simp
	+ also have "... = T'.composite_cell w' \<theta>' \<cdot> (\<beta>' \<cdot> (inv \<phi> \<star> w))"
	+ using eq' comp_assoc by simp
	+ also have "... = composite_cell w' \<theta>' \<cdot> ((\<phi> \<star> w') \<cdot> \<beta>' \<cdot> (inv \<phi> \<star> w))"
	+ using assms \<phi>_in_hhom whisker_right comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ proof -
	+ obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> ?\<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ using assms w w' \<theta> \<theta>' \<beta> eq \<phi>_in_hhom T2 [of w w' \<theta> u \<theta>' ?\<beta>] by auto
	+ have "\<beta>' = g' \<star> \<gamma>"
	+ proof -
	+ have "g \<star> \<gamma> = (\<phi> \<star> w') \<cdot> \<beta>' \<cdot> (inv \<phi> \<star> w)"
	+ using \<gamma> by simp
	+ hence "(inv \<phi> \<star> w') \<cdot> (g \<star> \<gamma>) = \<beta>' \<cdot> (inv \<phi> \<star> w)"
	+ using assms w' \<beta> \<phi>_in_hhom invert_side_of_triangle arrI iso_hcomp
	+ hseqE ide_is_iso inv_hcomp inv_ide seqE
	+ by metis
	+ hence "\<beta>' = (inv \<phi> \<star> w') \<cdot> (g \<star> \<gamma>) \<cdot> (\<phi> \<star> w)"
	+ using assms w \<beta> \<phi>_in_hhom invert_side_of_triangle comp_assoc seqE
	+ by (metis comp_arr_dom in_homE local.uw\<theta>w'\<theta>'\<beta>.\<beta>_simps(4) whisker_right)
	+ also have "... = (inv \<phi> \<star> w') \<cdot> (\<phi> \<star> \<gamma>)"
	+ using assms \<phi>_in_hhom \<gamma> interchange comp_arr_dom comp_cod_arr
	+ by (metis in_homE)
	+ also have "... = g' \<star> \<gamma>"
	+ using assms \<phi>_in_hhom \<gamma> interchange comp_inv_arr inv_is_inverse comp_cod_arr
	+ by (metis arr_dom calculation in_homE)
	+ finally show ?thesis by simp
	+ qed
	+ hence "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ using \<beta> \<gamma> by auto
	+ moreover have "\<And>\<gamma> \<gamma>'. \<lbrakk> \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>);
	+ \<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>') \<rbrakk> \<Longrightarrow> \<gamma> = \<gamma>'"
	+ proof -
	+ have *: "\<And>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<Longrightarrow> (\<phi> \<star> w') \<cdot> (g' \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = g \<star> \<gamma>"
	+ proof -
	+ fix \<gamma>
	+ assume \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>"
	+ have "(\<phi> \<star> w') \<cdot> (g' \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = (\<phi> \<star> w') \<cdot> (inv \<phi> \<star> \<gamma>)"
	+ using assms \<phi>_in_hhom \<gamma> interchange comp_arr_dom comp_cod_arr
	+ by (metis arr_dom comp_inv_arr' in_homE invert_side_of_triangle(2))
	+ also have "... = g \<star> \<gamma>"
	+ using assms \<phi>_in_hhom interchange comp_arr_inv inv_is_inverse comp_cod_arr
	+ by (metis \<gamma> comp_arr_inv' in_homE leg1_simps(2))
	+ finally show "(\<phi> \<star> w') \<cdot> (g' \<star> \<gamma>) \<cdot> (inv \<phi> \<star> w) = g \<star> \<gamma>" by blast
	+ qed
	+ fix \<gamma> \<gamma>'
	+ assume \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ and \<gamma>': "\<guillemotleft>\<gamma>' : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma>' \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>')"
	+ show "\<gamma> = \<gamma>'"
	+ using w w' \<theta> \<theta>' \<beta> \<gamma> \<gamma>' eq * T2 by metis
	+ qed
	+ ultimately show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta>' = g' \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)" by blast
	+ qed
	+ qed
	+ qed
	+
	+ text \<open>
	+ Finally, tabulations are preserved by composition with an isomorphism on the ``base''.
	+ \<close>
	+
	+ lemma is_preserved_by_base_iso:
	+ assumes "\<guillemotleft>\<phi> : r \<Rightarrow> r'\<guillemotright>" and "iso \<phi>"
	+ shows "tabulation V H \<a> \<i> src trg r' ((\<phi> \<star> f) \<cdot> \<rho>) f g"
	+ proof -
	+ have \<phi>f: "\<guillemotleft>\<phi> \<star> f : r \<star> f \<Rightarrow> r' \<star> f\<guillemotright>"
	+ using assms ide_leg0 by auto
	+ interpret T: tabulation_data V H \<a> \<i> src trg r' \<open>(\<phi> \<star> f) \<cdot> \<rho>\<close> f
	+ proof
	+ show ide_r': "ide r'" using assms by auto
	+ show "ide f" using ide_leg0 by auto
	+ show "\<guillemotleft>(\<phi> \<star> f) \<cdot> \<rho> : g \<Rightarrow> r' \<star> f\<guillemotright>"
	+ using tab_in_hom \<phi>f by force
	+ qed
	+ show ?thesis
	+ proof
	+ have *: "\<And>u v w \<theta> \<nu>. \<lbrakk> ide u; ide v; ide w; \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<nu> : v \<Rightarrow> g \<star> w\<guillemotright> \<rbrakk> \<Longrightarrow>
	+ ((\<phi> \<star> u) \<cdot> (r \<star> \<theta>)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> =
	+ T.composite_cell w \<theta> \<cdot> \<nu>"
	+ proof -
	+ fix u v w \<theta> \<nu>
	+ assume u: "ide u" and v: "ide v" and w: "ide w"
	+ and \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>" and \<nu>: "\<guillemotleft>\<nu> : v \<Rightarrow> g \<star> w\<guillemotright>"
	+ have fw: "hseq f w"
	+ using \<theta> ide_dom [of \<theta>] by fastforce
	+ have r\<theta>: "hseq r \<theta>"
	+ using \<theta> ide_base ide_dom [of \<theta>] trg_dom [of \<theta>] by fastforce
	+ have "((\<phi> \<star> u) \<cdot> (r \<star> \<theta>)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> =
	+ ((r' \<star> \<theta>) \<cdot> (\<phi> \<star> f \<star> w)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu>"
	+ using assms u w ide_base ide_leg0 \<theta> interchange comp_arr_dom comp_cod_arr
	+ by (metis r\<theta> hseq_char in_homE)
	+ also have "... = (r' \<star> \<theta>) \<cdot> ((\<phi> \<star> f \<star> w) \<cdot> \<a>[r, f, w]) \<cdot> (\<rho> \<star> w) \<cdot> \<nu>"
	+ using comp_assoc by simp
	+ also have "... = (r' \<star> \<theta>) \<cdot> \<a>[r', f, w] \<cdot> (((\<phi> \<star> f) \<star> w) \<cdot> (\<rho> \<star> w)) \<cdot> \<nu>"
	+ proof -
	+ have "(\<phi> \<star> f \<star> w) \<cdot> \<a>[r, f, w] = \<a>[r', f, w] \<cdot> ((\<phi> \<star> f) \<star> w)"
	+ using assms ide_leg0 w assoc_naturality [of \<phi> f w] fw by fastforce
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = T.composite_cell w \<theta> \<cdot> \<nu>"
	+ using assms ide_leg0 whisker_right fw T.tab_in_hom arrI w comp_assoc by auto
	+ finally show "((\<phi> \<star> u) \<cdot> (r \<star> \<theta>)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu> = T.composite_cell w \<theta> \<cdot> \<nu>"
	+ by simp
	+ qed
	+ show "\<And>u \<omega>'. \<lbrakk> ide u; \<guillemotleft>\<omega>' : dom \<omega>' \<Rightarrow> r' \<star> u\<guillemotright> \<rbrakk> \<Longrightarrow>
	+ \<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : dom \<omega>' \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ T.composite_cell w \<theta> \<cdot> \<nu> = \<omega>'"
	+ proof -
	+ fix u v \<omega>'
	+ assume u: "ide u" and \<omega>': "\<guillemotleft>\<omega>' : v \<Rightarrow> r' \<star> u\<guillemotright>"
	+ have \<omega>: "\<guillemotleft>(inv \<phi> \<star> u) \<cdot> \<omega>' : v \<Rightarrow> r \<star> u\<guillemotright>"
	+ proof
	+ show "\<guillemotleft>\<omega>' : v \<Rightarrow> r' \<star> u\<guillemotright>" by fact
	+ show "\<guillemotleft>inv \<phi> \<star> u : r' \<star> u \<Rightarrow> r \<star> u\<guillemotright>"
	+ proof -
	+ have "ide (r' \<star> u)"
	+ using \<omega>' ide_cod by fastforce
	+ hence "hseq r' u" by simp
	+ thus ?thesis
	+ using assms u by auto
	+ qed
	+ qed
	+ have \<phi>u: "hseq \<phi> u"
	+ using assms \<omega> hseqI
	+ by (metis arrI ide_is_iso iso_hcomp iso_is_arr seqE seq_if_composable
	+ src_inv u)
	+ obtain w \<theta> \<nu> where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ composite_cell w \<theta> \<cdot> \<nu> = (inv \<phi> \<star> u) \<cdot> \<omega>'"
	+ using u \<omega> T1 [of u "(inv \<phi> \<star> u) \<cdot> \<omega>'"] \<phi>f in_homE seqI' by auto
	+
	+ interpret uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho> f g u w \<theta> \<open>(inv \<phi> \<star> u) \<cdot> \<omega>'\<close> \<nu>
	+ using w\<theta>\<nu> \<omega> comp_assoc by (unfold_locales, auto)
	+
	+ have "ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ T.composite_cell w \<theta> \<cdot> \<nu> = \<omega>'"
	+ proof -
	+ have "\<omega>' = ((\<phi> \<star> u) \<cdot> (r \<star> \<theta>)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu>"
	+ proof -
	+ have "seq (r \<star> \<theta>) (\<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> \<nu>)" by fastforce
	+ moreover have "iso (inv \<phi> \<star> u)"
	+ using assms u iso_hcomp iso_inv_iso \<phi>u by auto
	+ moreover have "inv (inv \<phi> \<star> u) = \<phi> \<star> u"
	+ using assms u iso_hcomp iso_inv_iso \<phi>u by auto
	+ ultimately show ?thesis
	+ using invert_side_of_triangle(1) w\<theta>\<nu> comp_assoc by metis
	+ qed
	+ also have "... = T.composite_cell w \<theta> \<cdot> \<nu>"
	+ using u w\<theta>\<nu> * [of u v w \<theta> \<nu>] by force
	+ finally have "\<omega>' = T.composite_cell w \<theta> \<cdot> \<nu>" by simp
	+ thus ?thesis
	+ using w\<theta>\<nu> by simp
	+ qed
	+ thus "\<exists>w \<theta> \<nu>. ide w \<and> \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright> \<and> \<guillemotleft>\<nu> : v \<Rightarrow> g \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ T.composite_cell w \<theta> \<cdot> \<nu> = \<omega>'"
	+ by blast
	+ qed
	+ show "\<And>u w w' \<theta> \<theta>' \<beta>. \<lbrakk> ide w; ide w'; \<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>;
	+ \<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>;
	+ T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<cdot> \<beta> \<rbrakk> \<Longrightarrow>
	+ \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ proof -
	+ fix u w w' \<theta> \<theta>' \<beta>
	+ assume w: "ide w" and w': "ide w'"
	+ and \<theta>: "\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> u\<guillemotright>" and \<theta>': "\<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> u\<guillemotright>"
	+ and \<beta>: "\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>"
	+ and eq': "T.composite_cell w \<theta> = T.composite_cell w' \<theta>' \<cdot> \<beta>"
	+ interpret T: uw\<theta>w'\<theta>'\<beta> V H \<a> \<i> src trg r' \<open>(\<phi> \<star> f) \<cdot> \<rho>\<close> f g u w \<theta> w' \<theta>' \<beta>
	+ using w w' \<theta> \<theta>' \<beta> eq' comp_assoc
	+ by (unfold_locales, auto)
	+ have eq: "composite_cell w \<theta> = composite_cell w' \<theta>' \<cdot> \<beta>"
	+ proof -
	+ have "(\<phi> \<star> u) \<cdot> composite_cell w \<theta> = (\<phi> \<star> u) \<cdot> composite_cell w' \<theta>' \<cdot> \<beta>"
	+ proof -
	+ have "(\<phi> \<star> u) \<cdot> composite_cell w \<theta> =
	+ ((\<phi> \<star> u) \<cdot> (r \<star> \<theta>)) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w) \<cdot> (g \<star> w)"
	+ proof -
	+ have "\<guillemotleft>\<rho> \<star> w : g \<star> w \<Rightarrow> (r \<star> f) \<star> w\<guillemotright>"
	+ using w by auto
	+ thus ?thesis
	+ using comp_arr_dom comp_assoc by auto
	+ qed
	+ also have "... = T.composite_cell w \<theta> \<cdot> (g \<star> w)"
	+ using * [of u "g \<star> w" w \<theta> "g \<star> w"] by fastforce
	+ also have "... = T.composite_cell w \<theta>"
	+ proof -
	+ have "\<guillemotleft>(\<phi> \<star> f) \<cdot> \<rho> \<star> w : g \<star> w \<Rightarrow> (r' \<star> f) \<star> w\<guillemotright>"
	+ using assms by fastforce
	+ thus ?thesis
	+ using comp_arr_dom comp_assoc by auto
	+ qed
	+ also have "... = T.composite_cell w' \<theta>' \<cdot> \<beta>"
	+ using eq' by simp
	+ also have "... = ((\<phi> \<star> u) \<cdot> (r \<star> \<theta>')) \<cdot> \<a>[r, f, w'] \<cdot> (\<rho> \<star> w') \<cdot> \<beta>"
	+ using * [of u "g \<star> w" w' \<theta>' \<beta>] by fastforce
	+ finally show ?thesis
	+ using comp_assoc by simp
	+ qed
	+ moreover have "iso (\<phi> \<star> u)"
	+ using assms by auto
	+ moreover have "seq (\<phi> \<star> u) ((r \<star> \<theta>) \<cdot> \<a>[r, f, w] \<cdot> (\<rho> \<star> w))"
	+ proof -
	+ have "\<guillemotleft>\<phi> \<star> u : r \<star> u \<Rightarrow> r' \<star> u\<guillemotright>"
	+ using assms by (intro hcomp_in_vhom, auto)
	+ thus ?thesis
	+ using composite_cell_in_hom [of w u \<theta>] by auto
	+ qed
	+ moreover have "seq (\<phi> \<star> u) (composite_cell w' \<theta>' \<cdot> \<beta>)"
	+ using assms ide_leg0 w w' \<theta> \<theta>' \<beta> calculation(1) calculation(3) by auto
	+ ultimately show ?thesis
	+ using monoE section_is_mono iso_is_section by metis
	+ qed
	+ show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<cdot> (f \<star> \<gamma>)"
	+ using w w' \<theta> \<theta>' \<beta> eq T2 by simp
	+ qed
	+ qed
	+ qed
	+
	+ end
	+
	+ subsection "Canonical Tabulations"
	+
	+ text \<open>
	+ If the 1-cell \<open>g \<star> f\<^sup>*\<close> has any tabulation \<open>(f, \<rho>, g)\<close>, then it has the canonical
	+ tabulation obtained as the adjoint transpose of (the identity on) \<open>g \<star> f\<^sup>*\<close>.
	+ \<close>
	+
	+ context map_in_bicategory
	+ begin
	+
	+ lemma canonical_tabulation:
	+ assumes "ide g" and "src f = src g"
	+ and "\<exists>\<rho>. tabulation V H \<a> \<i> src trg (g \<star> f\<^sup>*) \<rho> f g"
	+ shows "tabulation V H \<a> \<i> src trg (g \<star> f\<^sup>) (trnr\<^sub>\<eta> g (g \<star> f\<^sup>)) f g"
	+ proof -
	+ have 1: "ide (g \<star> f\<^sup>*)"
	+ using assms(1-2) ide_right antipar by simp
	+ obtain \<rho> where \<rho>: "tabulation V H \<a> \<i> src trg (g \<star> f\<^sup>*) \<rho> f g"
	+ using assms(3) by auto
	+ interpret \<rho>: tabulation V H \<a> \<i> src trg \<open>g \<star> f\<^sup>*\<close> \<rho> f g
	+ using \<rho> by auto
	+ let ?\<psi> = "trnr\<^sub>\<epsilon> (g \<star> f\<^sup>*) \<rho>"
	+ have 3: "\<guillemotleft>?\<psi> : g \<star> f\<^sup>* \<Rightarrow> g \<star> f\<^sup>*\<guillemotright> \<and> iso ?\<psi>"
	+ using \<rho>.yields_isomorphic_representation by blast
	+ hence "tabulation (\<cdot>) (\<star>) \<a> \<i> src trg (g \<star> f\<^sup>*) ((inv ?\<psi> \<star> f) \<cdot> \<rho>) f g"
	+ using \<rho>.is_preserved_by_base_iso [of "inv ?\<psi>" "g \<star> f\<^sup>*"] iso_inv_iso by simp
	+ moreover have "(inv ?\<psi> \<star> f) \<cdot> \<rho> = trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)"
	+ proof -
	+ have "(inv ?\<psi> \<star> f) \<cdot> \<rho> = ((inv ?\<psi> \<star> f) \<cdot> (?\<psi> \<star> f)) \<cdot> trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)"
	+ using \<rho>.\<rho>_in_terms_of_rep comp_assoc by simp
	+ also have "... = ((g \<star> f\<^sup>) \<star> f) \<cdot> trnr\<^sub>\<eta> g (g \<star> f\<^sup>)"
	+ proof -
	+ have "src (inv ?\<psi>) = trg f"
	+ using 3 antipar
	+ by (metis \<rho>.leg0_simps(3) \<rho>.base_in_hom(2) seqI' src_inv vseq_implies_hpar(1))
	+ hence "(inv ?\<psi> \<star> f) \<cdot> (?\<psi> \<star> f) = (g \<star> f\<^sup>*) \<star> f"
	+ using 3 whisker_right [of f "inv ?\<psi>" ?\<psi>] inv_is_inverse comp_inv_arr by auto
	+ thus ?thesis
	+ using comp_cod_arr by simp
	+ qed
	+ also have "... = trnr\<^sub>\<eta> g (g \<star> f\<^sup>*)"
	+ proof -
	+ have "src (g \<star> f\<^sup>*) = trg f" by simp
	+ moreover have "ide g" by simp
	+ ultimately have "\<guillemotleft>trnr\<^sub>\<eta> g (g \<star> f\<^sup>) : g \<Rightarrow> (g \<star> f\<^sup>) \<star> f\<guillemotright>"
	+ using 1 adjoint_transpose_right(1) ide_in_hom antipar by blast
	+ thus ?thesis
	+ using comp_cod_arr by blast
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+
	+ end
	+
	+ subsection "Uniqueness of Tabulations"
	+
	+ text \<open>
	+ We now intend to show that a tabulation of \<open>r\<close> is ``unique up to equivalence'',
	+ which is a property that any proper bicategorical limit should have.
	+ What do we mean by this, exactly?
	+ If we have two tabulations \<open>(f, \<rho>)\<close> and \<open>(f', \<rho>')\<close> of the same 1-cell \<open>r\<close>, then this
	+ induces \<open>\<guillemotleft>w : src f' \<rightarrow> src f\<guillemotright>\<close>, \<open>\<guillemotleft>w' : src f \<rightarrow> src f'\<guillemotright>\<close>, \<open>\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> f'\<guillemotright>\<close>, and
	+ \<open>\<guillemotleft>\<theta> : f \<star> w \<Rightarrow> f'\<guillemotright>\<close>, such that \<open>\<rho>'\<close> is recovered up to isomorphism \<open>\<guillemotleft>\<nu> : g' \<Rightarrow> g \<star> w\<guillemotright>\<close>
	+ from \<open>(w, \<theta>)\<close> by composition with \<open>\<rho>\<close> and \<open>\<rho>\<close> is recovered up to isomorphism
	+ \<open>\<guillemotleft>\<nu>' : g \<Rightarrow> g' \<star> w'\<guillemotright>\<close> from \<open>(w', \<theta>')\<close> by composition with \<open>\<rho>'\<close>.
	+ This means that we obtain isomorphisms \<open>\<guillemotleft>(\<nu>' \<star> w') \<cdot> \<nu> : g' \<Rightarrow> g' \<star> w' \<star> w\<guillemotright>\<close> and
	+ \<open>\<guillemotleft>(\<nu> \<star> w') \<cdot> \<nu>' : g \<Rightarrow> g \<star> w \<star> w'\<guillemotright>\<close>.
	+ These isomorphisms then induce, via \<open>T2\<close>, unique 2-cells from \<open>src f'\<close> to \<open>w' \<star> w\<close>
	+ and from \<open>src f\<close> to \<open>w \<star> w'\<close>, which must be isomorphisms, thus showing \<open>w\<close> and \<open>w'\<close> are
	+ equivalence maps.
	+ \<close>
	+
	+ context tabulation
	+ begin
	+
	+ text \<open>
	+ We will need the following technical lemma.
	+ \<close>
	+
	+ lemma apex_equivalence_lemma:
	+ assumes "\<guillemotleft>\<rho>' : g' \<Rightarrow> r \<star> f'\<guillemotright>"
	+ and "ide w \<and> \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> f\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<Rightarrow> g' \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot> (\<rho>' \<star> w) \<cdot> \<nu> = \<rho>"
	+ and "ide w' \<and> \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>\<nu>' : g' \<Rightarrow> g \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
	+ (r \<star> \<theta>') \<cdot> \<a>[r, f, w'] \<cdot> (\<rho> \<star> w') \<cdot> \<nu>' = \<rho>'"
	+ shows "\<exists>\<phi>. \<guillemotleft>\<phi> : src f \<Rightarrow> w' \<star> w\<guillemotright> \<and> iso \<phi>"
	+ proof -
	+ interpret T': uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho> f g f' w' \<theta>' \<rho>' \<nu>'
	+ using assms(1,3) apply unfold_locales by auto
	+ interpret T: tabulation_data V H \<a> \<i> src trg r \<rho>' f' g'
	+ using assms(1,2) apply unfold_locales by auto
	+ interpret T: uw\<theta>\<omega>\<nu> V H \<a> \<i> src trg r \<rho>' f' g' f w \<theta> \<rho> \<nu>
	+ using assms(1,2) apply unfold_locales by auto
	+
	+ (* These next simps are very important. *)
	+ have dom_\<nu> [simp]: "dom \<nu> = dom \<rho>"
	+ using assms(2) by auto
	+ have dom_\<nu>' [simp]: "dom \<nu>' = dom \<rho>'"
	+ using assms(3) by auto
	+
	+ let ?\<nu>'\<nu> = "\<a>[dom \<rho>, w', w] \<cdot> (\<nu>' \<star> w) \<cdot> \<nu>"
	+ have \<nu>'\<nu>: "\<guillemotleft>?\<nu>'\<nu> : dom \<rho> \<Rightarrow> dom \<rho> \<star> w' \<star> w\<guillemotright>"
	+ by fastforce
	+ have "\<guillemotleft>\<nu> : src \<rho> \<rightarrow> trg r\<guillemotright>" by simp
	+ let ?\<theta>\<theta>' = "\<theta> \<cdot> (\<theta>' \<star> w) \<cdot> \<a>\<^sup>-\<^sup>1[f, w', w]"
	+ have \<theta>\<theta>': "\<guillemotleft>?\<theta>\<theta>' : f \<star> w' \<star> w \<Rightarrow> f\<guillemotright>"
	+ by fastforce
	+ have iso_\<nu>'\<nu>_r: "iso (?\<nu>'\<nu> \<cdot> \<r>[g])"
	+ using iso_runit \<nu>'\<nu>
	+ apply (intro isos_compose) by auto
	+
	+ have eq: "composite_cell (src f) \<r>[f] = composite_cell (w' \<star> w) ?\<theta>\<theta>' \<cdot> (?\<nu>'\<nu> \<cdot> \<r>[g])"
	+ proof -
	+ have "composite_cell (w' \<star> w) ?\<theta>\<theta>' \<cdot> (?\<nu>'\<nu> \<cdot> \<r>[g]) =
	+ ((r \<star> \<theta>) \<cdot> (r \<star> \<theta>' \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, w', w])) \<cdot>
	+ \<a>[r, f, w' \<star> w] \<cdot> ((\<rho> \<star> w' \<star> w) \<cdot> \<a>[g, w', w]) \<cdot> (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
	+ using whisker_left comp_assoc
	+ by (simp add: hseqI')
	+ also have "... = ((r \<star> \<theta>) \<cdot> (r \<star> \<theta>' \<star> w) \<cdot> (r \<star> \<a>\<^sup>-\<^sup>1[f, w', w])) \<cdot>
	+ \<a>[r, f, w' \<star> w] \<cdot> (\<a>[r \<star> f, w', w] \<cdot>
	+ ((\<rho> \<star> w') \<star> w)) \<cdot> (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
	+ using assoc_naturality [of \<rho> w' w] by simp
	+ also have "... = (r \<star> \<theta>) \<cdot> (r \<star> \<theta>' \<star> w) \<cdot>
	+ ((r \<star> \<a>\<^sup>-\<^sup>1[f, w', w]) \<cdot> \<a>[r, f, w' \<star> w] \<cdot> \<a>[r \<star> f, w', w]) \<cdot>
	+ ((\<rho> \<star> w') \<star> w) \<cdot> (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
	+ using comp_assoc by simp
	+ also have "... = (r \<star> \<theta>) \<cdot> ((r \<star> \<theta>' \<star> w) \<cdot> \<a>[r, f \<star> w', w]) \<cdot>
	+ (\<a>[r, f, w'] \<star> w) \<cdot>
	+ ((\<rho> \<star> w') \<star> w) \<cdot> (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
	+ proof -
	+ have "seq \<a>[r, f, w' \<star> w] \<a>[r \<star> f, w', w]" by simp
	+ moreover have "inv (r \<star> \<a>[f, w', w]) = r \<star> \<a>\<^sup>-\<^sup>1[f, w', w]"
	+ by simp
	+ moreover have "(r \<star> \<a>[f, w', w]) \<cdot> \<a>[r, f \<star> w', w] \<cdot> (\<a>[r, f, w'] \<star> w) =
	+ \<a>[r, f, w' \<star> w] \<cdot> \<a>[r \<star> f, w', w]"
	+ using pentagon by simp
	+ ultimately have "(r \<star> \<a>\<^sup>-\<^sup>1[f, w', w]) \<cdot> \<a>[r, f, w' \<star> w] \<cdot> \<a>[r \<star> f, w', w] =
	+ \<a>[r, f \<star> w', w] \<cdot> (\<a>[r, f, w'] \<star> w)"
	+ using iso_assoc [of f w' w] iso_hcomp
	+ invert_side_of_triangle(1)
	+ [of "\<a>[r, f, w' \<star> w] \<cdot> \<a>[r \<star> f, w', w]" "r \<star> \<a>[f, w', w]"
	+ "\<a>[r, f \<star> w', w] \<cdot> (\<a>[r, f, w'] \<star> w)"]
	+ by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot>
	+ (((r \<star> \<theta>') \<star> w) \<cdot> (\<a>[r, f, w'] \<star> w) \<cdot> ((\<rho> \<star> w') \<star> w)) \<cdot>
	+ (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
	+ proof -
	+ have "(r \<star> \<theta>' \<star> w) \<cdot> \<a>[r, f \<star> w', w] = \<a>[r, f', w] \<cdot> ((r \<star> \<theta>') \<star> w)"
	+ using assoc_naturality [of r \<theta>' w] by simp
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot> (composite_cell w' \<theta>' \<star> w) \<cdot> (\<nu>' \<star> w) \<cdot> \<nu> \<cdot> \<r>[g]"
	+ using whisker_right
	+ by (metis T'.uw\<theta>\<omega> T'.w_in_hom(1) composite_cell_in_hom T'.\<theta>_simps(2) T'.ide_w
	+ T.ide_w arrI seqE)
	+ also have "... = (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot> ((\<rho>' \<cdot> inv \<nu>' \<star> w) \<cdot> (\<nu>' \<star> w)) \<cdot> \<nu> \<cdot> \<r>[g]"
	+ proof -
	+ have "composite_cell w' \<theta>' = \<rho>' \<cdot> inv \<nu>'"
	+ using assms invert_side_of_triangle(2) T.tab_simps(1) comp_assoc by presburger
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ also have "... = (T.composite_cell w \<theta> \<cdot> \<nu>) \<cdot> \<r>[g]"
	+ using whisker_right [of w "\<rho>' \<cdot> inv \<nu>'" \<nu>'] dom_\<nu>' comp_assoc comp_inv_arr'
	+ comp_arr_dom
	+ by simp
	+ also have "... = \<rho> \<cdot> \<r>[g]"
	+ using assms(2) comp_assoc by simp
	+ also have "... = composite_cell (src f) \<r>[f]"
	+ using comp_assoc runit_hcomp runit_naturality [of \<rho>] by simp
	+ finally show ?thesis by simp
	+ qed
	+ have eq': "(r \<star> \<r>[f]) \<cdot> \<a>[r, f, src f] \<cdot> (\<rho> \<star> src f) \<cdot> (inv (?\<nu>'\<nu> \<cdot> \<r>[g])) =
	+ composite_cell (w' \<star> w) ?\<theta>\<theta>'"
	+ proof -
	+ have 1: "composite_cell (src f) \<r>[f] = (composite_cell (w' \<star> w) ?\<theta>\<theta>') \<cdot> ?\<nu>'\<nu> \<cdot> \<r>[g]"
	+ using eq comp_assoc by simp
	+ have "composite_cell (src f) \<r>[f] \<cdot> (inv (?\<nu>'\<nu> \<cdot> \<r>[g])) = composite_cell (w' \<star> w) ?\<theta>\<theta>'"
	+ proof -
	+ have "seq (r \<star> \<r>[f]) (\<a>[r, f, src f] \<cdot> (\<rho> \<star> src f))"
	+ by fastforce
	+ thus ?thesis
	+ using iso_\<nu>'\<nu>_r 1 invert_side_of_triangle(2) by simp
	+ qed
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+
	+ have \<nu>'\<nu>_r: "\<guillemotleft>?\<nu>'\<nu> \<cdot> \<r>[g] : g \<star> src f \<Rightarrow> g \<star> w' \<star> w\<guillemotright>"
	+ by force
	+ have inv_\<nu>'\<nu>_r: "\<guillemotleft>inv (?\<nu>'\<nu> \<cdot> \<r>[g]) : g \<star> w' \<star> w \<Rightarrow> g \<star> src f\<guillemotright>"
	+ using \<nu>'\<nu> iso_\<nu>'\<nu>_r by simp
	+
	+ let ?P = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : src f \<Rightarrow> w' \<star> w\<guillemotright> \<and> ?\<nu>'\<nu> \<cdot> \<r>[g] = dom \<rho> \<star> \<gamma> \<and> \<r>[f] = ?\<theta>\<theta>' \<cdot> (f \<star> \<gamma>)"
	+ let ?\<gamma> = "THE \<gamma>. ?P \<gamma>"
	+ have "?P ?\<gamma>"
	+ proof -
	+ have "\<exists>!\<gamma>. ?P \<gamma>"
	+ using \<nu>'\<nu>_r \<theta>\<theta>' eq T2 [of "src f" "w' \<star> w" "\<r>[f]" f ?\<theta>\<theta>' "?\<nu>'\<nu> \<cdot> \<r>[g]"] by simp
	+ thus ?thesis
	+ using the1_equality [of ?P] by blast
	+ qed
	+ hence \<gamma>: "\<guillemotleft>?\<gamma> : src f \<rightarrow> src f\<guillemotright> \<and> ?P ?\<gamma>"
	+ using src_dom trg_dom by fastforce
	+
	+ let ?P' = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : w' \<star> w \<Rightarrow> src f\<guillemotright> \<and> inv (?\<nu>'\<nu> \<cdot> \<r>[g]) = g \<star> \<gamma> \<and> ?\<theta>\<theta>' = \<r>[f] \<cdot> (f \<star> \<gamma>)"
	+ let ?\<gamma>' = "THE \<gamma>. ?P' \<gamma>"
	+ have "?P' ?\<gamma>'"
	+ proof -
	+ have "\<exists>!\<gamma>. ?P' \<gamma>"
	+ using inv_\<nu>'\<nu>_r \<theta>\<theta>' eq' T2 comp_assoc by simp
	+ thus ?thesis
	+ using the1_equality [of ?P'] by blast
	+ qed
	+ hence \<gamma>': "\<guillemotleft>?\<gamma>' : src f \<rightarrow> src f\<guillemotright> \<and> ?P' ?\<gamma>'"
	+ using src_dom trg_dom by fastforce
	+
	+ have "inverse_arrows ?\<gamma> ?\<gamma>'"
	+ proof
	+ let ?Q = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : src f \<Rightarrow> src f\<guillemotright> \<and> dom \<rho> \<star> src f = g \<star> \<gamma> \<and> \<r>[f] = \<r>[f] \<cdot> (f \<star> \<gamma>)"
	+ have "\<exists>!\<gamma>. ?Q \<gamma>"
	+ proof -
	+ have "ide (src f)" by simp
	+ moreover have "\<guillemotleft>\<r>[f] : f \<star> src f \<Rightarrow> f\<guillemotright>" by simp
	+ moreover have "\<guillemotleft>dom \<rho> \<star> src f : g \<star> src f \<Rightarrow> g \<star> src f\<guillemotright>" by auto
	+ moreover have "(\<rho> \<star> src f) \<cdot> (dom \<rho> \<star> src f) = \<rho> \<star> src f"
	+ using comp_arr_dom hcomp_simps(3) [of \<rho> "src f"]
	+ by (metis (full_types) R.preserves_arr tab_simps(1) tab_simps(2) dom_src)
	+ ultimately show ?thesis
	+ using comp_arr_dom T2 [of "src f" "src f" "\<r>[f]" f "\<r>[f]" "dom \<rho> \<star> src f"]
	+ comp_assoc
	+ by metis
	+ qed
	+ moreover have "?Q (src f)"
	+ using comp_arr_dom by auto
	+ moreover have "?Q (?\<gamma>' \<cdot> ?\<gamma>)"
	+ proof (intro conjI)
	+ show "\<guillemotleft>?\<gamma>' \<cdot> ?\<gamma> : src f \<Rightarrow> src f\<guillemotright>"
	+ using \<gamma> \<gamma>' by auto
	+ show "dom \<rho> \<star> src f = g \<star> ?\<gamma>' \<cdot> ?\<gamma>"
	+ proof -
	+ have "g \<star> ?\<gamma>' \<cdot> ?\<gamma> = (g \<star> ?\<gamma>') \<cdot> (g \<star> ?\<gamma>)"
	+ using \<gamma> \<gamma>' whisker_left by fastforce
	+ also have "... = inv (?\<nu>'\<nu> \<cdot> \<r>[g]) \<cdot> (?\<nu>'\<nu> \<cdot> \<r>[g])"
	+ using \<gamma> \<gamma>' by simp
	+ also have "... = dom \<rho> \<star> src f"
	+ using \<nu>'\<nu> iso_\<nu>'\<nu>_r comp_inv_arr inv_is_inverse by auto
	+ finally show ?thesis by simp
	+ qed
	+ show "\<r>[f] = \<r>[f] \<cdot> (f \<star> ?\<gamma>' \<cdot> ?\<gamma>)"
	+ proof -
	+ have "\<r>[f] \<cdot> (f \<star> ?\<gamma>' \<cdot> ?\<gamma>) = \<r>[f] \<cdot> (f \<star> ?\<gamma>') \<cdot> (f \<star> ?\<gamma>)"
	+ using \<gamma> \<gamma>' whisker_left by fastforce
	+ also have "... = (\<r>[f] \<cdot> (f \<star> ?\<gamma>')) \<cdot> (f \<star> ?\<gamma>)"
	+ using comp_assoc by simp
	+ also have "... = \<r>[f]"
	+ using \<gamma> \<gamma>' by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ ultimately have "?\<gamma>' \<cdot> ?\<gamma> = src f" by blast
	+ thus "ide (?\<gamma>' \<cdot> ?\<gamma>)" by simp
	+
	+ let ?Q' = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : w' \<star> w \<Rightarrow> w' \<star> w\<guillemotright> \<and> g \<star> w' \<star> w = g \<star> \<gamma> \<and> ?\<theta>\<theta>' = ?\<theta>\<theta>' \<cdot> (f \<star> \<gamma>)"
	+ have "\<exists>!\<gamma>. ?Q' \<gamma>"
	+ proof -
	+ have "ide (w' \<star> w)" by simp
	+ moreover have "\<guillemotleft>?\<theta>\<theta>' : f \<star> w' \<star> w \<Rightarrow> f\<guillemotright>"
	+ using \<theta>\<theta>' by simp
	+ moreover have "\<guillemotleft>g \<star> w' \<star> w : g \<star> w' \<star> w \<Rightarrow> g \<star> w' \<star> w\<guillemotright>"
	+ by auto
	+ moreover have
	+ "composite_cell (w' \<star> w) ?\<theta>\<theta>' = composite_cell (w' \<star> w) ?\<theta>\<theta>' \<cdot> (g \<star> w' \<star> w)"
	+ proof -
	+ have "\<guillemotleft>\<rho> \<star> w' \<star> w : g \<star> w' \<star> w \<Rightarrow> (r \<star> f) \<star> w' \<star> w\<guillemotright>"
	+ by (intro hcomp_in_vhom, auto)
	+ hence "(\<rho> \<star> w' \<star> w) \<cdot> (g \<star> w' \<star> w) = \<rho> \<star> w' \<star> w"
	+ using comp_arr_dom by auto
	+ thus ?thesis
	+ using comp_assoc by simp
	+ qed
	+ ultimately show ?thesis
	+ using T2 by auto
	+ qed
	+ moreover have "?Q' (w' \<star> w)"
	+ using \<theta>\<theta>' comp_arr_dom by auto
	+ moreover have "?Q' (?\<gamma> \<cdot> ?\<gamma>')"
	+ proof (intro conjI)
	+ show "\<guillemotleft>?\<gamma> \<cdot> ?\<gamma>' : w' \<star> w \<Rightarrow> w' \<star> w\<guillemotright>"
	+ using \<gamma> \<gamma>' by auto
	+ show "g \<star> w' \<star> w = g \<star> ?\<gamma> \<cdot> ?\<gamma>'"
	+ proof -
	+ have "g \<star> ?\<gamma> \<cdot> ?\<gamma>' = (g \<star> ?\<gamma>) \<cdot> (g \<star> ?\<gamma>')"
	+ using \<gamma> \<gamma>' whisker_left by fastforce
	+ also have "... = (?\<nu>'\<nu> \<cdot> \<r>[g]) \<cdot> inv (?\<nu>'\<nu> \<cdot> \<r>[g])"
	+ using \<gamma> \<gamma>' by simp
	+ also have "... = g \<star> w' \<star> w"
	+ using \<nu>'\<nu> iso_\<nu>'\<nu>_r comp_arr_inv inv_is_inverse by auto
	+ finally show ?thesis by simp
	+ qed
	+ show "?\<theta>\<theta>' = ?\<theta>\<theta>' \<cdot> (f \<star> ?\<gamma> \<cdot> ?\<gamma>')"
	+ proof -
	+ have "?\<theta>\<theta>' \<cdot> (f \<star> ?\<gamma> \<cdot> ?\<gamma>') = ?\<theta>\<theta>' \<cdot> (f \<star> ?\<gamma>) \<cdot> (f \<star> ?\<gamma>')"
	+ using \<gamma> \<gamma>' whisker_left by fastforce
	+ also have "... = (?\<theta>\<theta>' \<cdot> (f \<star> ?\<gamma>)) \<cdot> (f \<star> ?\<gamma>')"
	+ using comp_assoc by simp
	+ also have "... = ?\<theta>\<theta>'"
	+ using \<gamma> \<gamma>' by simp
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ ultimately have "?\<gamma> \<cdot> ?\<gamma>' = w' \<star> w" by blast
	+ thus "ide (?\<gamma> \<cdot> ?\<gamma>')" by simp
	+ qed
	+ hence "\<guillemotleft>?\<gamma> : src f \<Rightarrow> w' \<star> w\<guillemotright> \<and> iso ?\<gamma>"
	+ using \<gamma> by auto
	+ thus ?thesis by auto
	+ qed
	+
	+ text \<open>
	+ Now we can show that, given two tabulations of the same 1-cell,
	+ there is an equivalence map between the apexes that extends to a transformation
	+ of one tabulation into the other.
	+ \<close>
	+
	+ lemma apex_unique_up_to_equivalence:
	+ assumes "tabulation V H \<a> \<i> src trg r \<rho>' f' g'"
	+ shows "\<exists>w w' \<phi> \<psi> \<theta> \<nu> \<theta>' \<nu>'.
	+ equivalence_in_bicategory V H \<a> \<i> src trg w' w \<psi> \<phi> \<and>
	+ \<guillemotleft>w : src f \<rightarrow> src f'\<guillemotright> \<and> \<guillemotleft>w' : src f' \<rightarrow> src f\<guillemotright> \<and>
	+ \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> f\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<Rightarrow> g' \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ \<rho> = (r \<star> \<theta>) \<cdot> \<a>[r, f', w] \<cdot> (\<rho>' \<star> w) \<cdot> \<nu> \<and>
	+ \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>\<nu>' : g' \<Rightarrow> g \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
	+ \<rho>' = (r \<star> \<theta>') \<cdot> \<a>[r, f, w'] \<cdot> (\<rho> \<star> w') \<cdot> \<nu>'"
	+ proof -
	+ interpret T': tabulation V H \<a> \<i> src trg r \<rho>' f' g'
	+ using assms by auto
	+ obtain w \<theta> \<nu>
	+ where w\<theta>\<nu>: "ide w \<and> \<guillemotleft>\<theta> : f' \<star> w \<Rightarrow> f\<guillemotright> \<and> \<guillemotleft>\<nu> : g \<Rightarrow> g' \<star> w\<guillemotright> \<and> iso \<nu> \<and>
	+ \<rho> = T'.composite_cell w \<theta> \<cdot> \<nu>"
	+ using T'.T1 [of f \<rho>] ide_leg0 tab_in_hom by auto
	+ obtain w' \<theta>' \<nu>'
	+ where w'\<theta>'\<nu>': "ide w' \<and> \<guillemotleft>\<theta>' : f \<star> w' \<Rightarrow> f'\<guillemotright> \<and> \<guillemotleft>\<nu>' : g' \<Rightarrow> g \<star> w'\<guillemotright> \<and> iso \<nu>' \<and>
	+ \<rho>' = composite_cell w' \<theta>' \<cdot> \<nu>'"
	+ using T1 [of f' \<rho>'] T'.ide_leg0 T'.tab_in_hom by auto
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : src f \<Rightarrow> w' \<star> w\<guillemotright> \<and> iso \<phi>"
	+ using w\<theta>\<nu> w'\<theta>'\<nu>' apex_equivalence_lemma T'.tab_in_hom comp_assoc by metis
	+ obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : src f' \<Rightarrow> w \<star> w'\<guillemotright> \<and> iso \<psi>"
	+ using w\<theta>\<nu> w'\<theta>'\<nu>' T'.apex_equivalence_lemma tab_in_hom comp_assoc by metis
	+ have 1: "src f = src w"
	+ using \<phi> src_dom [of \<phi>] hcomp_simps(1) [of w' w]
	+ by (metis arr_cod leg0_simps(2) in_homE src_cod src_src)
	+ have 2: "src f' = src w'"
	+ using \<psi> src_dom [of \<psi>] hcomp_simps(1) [of w w']
	+ by (metis arr_cod T'.leg0_simps(2) in_homE src_cod src_src)
	+ interpret E: equivalence_in_bicategory V H \<a> \<i> src trg w' w \<psi> \<open>inv \<phi>\<close>
	+ using \<phi> \<psi> 1 2 w\<theta>\<nu> w'\<theta>'\<nu>' iso_inv_iso
	+ apply unfold_locales by auto
	+ have "\<guillemotleft>w : src f \<rightarrow> src f'\<guillemotright>"
	+ using \<psi> w\<theta>\<nu> 1 2 trg_cod hcomp_simps(2) E.antipar(1) by simp
	+ moreover have "\<guillemotleft>w' : src f' \<rightarrow> src f\<guillemotright>"
	+ using \<phi> w'\<theta>'\<nu>' 1 2 E.antipar(2) by simp
	+ ultimately show ?thesis
	+ using E.equivalence_in_bicategory_axioms w\<theta>\<nu> w'\<theta>'\<nu>' comp_assoc by metis
	+ qed
	+
	+ end
	+
	+ subsection "`Tabulation' is Bicategorical"
	+
	+ text \<open>
	+ In this section we show that ``tabulation'' is a truly bicategorical notion,
	+ in the sense that tabulations are preserved and reflected by equivalence pseudofunctors.
	+ The proofs given here is are elementary proofs from first principles.
	+ It should also be possible to give a proof based on birepresentations,
	+ but for this to actually save work it would first be necessary to carry out a general
	+ development of birepresentations and bicategorical limits, and I have chosen not to
	+ attempt this here.
	+ \<close>
	+
	+ (*
	+ * TODO: The fully_faithful_and_essentially_surjective_functor locale should have arguments in
	+ * same order as functor, faithful_functor, etc.
	+ * The equivalence_functor definition can reverse the arguments for consistency
	+ * with the definition of adjoint equivalence.
	+ *)
	+
	+ context equivalence_pseudofunctor
	+ begin
	+
	+ lemma preserves_tabulation:
	+ assumes "tabulation (\<cdot>\<^sub>C) (\<star>\<^sub>C) \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> f g"
	+ shows "tabulation (\<cdot>\<^sub>D) (\<star>\<^sub>D) \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F r) (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>) (F f) (F g)"
	+ proof -
	+ let ?\<rho>' = "D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>"
	+ interpret T: tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> f
	+ using assms by auto
	+ interpret T': tabulation_data V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F r\<close> ?\<rho>' \<open>F f\<close> \<open>F g\<close>
	+ using \<Phi>_in_hom \<Phi>.components_are_iso C.VV.ide_char C.VV.arr_char
	+ apply unfold_locales
	+ apply auto
	+ by (intro D.comp_in_homI, auto)
	+ interpret T': tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F r\<close> ?\<rho>' \<open>F f\<close> \<open>F g\<close>
	+ text \<open>
	+ How bad can it be to just show this directly from first principles?
	+ It is worse than it at first seems, once you start filling in the details!
	+ \<close>
	+ proof
	+ fix u' \<omega>'
	+ assume u': "D.ide u'"
	+ assume \<omega>': "\<guillemotleft>\<omega>' : D.dom \<omega>' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u'\<guillemotright>"
	+ show "\<exists>w' \<theta>' \<nu>'. D.ide w' \<and> \<guillemotleft>\<theta>' : F f \<star>\<^sub>D w' \<Rightarrow>\<^sub>D u'\<guillemotright> \<and>
	+ \<guillemotleft>\<nu>' : D.dom \<omega>' \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w'\<guillemotright> \<and> D.iso \<nu>' \<and>
	+ T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' = \<omega>'"
	+ proof -
	+ text \<open>
	+ First, obtain \<open>\<omega>\<close> in \<open>C\<close> such that \<open>F \<omega>\<close> is related to \<open>\<omega>'\<close> by an equivalence in \<open>D\<close>.
	+ \<close>
	+ define v' where "v' = D.dom \<omega>'"
	+ have v': "D.ide v'"
	+ using assms v'_def D.ide_dom \<omega>' by blast
	+ have \<omega>': "\<guillemotleft>\<omega>' : v' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u'\<guillemotright>"
	+ using v'_def \<omega>' by simp
	+ define a' where "a' = src\<^sub>D \<omega>'"
	+
	+ have [simp]: "src\<^sub>D u' = a'"
	+ using a'_def \<omega>'
	+ by (metis D.arr_cod D.ide_char D.in_homE D.src.preserves_cod D.src_dom
	+ D.src_hcomp' v')
	+ have [simp]: "trg\<^sub>D u' = src\<^sub>D (F r)"
	+ using \<omega>'
	+ by (metis D.cod_trg D.in_homE D.not_arr_null D.seq_if_composable D.trg.is_extensional
	+ D.trg.preserves_arr D.trg.preserves_cod)
	+ have [simp]: "src\<^sub>D v' = a'"
	+ using v'_def \<omega>' a'_def by auto
	+ have [simp]: "trg\<^sub>D v' = trg\<^sub>D (F r)"
	+ using v'_def
	+ by (metis D.cod_trg D.hseqI' D.ideD(1) D.in_homE D.trg.preserves_hom D.trg_dom
	+ D.hcomp_simps(2) T'.base_simps(2) \<omega>' \<open>trg\<^sub>D u' = src\<^sub>D (F r)\<close> u')
	+
	+ have [simp]: "src\<^sub>D \<omega>' = a'"
	+ using \<omega>' a'_def by blast
	+ have [simp]: "trg\<^sub>D \<omega>' = trg\<^sub>D (F r)"
	+ using \<omega>' v'_def \<open>trg\<^sub>D v' = trg\<^sub>D (F r)\<close> by auto
	+
	+ obtain a where a: "C.obj a \<and> D.equivalent_objects (map\<^sub>0 a) a'"
	+ using u' \<omega>' a'_def surjective_on_objects_up_to_equivalence D.obj_src by blast
	+ obtain e' where e': "\<guillemotleft>e' : map\<^sub>0 a \<rightarrow>\<^sub>D a'\<guillemotright> \<and> D.equivalence_map e'"
	+ using a D.equivalent_objects_def by auto
	+
	+ have u'_in_hhom: "\<guillemotleft>u' : a' \<rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C r)\<guillemotright>"
	+ by (simp add: u')
	+ hence 1: "\<guillemotleft>u' \<star>\<^sub>D e' : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C r)\<guillemotright>"
	+ using e' by blast
	+ have v'_in_hhom: "\<guillemotleft>v' : a' \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C r)\<guillemotright>"
	+ by (simp add: v')
	+ hence 2: "\<guillemotleft>v' \<star>\<^sub>D e' : map\<^sub>0 a \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C r)\<guillemotright>"
	+ using e' by blast
	+
	+ obtain d' \<eta>' \<epsilon>'
	+ where d'\<eta>'\<epsilon>': "adjoint_equivalence_in_bicategory (\<cdot>\<^sub>D) (\<star>\<^sub>D) \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D e' d' \<eta>' \<epsilon>'"
	+ using e' D.equivalence_map_extends_to_adjoint_equivalence by blast
	+ interpret e': adjoint_equivalence_in_bicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D e' d' \<eta>' \<epsilon>'
	+ using d'\<eta>'\<epsilon>' by auto
	+ interpret d': adjoint_equivalence_in_bicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ d' e' "D.inv \<epsilon>'" "D.inv \<eta>'"
	+ using e'.dual_adjoint_equivalence by simp
	+ have [simp]: "src\<^sub>D e' = map\<^sub>0 a"
	+ using e' by auto
	+ have [simp]: "trg\<^sub>D e' = a'"
	+ using e' by auto
	+ have [simp]: "src\<^sub>D d' = a'"
	+ by (simp add: e'.antipar(2))
	+ have [simp]: "trg\<^sub>D d' = map\<^sub>0 a"
	+ using e'.antipar by simp
	+
	+ obtain u where u: "\<guillemotleft>u : a \<rightarrow>\<^sub>C src\<^sub>C r\<guillemotright> \<and> C.ide u \<and> D.isomorphic (F u) (u' \<star>\<^sub>D e')"
	+ using a e' u' 1 u'_in_hhom locally_essentially_surjective [of a "src\<^sub>C r" "u' \<star>\<^sub>D e'"]
	+ C.obj_src D.equivalence_map_is_ide T.base_simps(2)
	+ by blast
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : u' \<star>\<^sub>D e' \<Rightarrow>\<^sub>D F u\<guillemotright> \<and> D.iso \<phi>"
	+ using u D.isomorphic_symmetric by blast
	+ obtain v where v: "\<guillemotleft>v : a \<rightarrow>\<^sub>C trg\<^sub>C r\<guillemotright> \<and> C.ide v \<and> D.isomorphic (F v) (v' \<star>\<^sub>D e')"
	+ using a e' v' v'_in_hhom locally_essentially_surjective [of a "trg\<^sub>C r" "v' \<star>\<^sub>D e'"]
	+ C.obj_trg D.equivalence_map_is_ide T.base_simps(2)
	+ by blast
	+ obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : F v \<Rightarrow>\<^sub>D v' \<star>\<^sub>D e'\<guillemotright> \<and> D.iso \<psi>"
	+ using v by blast
	+
	+ have [simp]: "src\<^sub>C u = a" using u by auto
	+ have [simp]: "trg\<^sub>C u = src\<^sub>C r" using u by auto
	+ have [simp]: "src\<^sub>C v = a" using v by auto
	+ have [simp]: "trg\<^sub>C v = trg\<^sub>C r" using v by auto
	+ have [simp]: "src\<^sub>D \<phi> = map\<^sub>0 a"
	+ using \<phi> by (metis "1" D.dom_src D.in_hhomE D.in_homE D.src.preserves_dom)
	+ have [simp]: "trg\<^sub>D \<phi> = trg\<^sub>D u'"
	+ using \<phi>
	+ by (metis D.cod_trg D.hseqI D.in_homE D.isomorphic_implies_hpar(4)
	+ D.trg.preserves_cod D.trg_hcomp' e' u u'_in_hhom)
	+ have [simp]: "src\<^sub>D \<psi> = map\<^sub>0 a"
	+ using \<psi>
	+ by (metis C.in_hhomE D.in_homE D.src_dom \<open>src\<^sub>D e' = map\<^sub>0 a\<close> preserves_src v)
	+ have [simp]: "trg\<^sub>D \<psi> = trg\<^sub>D v'"
	+ using \<psi>
	+ by (metis "2" D.cod_trg D.in_hhomE D.in_homE D.trg.preserves_cod T.base_simps(2)
	+ \<open>trg\<^sub>D v' = trg\<^sub>D (F r)\<close> preserves_trg)
	+
	+ define F\<omega> where "F\<omega> = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi>"
	+ have F\<omega>: "\<guillemotleft>F\<omega> : F v \<Rightarrow>\<^sub>D F (r \<star>\<^sub>C u)\<guillemotright>"
	+ proof (unfold F\<omega>_def, intro D.comp_in_homI)
	+ show "\<guillemotleft>\<psi> : F v \<Rightarrow>\<^sub>D v' \<star>\<^sub>D e'\<guillemotright>"
	+ using \<psi> by simp
	+ show "\<guillemotleft>\<omega>' \<star>\<^sub>D e' : v' \<star>\<^sub>D e' \<Rightarrow>\<^sub>D (F r \<star>\<^sub>D u') \<star>\<^sub>D e'\<guillemotright>"
	+ using e' \<omega>' D.equivalence_map_is_ide v'_in_hhom by blast
	+ show "\<guillemotleft>\<a>\<^sub>D[F r, u', e'] : (F r \<star>\<^sub>D u') \<star>\<^sub>D e' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u' \<star>\<^sub>D e'\<guillemotright>"
	+ using e' u' D.equivalence_map_is_ide D.in_hhom_def u'_in_hhom by auto
	+ show "\<guillemotleft>F r \<star>\<^sub>D \<phi> : F r \<star>\<^sub>D u' \<star>\<^sub>D e' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D F u\<guillemotright>"
	+ using e' u' u \<phi>
	+ by (metis C.in_hhomE D.hcomp_in_vhom D.isomorphic_implies_hpar(4)
	+ T'.base_in_hom(2) T.base_simps(2) preserves_src preserves_trg)
	+ show "\<guillemotleft>\<Phi> (r, u) : F r \<star>\<^sub>D F u \<Rightarrow>\<^sub>D F (r \<star>\<^sub>C u)\<guillemotright>"
	+ using u \<Phi>_in_hom(2) [of r u] by auto
	+ qed
	+
	+ obtain \<omega> where \<omega>: "\<guillemotleft>\<omega> : v \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<guillemotright> \<and> F \<omega> = F\<omega>"
	+ using u v \<omega>' \<phi> \<psi> F\<omega> locally_full [of v "r \<star>\<^sub>C u" F\<omega>]
	+ by (metis C.ide_hcomp C.hseqI C.in_hhomE C.src_hcomp' C.trg_hcomp'
	+ T.ide_base T.base_in_hom(1))
	+ have [simp]: "src\<^sub>C \<omega> = src\<^sub>C u"
	+ using \<omega>
	+ by (metis C.hseqI C.in_homE C.src_cod C.src_hcomp' T.base_in_hom(1) u)
	+ have [simp]: "trg\<^sub>C \<omega> = trg\<^sub>C r"
	+ using \<omega>
	+ by (metis C.ide_char C.ide_trg C.in_homE C.trg.preserves_hom \<open>trg\<^sub>C v = trg\<^sub>C r\<close>)
	+
	+ text \<open>Apply \<open>T.T1\<close> to \<open>u\<close> and \<open>\<omega>\<close> to obtain \<open>w\<close>, \<open>\<theta>\<close>, \<open>\<nu>\<close>.\<close>
	+
	+ obtain w \<theta> \<nu>
	+ where w\<theta>\<nu>: "C.ide w \<and> \<guillemotleft>\<theta> : f \<star>\<^sub>C w \<Rightarrow>\<^sub>C u\<guillemotright> \<and> \<guillemotleft>\<nu> : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<guillemotright> \<and>
	+ C.iso \<nu> \<and> T.composite_cell w \<theta> \<cdot>\<^sub>C \<nu> = \<omega>"
	+ using u \<omega> T.T1 [of u \<omega>] by auto
	+ text \<open>
	+ Combining \<open>\<omega>\<close> and \<open>w\<theta>\<nu>\<close> yields the situation depicted in the diagram below.
	+ In this as well as subsequent diagrams, canonical isomorphisms have been suppressed
	+ in the interests of clarity.
	+$$
	+F (
	+\xy/67pt/
	+\xymatrix{
	+ & {\scriptstyle{a}}
	+ \xlowertwocell[ddddl]{}_{v}{^\nu}
	+ \xuppertwocell[ddddr]{}^{u}{^\theta}
	+ \ar@ {.>}[dd]^{w}
	+ \\
	+ \\
	+ & \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \xtwocell[ddd]{}\omit{^\rho}
	+ \ar[ddl] _{g}
	+ \ar[ddr] ^{f}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll] ^{r}
	+ \\
	+ &
	+}
	+\endxy
	+)
	+\qquad = \qquad
	+\xy/67pt/
	+\xymatrix{
	+ & {\scriptstyle{{\rm src}(F a)}}
	+ \xlowertwocell[ddddl]{}^{<2>F v}{^{\psi}}
	+ \xuppertwocell[ddddr]{}^{<2>F u}{^{\phi}}
	+ \ar[dd] ^{e'}
	+ \\
	+ \\
	+ & \scriptstyle{a'} \xtwocell[ddd]{}\omit{^{\omega'}}
	+ \ar[ddl] _{v'}
	+ \ar[ddr] ^{u'}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
	+ \\
	+ &
	+}
	+\endxy
	+$$
	+ \<close>
	+ have [simp]: "src\<^sub>C w = src\<^sub>C u"
	+ by (metis C.arrI C.seqE C.src_hcomp' C.src_vcomp C.vseq_implies_hpar(1)
	+ \<omega> \<open>src\<^sub>C \<omega> = src\<^sub>C u\<close> w\<theta>\<nu>)
	+ have [simp]: "trg\<^sub>C w = src\<^sub>C f"
	+ by (metis C.arrI C.hseq_char C.seqE T.tab_simps(2) \<omega> w\<theta>\<nu>)
	+ have [simp]: "src\<^sub>D (F u) = map\<^sub>0 a"
	+ using e'.antipar(1) u by auto
	+ have [simp]: "src\<^sub>D (F v) = map\<^sub>0 a"
	+ using v e' e'.antipar by force
	+ have [simp]: "src\<^sub>D (F w) = map\<^sub>0 a"
	+ by (simp add: w\<theta>\<nu>)
	+
	+ have *: "F (T.composite_cell w \<theta> \<cdot>\<^sub>C \<nu>) =
	+ \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu>"
	+ text \<open>
	+$$
	+F (
	+\xy/67pt/
	+\xymatrix{
	+ & {\scriptstyle{a}}
	+ \xlowertwocell[ddddl]{}_{v}{^\nu}
	+ \xuppertwocell[ddddr]{}^{u}{^\theta}
	+ \ar[dd] ^{w}
	+ \\
	+ \\
	+ & \scriptstyle{{\rm src}~g \;=\;{\rm src}~f} \xtwocell[ddd]{}\omit{^\rho}
	+ \ar[ddl] _{g}
	+ \ar[ddr] ^{f}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~r} & & \scriptstyle{{\rm src}~r} \ar[ll] ^{r}
	+ \\
	+ &
	+}
	+\endxy
	+)
	+\qquad = \qquad
	+\xy/67pt/
	+\xymatrix{
	+ & {\scriptstyle{{\rm src}(F a)}}
	+ \xlowertwocell[ddddl]{}^{<2>F v}{^{F \nu}}
	+ \xuppertwocell[ddddr]{}^{<2>F u}{^{F \theta}}
	+ \ar[dd] ^{Fw}
	+ \\
	+ \\
	+ & \scriptstyle{{\rm src}(F g) \;=\;{\rm src}(F f)} \xtwocell[ddd]{}\omit{^{F \rho}}
	+ \ar[ddl] _{F g}
	+ \ar[ddr] ^{F f}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
	+ \\
	+ &
	+}
	+\endxy
	+$$
	+ \<close>
	+ proof -
	+ have "F (T.composite_cell w \<theta> \<cdot>\<^sub>C \<nu>) = F ((r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>C \<a>\<^sub>C[r, f, w] \<cdot>\<^sub>C (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>C \<nu>)"
	+ using C.comp_assoc by simp
	+ also have "... = F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>D F \<nu>"
	+ by (metis C.arr_dom_iff_arr C.comp_assoc C.in_homE C.seqE preserves_comp_2 w\<theta>\<nu>)
	+ also have "... =
	+ F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D (\<Phi> (r, f \<star>\<^sub>C w) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w))) \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>D F \<nu>"
	+ using \<omega> w\<theta>\<nu> preserves_assoc [of r f w]
	+ by (metis C.hseqE C.in_homE C.seqE T.tab_simps(2) T.ide_leg0 T.ide_base
	+ T.leg0_simps(3))
	+ also have "... =
	+ ((F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w))) \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>D F \<nu>"
	+ using D.comp_assoc by simp
	+ also have "... =
	+ \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w)) \<cdot>\<^sub>D F \<nu>"
	+ proof -
	+ have "(F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) =
	+ (\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)))"
	+ proof -
	+ have "F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w) = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>)"
	+ using \<omega> \<Phi>.naturality [of "(r, \<theta>)"] FF_def w\<theta>\<nu> C.VV.arr_char
	+ apply simp
	+ by (metis (no_types, lifting) C.hseqE C.in_homE C.seqE)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w))"
	+ proof -
	+ have "(F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) = F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)"
	+ using \<omega> w\<theta>\<nu> D.whisker_right [of "F r" "F \<theta>" "\<Phi> (f, w)"]
	+ by (metis C.hseqE C.in_homE C.seqE D.comp_ide_self D.interchange D.seqI'
	+ T'.ide_base T'.base_in_hom(2) T.tab_simps(2) T.ide_leg0 \<Phi>_in_hom(2)
	+ preserves_hom)
	+ thus ?thesis by simp
	+ qed
	+ finally have "(F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) =
	+ \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w))"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))) \<cdot>\<^sub>D F \<nu>"
	+ proof -
	+ have "(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) =
	+ ((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w)) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
	+ proof -
	+ have "D.inv (\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) = (F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
	+ proof -
	+ have "src\<^sub>C (r \<star>\<^sub>C f) = trg\<^sub>C w"
	+ using \<omega> w\<theta>\<nu>
	+ by (metis C.arrI C.hseq_char C.seqE C.hcomp_simps(1) T.tab_simps(2)
	+ T.leg0_simps(2) T.leg0_simps(3))
	+ hence "D.seq (\<Phi> (r \<star>\<^sub>C f, w)) (F \<rho> \<star>\<^sub>D F w)"
	+ using \<omega> w\<theta>\<nu> \<Phi>_in_hom(2) [of "r \<star>\<^sub>C f" w] C.VV.arr_char FF_def
	+ apply (intro D.seqI D.hseqI')
	+ apply auto
	+ using \<omega> w\<theta>\<nu> T.tab_in_hom preserves_cod [of "\<rho> \<star>\<^sub>C w"] D.hseqI'
	+ by force
	+ moreover have "\<Phi> (r \<star>\<^sub>C f, w) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w) = F (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>D \<Phi> (g, w)"
	+ using \<omega> w\<theta>\<nu> \<Phi>.naturality [of "(\<rho>, w)"] \<Phi>_components_are_iso FF_def
	+ C.VV.arr_char
	+ by simp
	+ moreover have "D.iso (\<Phi> (r \<star>\<^sub>C f, w))"
	+ using w\<theta>\<nu> \<Phi>_components_are_iso
	+ by (metis C.arrI C.ide_hcomp C.hseqE C.hseqI' C.seqE C.src_hcomp'
	+ T.tab_simps(2) T.ide_leg0 T.ide_base T.leg0_simps(2) T.leg0_simps(3) \<omega>)
	+ moreover have "D.iso (\<Phi> (g, w))"
	+ using w\<theta>\<nu> \<Phi>_components_are_iso
	+ by (metis C.arrI C.hseqE C.seqE T.tab_simps(2) T.ide_leg1 T.leg1_simps(3) \<omega>)
	+ ultimately show ?thesis
	+ using \<omega> w\<theta>\<nu> \<Phi>.naturality \<Phi>_components_are_iso FF_def C.VV.arr_char
	+ D.invert_opposite_sides_of_square
	+ by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
	+ using \<omega> w\<theta>\<nu> D.whisker_right \<Phi>_components_are_iso \<Phi>_in_hom D.comp_assoc
	+ by auto
	+ finally show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ finally show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+
	+ text \<open>We can now define the \<open>w'\<close>, \<open>\<theta>'\<close>, and \<open>\<nu>'\<close> that we are required to exhibit.\<close>
	+
	+ define \<phi>' where "\<phi>' = e'.trnr\<^sub>\<epsilon> u' (D.inv \<phi>)"
	+ have "\<phi>' = \<r>\<^sub>D[u'] \<cdot>\<^sub>D (u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[u', e', d'] \<cdot>\<^sub>D (D.inv \<phi> \<star>\<^sub>D d')"
	+ unfolding \<phi>'_def e'.trnr\<^sub>\<epsilon>_def by simp
	+ have \<phi>': "\<guillemotleft>\<phi>' : F u \<star>\<^sub>D d' \<Rightarrow>\<^sub>D u'\<guillemotright>"
	+ using \<phi> \<phi>'_def u u' e'.adjoint_transpose_right(2) [of u' "F u"] by auto
	+
	+ have [simp]: "src\<^sub>D \<phi>' = src\<^sub>D u'"
	+ using \<phi>' by fastforce
	+ have [simp]: "trg\<^sub>D \<phi>' = trg\<^sub>D u'"
	+ using \<phi>' by fastforce
	+
	+ define \<psi>' where "\<psi>' = d'.trnr\<^sub>\<eta> v' (D.inv \<psi>)"
	+ have \<psi>'_eq: "\<psi>' = (D.inv \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
	+ unfolding \<psi>'_def d'.trnr\<^sub>\<eta>_def by simp
	+ have \<psi>': "\<guillemotleft>\<psi>' : v' \<Rightarrow>\<^sub>D F v \<star>\<^sub>D d'\<guillemotright>"
	+ using \<psi> \<psi>'_def v v' d'.adjoint_transpose_right(1) [of "F v" v'] by auto
	+ have iso_\<psi>': "D.iso \<psi>'"
	+ unfolding \<psi>'_def d'.trnr\<^sub>\<eta>_def
	+ using \<psi> e'.counit_is_iso
	+ by (metis D.arrI D.iso_hcomp D.hseq_char D.ide_is_iso D.iso_assoc'
	+ D.iso_inv_iso D.iso_runit' D.isos_compose D.seqE \<psi>'_eq
	+ \<psi>' d'.unit_simps(5) e'.antipar(1) e'.antipar(2) e'.ide_left e'.ide_right v')
	+
	+ have [simp]: "src\<^sub>D \<psi>' = src\<^sub>D v'"
	+ using \<psi>' by fastforce
	+ have [simp]: "trg\<^sub>D \<psi>' = trg\<^sub>D v'"
	+ using \<psi>' by fastforce
	+
	+ define w' where "w' = F w \<star>\<^sub>D d'"
	+ define \<theta>' where "\<theta>' = \<phi>' \<cdot>\<^sub>D (F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']"
	+ define \<nu>' where "\<nu>' = \<a>\<^sub>D[F g, F w, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ have w': "D.ide w' \<and> \<guillemotleft>w' : src\<^sub>D u' \<rightarrow>\<^sub>D src\<^sub>D (F f)\<guillemotright>"
	+ using w'_def \<omega> w\<theta>\<nu> by simp
	+ have \<theta>': "\<guillemotleft>\<theta>' : F f \<star>\<^sub>D w' \<Rightarrow>\<^sub>D u'\<guillemotright>"
	+ unfolding \<theta>'_def w'_def
	+ using \<phi>' \<omega> w\<theta>\<nu> \<Phi>_in_hom
	+ apply (intro D.comp_in_homI D.hcomp_in_vhom)
	+ apply auto
	+ by (intro D.comp_in_homI D.hcomp_in_vhom, auto)
	+ have \<nu>': "\<guillemotleft>\<nu>' : v' \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w'\<guillemotright>"
	+ unfolding \<nu>'_def w'_def
	+ using \<psi>' \<omega> w\<theta>\<nu> \<Phi>_in_hom \<Phi>_components_are_iso
	+ apply (intro D.comp_in_homI)
	+ apply auto
	+ by (intro D.hcomp_in_vhom D.comp_in_homI, auto)
	+ have iso_\<nu>': "D.iso \<nu>'"
	+ using \<nu>'_def iso_\<psi>' \<Phi>_in_hom \<Phi>.components_are_iso D.isos_compose preserves_iso
	+ by (metis (no_types, lifting) C.ideD(1) D.arrI D.iso_hcomp D.hseqE D.ide_is_iso
	+ D.iso_assoc D.iso_inv_iso D.seqE T.ide_leg1 T.leg1_simps(3) \<Phi>_components_are_iso
	+ \<nu>' \<open>src\<^sub>D (F w) = map\<^sub>0 a\<close> \<open>src\<^sub>D e' = map\<^sub>0 a\<close> \<open>trg\<^sub>C w = src\<^sub>C f\<close> e'.antipar(1)
	+ e'.ide_right preserves_ide preserves_src preserves_trg w\<theta>\<nu>)
	+
	+ have "T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' = \<omega>'"
	+ text \<open>
	+$$
	+\xy/67pt/
	+\xymatrix{
	+ &
	+ \xlowertwocell[ddddddl]{\scriptstyle{a'}}<-13>^{<2>v'}{^{\psi'}}
	+ \xuppertwocell[ddddddr]{}<13>^{<2>u'}{^{\phi'}}
	+ \ar [dd] ^{d'}
	+ \\
	+ \\
	+ & {\scriptstyle{{\rm src}(F g) \;=\;{\rm src}(F f)}}
	+ \xlowertwocell[ddddl]{}^{<2>F v}{^{F \nu}}
	+ \xuppertwocell[ddddr]{}^{<2>F u}{^{F \theta}}
	+ \ar[dd] ^{Fw}
	+ \\
	+ \\
	+ & \scriptstyle{a'} \xtwocell[ddd]{}\omit{^{F \rho}}
	+ \ar[ddl] _{F g}
	+ \ar[ddr] ^{F f}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
	+ \\
	+ &
	+}
	+\endxy
	+\qquad = \qquad
	+\xy/33pt/
	+\xymatrix{
	+ & \scriptstyle{\scriptstyle{a'}} \xtwocell[ddd]{}\omit{^{\omega'}}
	+ \ar[ddl] _{v'}
	+ \ar[ddr] ^{u'}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~(Fr)} & & \scriptstyle{{\rm src}~(Fr)} \ar[ll] ^{Fr}
	+ \\
	+ &
	+}
	+\endxy
	+$$
	+ \<close>
	+ proof -
	+ have 1: "\<guillemotleft>T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' : v' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u'\<guillemotright>"
	+ using w' \<theta>' \<nu>' w\<theta>\<nu> T'.composite_cell_in_hom by blast
	+ have "T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' =
	+ (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (F (T.composite_cell w \<theta> \<cdot>\<^sub>C \<nu>) \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' =
	+ (F r \<star>\<^sub>D \<phi>' \<cdot>\<^sub>D (F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w') \<cdot>\<^sub>D \<a>\<^sub>D[F g, F w, d'] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using \<theta>'_def \<nu>'_def D.comp_assoc by simp
	+ also have
	+ "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D (F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, F w, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using \<theta>' \<theta>'_def w'_def D.comp_assoc D.whisker_left by auto
	+ also have
	+ "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D (F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, F w, d']) \<cdot>\<^sub>D (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using \<theta>' \<theta>'_def D.whisker_right \<Phi>_in_hom D.comp_assoc by fastforce
	+ also have
	+ "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D (F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d'] \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F g, F w, d'] =
	+ \<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d'] \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d')"
	+ using D.assoc_naturality [of "D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>" "F w" d']
	+ \<Phi>_in_hom \<Phi>_components_are_iso
	+ by (simp add: w\<theta>\<nu>)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D \<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d']) \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using 1 D.whisker_left D.comp_assoc
	+ by (metis D.arrI D.hseq_char D.seqE T'.ide_base calculation)
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f \<star>\<^sub>D F w, d']) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "D.seq \<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d']"
	+ by (metis 1 D.arrI D.seqE calculation)
	+ moreover have "D.iso (F r \<star>\<^sub>D \<a>\<^sub>D[F f, F w, d'])"
	+ by (simp add: w\<theta>\<nu>)
	+ moreover have "D.inv (F r \<star>\<^sub>D \<a>\<^sub>D[F f, F w, d']) = F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']"
	+ using D.inv_hcomp [of "F r" "\<a>\<^sub>D[F f, F w, d']"] by (simp add: w\<theta>\<nu>)
	+ ultimately
	+ have "(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F w, d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d'] =
	+ \<a>\<^sub>D[F r, F f \<star>\<^sub>D F w, d'] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d')"
	+ using w\<theta>\<nu> D.pentagon
	+ D.invert_side_of_triangle(1)
	+ [of "\<a>\<^sub>D[F r, F f, F w \<star>\<^sub>D d'] \<cdot>\<^sub>D \<a>\<^sub>D[F r \<star>\<^sub>D F f, F w, d']"
	+ "F r \<star>\<^sub>D \<a>\<^sub>D[F f, F w, d']"
	+ "\<a>\<^sub>D[F r, F f \<star>\<^sub>D F w, d'] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d')"]
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D ((F r \<star>\<^sub>D F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F (f \<star>\<^sub>C w), d']) \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<Phi> (f, w)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "(F r \<star>\<^sub>D \<Phi> (f, w) \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D F w, d'] =
	+ \<a>\<^sub>D[F r, F (f \<star>\<^sub>C w), d'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<Phi> (f, w)) \<star>\<^sub>D d')"
	+ using 1 w\<theta>\<nu> D.assoc_naturality [of "F r" "\<Phi> (f, w)" d'] D.hseqI'
	+ \<open>trg\<^sub>C w = src\<^sub>C f\<close> e'.ide_right
	+ by (metis D.arrI D.hseq_char D.ide_char D.seqE T'.base_simps(3)
	+ T'.base_simps(4) T'.leg0_simps(3) T.ide_leg0 \<Phi>_simps(1-5) w'_def)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (((F r \<star>\<^sub>D F \<theta>) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<Phi> (f, w)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d')) \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "src\<^sub>D (F r) = trg\<^sub>D (F \<theta>)"
	+ using w\<theta>\<nu> by (metis C.arrI C.hseqE C.seqE \<omega> preserves_hseq)
	+ moreover have "src\<^sub>D (F \<theta>) = trg\<^sub>D d'"
	+ using w\<theta>\<nu>
	+ by (metis C.arrI C.seqE C.hcomp_simps(1) C.src_vcomp \<omega> \<open>src\<^sub>C \<omega> = src\<^sub>C u\<close>
	+ \<open>src\<^sub>C u = a\<close> \<open>trg\<^sub>D d' = map\<^sub>0 a\<close> preserves_src)
	+ ultimately
	+ have "(F r \<star>\<^sub>D F \<theta> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F (f \<star>\<^sub>C w), d'] =
	+ \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F \<theta>) \<star>\<^sub>D d')"
	+ using w\<theta>\<nu> D.assoc_naturality [of "F r" "F \<theta>" d'] by auto
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
	+ (((F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "((F r \<star>\<^sub>D F \<theta>) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<Phi> (f, w)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, F w] \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') =
	+ (F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu>
	+ \<star>\<^sub>D d'"
	+ proof -
	+ have "\<guillemotleft>(F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> :
	+ F v \<Rightarrow>\<^sub>D F r \<star>\<^sub>D F u\<guillemotright>"
	+ using w\<theta>\<nu> \<omega> \<Phi>_in_hom
	+ apply (intro D.comp_in_homI)
	+ apply auto
	+ by (intro D.hcomp_in_vhom, auto)
	+ hence "D.arr ((F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu>)"
	+ by auto
	+ thus ?thesis
	+ using D.whisker_right by fastforce
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using w\<theta>\<nu> D.whisker_left \<Phi>_in_hom
	+ by (metis D.seqI' T'.ide_base T.ide_leg0 \<open>trg\<^sub>C w = src\<^sub>C f\<close> preserves_hom)
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "(D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u)) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) =
	+ F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)"
	+ proof -
	+ have "(D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u)) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) =
	+ (F r \<star>\<^sub>D F u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w))"
	+ using u \<Phi>_components_are_iso
	+ by (simp add: D.comp_inv_arr')
	+ also have "... = F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)"
	+ using u \<omega> w\<theta>\<nu> \<Phi>_in_hom \<open>trg\<^sub>C u = src\<^sub>C r\<close>
	+ D.comp_cod_arr [of "F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)" "F r \<star>\<^sub>D F u"]
	+ by (metis (full_types) "*" D.arrI D.cod_comp D.seqE F\<omega> T.ide_base
	+ \<Phi>_simps(4))
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using D.comp_assoc by simp
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d' =
	+ (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D F \<nu> \<star>\<^sub>D d')"
	+ using D.whisker_right \<Phi>_in_hom \<Phi>_components_are_iso
	+ by (metis * D.arrI D.invert_side_of_triangle(1) F\<omega> T.ide_base \<omega>
	+ \<open>trg\<^sub>C u = src\<^sub>C r\<close> e'.ide_right u w\<theta>\<nu>)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (F (T.composite_cell w \<theta> \<cdot>\<^sub>C \<nu>) \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using D.comp_assoc * by simp
	+ finally show ?thesis by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (F \<omega> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using w\<theta>\<nu> by simp
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ \<psi>'"
	+ using \<omega> F\<omega>_def by simp
	+ text \<open>
	+$$
	+\xy/67pt/
	+\xymatrix{
	+ & {\scriptstyle{a'}}
	+ \xlowertwocell[ddddl]{}^{<2>F v}{^{\psi'}}
	+ \xuppertwocell[ddddr]{}^{<2>F u}{^{\phi'}}
	+ \ar@ {.}[dd] ^{d'}
	+ \\
	+ \\
	+ & \scriptstyle{{\rm src}(F a)} \xtwocell[ddd]{}\omit{^{F \omega}}
	+ \ar[ddl] _{F v}
	+ \ar[ddr] ^{F u}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
	+ \\
	+ &
	+}
	+\endxy
	+\qquad = \qquad
	+\xy/67pt/
	+\xymatrix{
	+ &
	+ \xlowertwocell[ddddddl]{\scriptstyle{a'}}<-13>^{<2>v'}{^{\psi'}}
	+ \xuppertwocell[ddddddr]{}<13>^{<2>u'}{^{\phi'}}
	+ \ar@ {.}[dd] ^{d'}
	+ \\
	+ \\
	+ & {\scriptstyle{{\rm src}(F a)}}
	+ \xlowertwocell[ddddl]{}^{<2>F v}{^{\psi}}
	+ \xuppertwocell[ddddr]{}^{<2>F u}{^{\phi}}
	+ \ar@ {.}[dd] ^{e'}
	+ \\
	+ \\
	+ & \scriptstyle{a'} \xtwocell[ddd]{}\omit{^{\omega'}}
	+ \ar[ddl] _{v'}
	+ \ar[ddr] ^{u'}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
	+ \\
	+ &
	+}
	+\endxy
	+$$
	+ \<close>
	+ also have "... = \<omega>'"
	+ text \<open>
	+$$
	+\xy/67pt/
	+\xymatrix{
	+ &
	+ \xlowertwocell[ddddddl]{\scriptstyle{a'}}<-13>^{<2>v'}{^{\psi'}}
	+ \xuppertwocell[ddddddr]{}<13>^{<2>u'}{^{\phi'}}
	+ \ar[dd] ^{d'}
	+ \\
	+ \\
	+ & {\scriptstyle{{\rm src}(F a)}}
	+ \xlowertwocell[ddddl]{}^{<2>F v}{^{\psi}}
	+ \xuppertwocell[ddddr]{}^{<2>F u}{^{\phi}}
	+ \ar[dd] ^{e'}
	+ \\
	+ \\
	+ & \scriptstyle{a'} \xtwocell[ddd]{}\omit{^{\omega'}}
	+ \ar[ddl] _{v'}
	+ \ar[ddr] ^{u'}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~(F r)} \ar[ll] ^{F r}
	+ \\
	+ &
	+}
	+\endxy
	+\qquad = \qquad
	+\xy/33pt/
	+\xymatrix{
	+ & \scriptstyle{a'} \xtwocell[ddd]{}\omit{^{\omega'}}
	+ \ar[ddl] _{v'}
	+ \ar[ddr] ^{u'}
	+ \\
	+ \\
	+ \scriptstyle{{\rm trg}~(F r)} & & \scriptstyle{{\rm src}~)(F r)} \ar[ll] ^{F r}
	+ \\
	+ &
	+}
	+\endxy
	+$$
	+ \<close>
	+ proof -
	+ have "(F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>' =
	+ (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (r, u) \<star>\<^sub>D d')) \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using D.whisker_right \<Phi>_in_hom D.comp_assoc
	+ by (metis D.arrI F\<omega> F\<omega>_def e'.ide_right)
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "(D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (r, u) \<star>\<^sub>D d') =
	+ D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u) \<star>\<^sub>D d'"
	+ using \<Phi>_in_hom \<Phi>_components_are_iso D.whisker_right
	+ by (metis C.hseqI D.comp_arr_inv' D.in_homE D.invert_opposite_sides_of_square
	+ D.iso_inv_iso T.ide_base T.base_in_hom(1) \<open>trg\<^sub>C u = src\<^sub>C r\<close> e'.ide_right
	+ preserves_arr u)
	+ also have "... = (F r \<star>\<^sub>D F u) \<star>\<^sub>D d'"
	+ using u \<Phi>_components_are_iso D.comp_inv_arr' by simp
	+ finally have "(F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, u)) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<Phi> (r, u) \<star>\<^sub>D d')) \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>' =
	+ (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F u) \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ by simp
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F u) \<star>\<^sub>D d')) \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using D.comp_assoc by auto
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using u D.comp_arr_dom by simp
	+ finally show ?thesis by blast
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<phi>) \<star>\<^sub>D d')) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ ((\<omega>' \<star>\<^sub>D e') \<star>\<^sub>D d') \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have
	+ "(F r \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e') \<cdot>\<^sub>D \<psi> \<star>\<^sub>D d' =
	+ ((F r \<star>\<^sub>D \<phi>) \<star>\<^sub>D d') \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') \<cdot>\<^sub>D ((\<omega>' \<star>\<^sub>D e') \<star>\<^sub>D d') \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d')"
	+ using D.whisker_right \<phi> \<phi>' e' e'.antipar(1) u' u'_in_hhom
	+ by (metis D.arrI D.seqE F\<omega> F\<omega>_def e'.ide_right)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') \<cdot>\<^sub>D ((\<omega>' \<star>\<^sub>D e') \<star>\<^sub>D d')) \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "\<a>\<^sub>D[F r, F u, d'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<phi>) \<star>\<^sub>D d') =
	+ (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d']"
	+ using D.assoc_naturality [of "F r" \<phi> d'] \<phi> by auto
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D u', e', d'] \<cdot>\<^sub>D
	+ (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[v', e', d'])) \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ using F\<omega> F\<omega>_def \<omega>' D.comp_assoc D.hseqI' D.hcomp_reassoc(1) [of \<omega>' e' d']
	+ by (elim D.in_homE, simp)
	+ also have "... = (F r \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D
	+ (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<psi>'"
	+ proof -
	+ have "D.seq (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d'])
	+ (\<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d'))"
	+ using u' by (simp add: D.hseqI')
	+ moreover have "(F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') =
	+ \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D \<a>\<^sub>D[F r \<star>\<^sub>D u', e', d']"
	+ using u' D.pentagon by simp
	+ moreover have "D.iso (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d'])"
	+ using u' by simp
	+ moreover have "D.inv (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) = F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']"
	+ using u' by simp
	+ ultimately
	+ have "\<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D u', e', d'] =
	+ (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d']"
	+ using u' D.comp_assoc D.hseqI'
	+ D.invert_opposite_sides_of_square
	+ [of "F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']"
	+ "\<a>\<^sub>D[F r, u' \<star>\<^sub>D e', d'] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', e'] \<star>\<^sub>D d')"
	+ "\<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d']" "\<a>\<^sub>D[F r \<star>\<^sub>D u', e', d']"]
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by metis
	+ qed
	+ also have
	+ "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u'] \<cdot>\<^sub>D (u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[u', e', d'] \<cdot>\<^sub>D (D.inv \<phi> \<star>\<^sub>D d')) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D
	+ (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D (D.inv \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
	+ unfolding \<phi>'_def \<psi>'_def e'.trnr\<^sub>\<epsilon>_def d'.trnr\<^sub>\<eta>_def by simp
	+ also have
	+ "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D (\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D (D.inv \<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] \<cdot>\<^sub>D
	+ (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
	+ proof -
	+ have "F r \<star>\<^sub>D \<r>\<^sub>D[u'] \<cdot>\<^sub>D (u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[u', e', d'] \<cdot>\<^sub>D (D.inv \<phi> \<star>\<^sub>D d') =
	+ (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d')"
	+ proof -
	+ have "D.ide (F r)" by simp
	+ moreover have "D.seq \<r>\<^sub>D[u'] ((u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[u', e', d'] \<cdot>\<^sub>D (D.inv \<phi> \<star>\<^sub>D d')) \<and>
	+ D.seq (u' \<star>\<^sub>D \<epsilon>') (\<a>\<^sub>D[u', e', d'] \<cdot>\<^sub>D (D.inv \<phi> \<star>\<^sub>D d')) \<and>
	+ D.seq \<a>\<^sub>D[u', e', d'] (D.inv \<phi> \<star>\<^sub>D d')"
	+ using \<phi>' \<phi>'_def unfolding e'.trnr\<^sub>\<epsilon>_def by blast
	+ ultimately show ?thesis
	+ using D.whisker_left by metis
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D
	+ (((F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d')) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d'])) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D (((\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D (D.inv \<psi> \<star>\<^sub>D d')) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d']) \<cdot>\<^sub>D
	+ (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
	+ using D.comp_assoc by simp
	+ also have
	+ "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d']) \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>')) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
	+ proof -
	+ have "((F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) =
	+ F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']"
	+ proof -
	+ have "(F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') = F r \<star>\<^sub>D D.inv \<phi> \<cdot>\<^sub>D \<phi> \<star>\<^sub>D d'"
	+ using u u' \<phi> 1 2 D.src_dom e'.antipar D.hseqI' D.whisker_left D.whisker_right
	+ by auto
	+ also have "... = F r \<star>\<^sub>D (u' \<star>\<^sub>D e') \<star>\<^sub>D d'"
	+ using \<phi> D.comp_inv_arr' by auto
	+ finally have
	+ "(F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d') = F r \<star>\<^sub>D (u' \<star>\<^sub>D e') \<star>\<^sub>D d'"
	+ by simp
	+ hence
	+ "((F r \<star>\<^sub>D D.inv \<phi> \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<phi> \<star>\<^sub>D d')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']) =
	+ (F r \<star>\<^sub>D (u' \<star>\<^sub>D e') \<star>\<^sub>D d') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d'])"
	+ using D.comp_assoc by simp
	+ also have "... = F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']"
	+ proof -
	+ have "\<guillemotleft>F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d'] :
	+ F r \<star>\<^sub>D u' \<star>\<^sub>D e' \<star>\<^sub>D d' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D (u' \<star>\<^sub>D e') \<star>\<^sub>D d'\<guillemotright>"
	+ using u' e'.antipar \<phi>' D.assoc'_in_hom
	+ unfolding e'.trnr\<^sub>\<epsilon>_def
	+ by (intro D.hcomp_in_vhom, auto)
	+ thus ?thesis
	+ using D.comp_cod_arr by blast
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ moreover have
	+ "((\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D (D.inv \<psi> \<star>\<^sub>D d')) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] = \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d']"
	+ proof -
	+ have "(\<psi> \<star>\<^sub>D d') \<cdot>\<^sub>D (D.inv \<psi> \<star>\<^sub>D d') = (v' \<star>\<^sub>D e') \<star>\<^sub>D d'"
	+ using \<psi> e'.antipar D.src_cod v' e'.antipar \<psi>' d'.trnr\<^sub>\<eta>_def
	+ D.whisker_right [of d' \<psi> "D.inv \<psi>"] D.comp_arr_inv'
	+ by auto
	+ moreover have "\<guillemotleft>\<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] : v' \<star>\<^sub>D e' \<star>\<^sub>D d' \<Rightarrow>\<^sub>D (v' \<star>\<^sub>D e') \<star>\<^sub>D d'\<guillemotright>"
	+ using v' e'.antipar \<psi>' D.assoc'_in_hom
	+ unfolding d'.trnr\<^sub>\<eta>_def
	+ by fastforce
	+ ultimately show ?thesis
	+ using D.comp_cod_arr by auto
	+ qed
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (((F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d'])) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d']) \<cdot>\<^sub>D
	+ (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
	+ proof -
	+ have "(\<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d']) \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') = v' \<star>\<^sub>D D.inv \<epsilon>'"
	+ proof -
	+ have 1: "D.hseq v' e'"
	+ using v' e'.antipar \<psi>' unfolding d'.trnr\<^sub>\<eta>_def by fastforce
	+ have "\<a>\<^sub>D[v', e', d'] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[v', e', d'] = v' \<star>\<^sub>D e' \<star>\<^sub>D d'"
	+ using v' e'.antipar 1 D.comp_assoc_assoc' by auto
	+ moreover have "\<guillemotleft>v' \<star>\<^sub>D D.inv \<epsilon>' : v' \<star>\<^sub>D trg\<^sub>D e' \<Rightarrow>\<^sub>D v' \<star>\<^sub>D e' \<star>\<^sub>D d'\<guillemotright>"
	+ using v' e'.antipar 1
	+ apply (intro D.hcomp_in_vhom)
	+ apply auto
	+ by (metis D.ideD(1) D.trg_src \<open>trg\<^sub>D e' = a'\<close> e'.antipar(2) e'.ide_right)
	+ ultimately show ?thesis
	+ using D.comp_cod_arr by auto
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D ((F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d']) \<cdot>\<^sub>D
	+ (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
	+ proof -
	+ have "((F r \<star>\<^sub>D \<a>\<^sub>D[u', e', d']) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d'])) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] =
	+ \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d']"
	+ using \<phi> u' e'.antipar 1 D.comp_cod_arr D.comp_assoc_assoc'
	+ D.whisker_left [of "F r" "\<a>\<^sub>D[u', e', d']" "\<a>\<^sub>D\<^sup>-\<^sup>1[u', e', d']"]
	+ by auto
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', trg\<^sub>D e'] \<cdot>\<^sub>D (((F r \<star>\<^sub>D u') \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D
	+ (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d')) \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
	+ proof -
	+ have "(F r \<star>\<^sub>D u' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', e' \<star>\<^sub>D d'] =
	+ \<a>\<^sub>D[F r, u', trg\<^sub>D e'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D u') \<star>\<^sub>D \<epsilon>')"
	+ using D.assoc_naturality [of "F r" u' \<epsilon>'] e' u' u'_in_hhom by force
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', trg\<^sub>D e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D trg\<^sub>D e') \<cdot>\<^sub>D
	+ ((v' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>')) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
	+ proof -
	+ have "((F r \<star>\<^sub>D u') \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') = (\<omega>' \<star>\<^sub>D trg\<^sub>D e') \<cdot>\<^sub>D (v' \<star>\<^sub>D \<epsilon>')"
	+ proof -
	+ have "((F r \<star>\<^sub>D u') \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D e' \<star>\<^sub>D d') =
	+ ((F r \<star>\<^sub>D u') \<cdot>\<^sub>D \<omega>' \<star>\<^sub>D \<epsilon>' \<cdot>\<^sub>D (e' \<star>\<^sub>D d'))"
	+ using D.interchange
	+ by (metis D.comp_arr_dom D.hcomp_simps(3) D.hseqI D.ide_char D.in_hhomE
	+ D.in_homE D.seqI T'.base_in_hom(1) T'.base_simps(3) T.base_simps(2)
	+ \<omega>' e'.counit_simps(1) e'.counit_simps(2) preserves_src u' u'_in_hhom)
	+ also have "... = \<omega>' \<cdot>\<^sub>D v' \<star>\<^sub>D trg\<^sub>D e' \<cdot>\<^sub>D \<epsilon>'"
	+ using \<omega>' D.comp_arr_dom D.comp_cod_arr by auto
	+ also have "... = (\<omega>' \<star>\<^sub>D trg\<^sub>D e') \<cdot>\<^sub>D (v' \<star>\<^sub>D \<epsilon>')"
	+ using D.interchange
	+ by (metis D.arrI D.comp_cod_arr D.ide_char D.seqI \<omega>' \<open>trg\<^sub>D e' = a'\<close>
	+ e'.counit_simps(1) e'.counit_simps(3) e'.counit_simps(5) v' v'_def)
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u', trg\<^sub>D e'] \<cdot>\<^sub>D (\<omega>' \<star>\<^sub>D trg\<^sub>D e') \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[v']"
	+ proof -
	+ have "(v' \<star>\<^sub>D \<epsilon>') \<cdot>\<^sub>D (v' \<star>\<^sub>D D.inv \<epsilon>') = v' \<star>\<^sub>D trg\<^sub>D e'"
	+ using v' D.whisker_left D.comp_arr_inv D.inv_is_inverse
	+ by (metis D.comp_arr_inv' D.seqI' d'.unit_in_vhom e'.counit_in_hom(2)
	+ e'.counit_is_iso e'.counit_simps(3))
	+ moreover have "\<guillemotleft>\<r>\<^sub>D\<^sup>-\<^sup>1[v'] : v' \<Rightarrow>\<^sub>D v' \<star>\<^sub>D trg\<^sub>D e'\<guillemotright>"
	+ using v' 1 by simp
	+ ultimately show ?thesis
	+ using v' D.comp_cod_arr by auto
	+ qed
	+ also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, u', trg\<^sub>D e'] \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D u']) \<cdot>\<^sub>D \<omega>'"
	+ using u' v' \<omega>' D.runit'_naturality D.comp_assoc
	+ by (metis D.in_hhomE D.in_homE a'_def e')
	+ also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[u']) \<cdot>\<^sub>D \<omega>'"
	+ using 1 T'.ide_base u' D.runit_hcomp [of "F r" u'] by fastforce
	+ also have "... = ((F r \<star>\<^sub>D \<r>\<^sub>D[u']) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[u'])) \<cdot>\<^sub>D \<omega>'"
	+ using D.comp_assoc by simp
	+ also have "... = (F r \<star>\<^sub>D \<r>\<^sub>D[u'] \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[u']) \<cdot>\<^sub>D \<omega>'"
	+ using 1 T'.ide_base u' D.whisker_left by simp
	+ also have "... = (F r \<star>\<^sub>D u') \<cdot>\<^sub>D \<omega>'"
	+ using u'
	+ by (metis D.comp_ide_self D.ide_in_hom(2) D.ide_is_iso
	+ D.invert_opposite_sides_of_square D.invert_side_of_triangle(1)
	+ D.iso_runit D.runit_in_vhom D.seqI')
	+ also have "... = \<omega>'"
	+ using \<omega>' D.comp_cod_arr by auto
	+ finally show ?thesis by simp
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ thus "\<exists>w' \<theta>' \<nu>'. D.ide w' \<and> \<guillemotleft>\<theta>' : F f \<star>\<^sub>D w' \<Rightarrow>\<^sub>D u'\<guillemotright> \<and>
	+ \<guillemotleft>\<nu>' : D.dom \<omega>' \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w'\<guillemotright> \<and> D.iso \<nu>' \<and> T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<nu>' = \<omega>'"
	+ using w' \<theta>' \<nu>' iso_\<nu>' v'_def by blast
	+ qed
	+
	+ text \<open>Now we establish \<open>T'.T2\<close>.\<close>
	+ next
	+ fix u w w' \<theta> \<theta>' \<beta>
	+ assume w: "D.ide w"
	+ assume w': "D.ide w'"
	+ assume \<theta>: "\<guillemotleft>\<theta> : F f \<star>\<^sub>D w \<Rightarrow>\<^sub>D u\<guillemotright>"
	+ assume \<theta>': "\<guillemotleft>\<theta>' : F f \<star>\<^sub>D w' \<Rightarrow>\<^sub>D u\<guillemotright>"
	+ assume \<beta>: "\<guillemotleft>\<beta> : F g \<star>\<^sub>D w \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w'\<guillemotright>"
	+ assume eq: "T'.composite_cell w \<theta> = T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<beta>"
	+ show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>D w'\<guillemotright> \<and> \<beta> = F g \<star>\<^sub>D \<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>)"
	+ proof -
	+ define a where "a = src\<^sub>D w"
	+ have a: "D.obj a"
	+ unfolding a_def by (simp add: w)
	+
	+ have [simp]: "src\<^sub>D \<theta> = a"
	+ using \<theta> a_def
	+ by (metis D.dom_src D.in_homE D.src.preserves_dom D.src.preserves_reflects_arr
	+ D.src_hcomp')
	+ have [simp]: "trg\<^sub>D \<theta> = trg\<^sub>D (F f)"
	+ using \<theta>
	+ by (metis D.dom_trg D.hseq_char' D.ideD(1) D.ide_trg D.in_homE D.trg.is_extensional
	+ D.trg.preserves_dom D.hcomp_simps(2))
	+ have [simp]: "src\<^sub>D \<theta>' = a"
	+ using \<theta>' a_def
	+ by (metis D.horizontal_homs_axioms D.in_homE \<open>src\<^sub>D \<theta> = a\<close> \<theta> horizontal_homs.src_cod)
	+ have [simp]: "trg\<^sub>D \<theta>' = trg\<^sub>D (F f)"
	+ using \<theta>'
	+ by (metis D.dom_trg D.hseq_char' D.ideD(1) D.ide_trg D.in_homE D.trg.is_extensional
	+ D.trg.preserves_dom D.hcomp_simps(2))
	+ have [simp]: "src\<^sub>D w = a"
	+ using a_def by simp
	+ have [simp]: "trg\<^sub>D w = map\<^sub>0 (src\<^sub>C \<rho>)"
	+ by (metis D.horizontal_homs_axioms D.hseq_char D.in_homE T.tab_simps(2) T.leg0_simps(2)
	+ \<theta> category.ideD(1) category.ide_dom horizontal_homs_def preserves_src)
	+ have [simp]: "src\<^sub>D w' = a"
	+ using a_def
	+ by (metis D.dom_src D.hseq_char' D.ideD(1) D.in_homE D.src.is_extensional
	+ D.src.preserves_dom D.src.preserves_ide \<open>src\<^sub>D \<theta>' = a\<close> \<theta>' D.hcomp_simps(1) w)
	+ have [simp]: "trg\<^sub>D w' = map\<^sub>0 (src\<^sub>C \<rho>)"
	+ by (metis D.horizontal_homs_axioms D.hseq_char D.in_homE T.tab_simps(2) T.leg0_simps(2)
	+ \<theta>' category.ideD(1) category.ide_dom horizontal_homs_def preserves_src)
	+
	+ text \<open>First, reflect the picture back to \<open>C\<close>, so that we will be able to apply \<open>T.T2\<close>.
	+ We need to choose arrows in \<open>C\<close> carefully, so that their \<open>F\<close> images will enable the
	+ cancellation of the various isomorphisms that appear.\<close>
	+
	+ obtain a\<^sub>C where a\<^sub>C: "C.obj a\<^sub>C \<and> D.equivalent_objects (map\<^sub>0 a\<^sub>C) a"
	+ using w a_def surjective_on_objects_up_to_equivalence D.obj_src D.ideD(1)
	+ by presburger
	+ obtain e where e: "\<guillemotleft>e : map\<^sub>0 a\<^sub>C \<rightarrow>\<^sub>D a\<guillemotright> \<and> D.equivalence_map e"
	+ using a\<^sub>C D.equivalent_objects_def by auto
	+ obtain d \<eta> \<epsilon>
	+ where d\<eta>\<epsilon>: "adjoint_equivalence_in_bicategory (\<cdot>\<^sub>D) (\<star>\<^sub>D) \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D e d \<eta> \<epsilon>"
	+ using e D.equivalence_map_extends_to_adjoint_equivalence by blast
	+ interpret e: adjoint_equivalence_in_bicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D e d \<eta> \<epsilon>
	+ using d\<eta>\<epsilon> by auto
	+ interpret d: adjoint_equivalence_in_bicategory \<open>(\<cdot>\<^sub>D)\<close> \<open>(\<star>\<^sub>D)\<close> \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ d e "D.inv \<epsilon>" "D.inv \<eta>"
	+ using e.dual_adjoint_equivalence by simp
	+
	+ have [simp]: "src\<^sub>D e = map\<^sub>0 a\<^sub>C"
	+ using e by auto
	+ have [simp]: "trg\<^sub>D e = a"
	+ using e by auto
	+ have [simp]: "src\<^sub>D d = a"
	+ using e.antipar by simp
	+ have [simp]: "trg\<^sub>D d = map\<^sub>0 a\<^sub>C"
	+ using e.antipar by simp
	+
	+ have we: "\<guillemotleft>w \<star>\<^sub>D e : map\<^sub>0 a\<^sub>C \<rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C \<rho>)\<guillemotright>"
	+ using a\<^sub>C e D.ideD(1) \<open>trg\<^sub>D w = map\<^sub>0 (src\<^sub>C \<rho>)\<close> a_def by blast
	+ obtain w\<^sub>C where
	+ w\<^sub>C: "C.ide w\<^sub>C \<and> \<guillemotleft>w\<^sub>C : a\<^sub>C \<rightarrow>\<^sub>C src\<^sub>C \<rho>\<guillemotright> \<and> D.isomorphic (F w\<^sub>C) (w \<star>\<^sub>D e)"
	+ using a\<^sub>C e we locally_essentially_surjective [of a\<^sub>C "src\<^sub>C \<rho>" "w \<star>\<^sub>D e"]
	+ C.obj_src T.tab_simps(1) e.ide_left w by blast
	+ have w'e: "\<guillemotleft>w' \<star>\<^sub>D e : map\<^sub>0 a\<^sub>C \<rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C \<rho>)\<guillemotright>"
	+ using a\<^sub>C e D.ideD(1) \<open>trg\<^sub>D w' = map\<^sub>0 (src\<^sub>C \<rho>)\<close> a_def \<open>src\<^sub>D w' = a\<close> w' by blast
	+ obtain w\<^sub>C' where
	+ w\<^sub>C': "C.ide w\<^sub>C' \<and> \<guillemotleft>w\<^sub>C' : a\<^sub>C \<rightarrow>\<^sub>C src\<^sub>C \<rho>\<guillemotright> \<and> D.isomorphic (F w\<^sub>C') (w' \<star>\<^sub>D e)"
	+ using a\<^sub>C e a_def locally_essentially_surjective
	+ by (metis C.obj_src D.ide_hcomp D.hseq_char D.in_hhomE T.tab_simps(2)
	+ T.leg0_simps(2) e.ide_left w' w'e)
	+
	+ have [simp]: "src\<^sub>C w\<^sub>C = a\<^sub>C"
	+ using w\<^sub>C by auto
	+ have [simp]: "trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>"
	+ using w\<^sub>C by auto
	+ have [simp]: "src\<^sub>C w\<^sub>C' = a\<^sub>C"
	+ using w\<^sub>C' by auto
	+ have [simp]: "trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>"
	+ using w\<^sub>C' by auto
	+
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : F w\<^sub>C \<Rightarrow>\<^sub>D w \<star>\<^sub>D e\<guillemotright> \<and> D.iso \<phi>"
	+ using w\<^sub>C D.isomorphicE by blast
	+ obtain \<phi>' where \<phi>': "\<guillemotleft>\<phi>' : F w\<^sub>C' \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright> \<and> D.iso \<phi>'"
	+ using w\<^sub>C' D.isomorphicE by blast
	+
	+ have ue: "\<guillemotleft>u \<star>\<^sub>D e : map\<^sub>0 a\<^sub>C \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C f)\<guillemotright> \<and> D.ide (u \<star>\<^sub>D e)"
	+ using a\<^sub>C e \<theta> e.ide_left
	+ by (intro conjI, auto)
	+ obtain u\<^sub>C where
	+ u\<^sub>C: "C.ide u\<^sub>C \<and> \<guillemotleft>u\<^sub>C : a\<^sub>C \<rightarrow>\<^sub>C trg\<^sub>C f\<guillemotright> \<and> D.isomorphic (F u\<^sub>C) (u \<star>\<^sub>D e)"
	+ using a\<^sub>C e ue locally_essentially_surjective [of a\<^sub>C "trg\<^sub>C f" "u \<star>\<^sub>D e"] by auto
	+
	+ have [simp]: "src\<^sub>C u\<^sub>C = a\<^sub>C"
	+ using u\<^sub>C by auto
	+ have [simp]: "trg\<^sub>C u\<^sub>C = trg\<^sub>C f"
	+ using u\<^sub>C by auto
	+
	+ obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : u \<star>\<^sub>D e \<Rightarrow>\<^sub>D F u\<^sub>C\<guillemotright> \<and> D.iso \<psi>"
	+ using u\<^sub>C D.isomorphic_symmetric D.isomorphicE by blast
	+
	+ define F\<theta>\<^sub>C where
	+ "F\<theta>\<^sub>C = \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
	+ have 1: "\<guillemotleft>F\<theta>\<^sub>C : F (f \<star>\<^sub>C w\<^sub>C) \<Rightarrow>\<^sub>D F u\<^sub>C\<guillemotright>"
	+ proof (unfold F\<theta>\<^sub>C_def, intro D.comp_in_homI)
	+ show "\<guillemotleft>D.inv (\<Phi> (f, w\<^sub>C)) : F (f \<star>\<^sub>C w\<^sub>C) \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F w\<^sub>C\<guillemotright>"
	+ by (simp add: \<Phi>_in_hom(2) w\<^sub>C)
	+ show "\<guillemotleft>F f \<star>\<^sub>D \<phi> : F f \<star>\<^sub>D F w\<^sub>C \<Rightarrow>\<^sub>D F f \<star>\<^sub>D w \<star>\<^sub>D e\<guillemotright>"
	+ using w w\<^sub>C \<phi> by (intro D.hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] : F f \<star>\<^sub>D w \<star>\<^sub>D e \<Rightarrow>\<^sub>D (F f \<star>\<^sub>D w) \<star>\<^sub>D e\<guillemotright>"
	+ using w D.assoc'_in_hom by simp
	+ show "\<guillemotleft>\<theta> \<star>\<^sub>D e : (F f \<star>\<^sub>D w) \<star>\<^sub>D e \<Rightarrow>\<^sub>D u \<star>\<^sub>D e\<guillemotright>"
	+ using w \<theta> by (intro D.hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<psi> : u \<star>\<^sub>D e \<Rightarrow>\<^sub>D F u\<^sub>C\<guillemotright>"
	+ using \<psi> by simp
	+ qed
	+ have 2: "\<exists>\<theta>\<^sub>C. \<guillemotleft>\<theta>\<^sub>C : f \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C u\<^sub>C\<guillemotright> \<and> F \<theta>\<^sub>C = F\<theta>\<^sub>C"
	+ using u\<^sub>C w\<^sub>C 1 e \<theta> \<phi> locally_full by simp
	+ obtain \<theta>\<^sub>C where \<theta>\<^sub>C: "\<guillemotleft>\<theta>\<^sub>C : f \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C u\<^sub>C\<guillemotright> \<and> F \<theta>\<^sub>C = F\<theta>\<^sub>C"
	+ using 2 by auto
	+
	+ define F\<theta>\<^sub>C' where
	+ "F\<theta>\<^sub>C' = \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C'))"
	+ have 1: "\<guillemotleft>F\<theta>\<^sub>C' : F (f \<star>\<^sub>C w\<^sub>C') \<Rightarrow>\<^sub>D F u\<^sub>C\<guillemotright>"
	+ proof (unfold F\<theta>\<^sub>C'_def, intro D.comp_in_homI)
	+ show "\<guillemotleft>D.inv (\<Phi> (f, w\<^sub>C')) : F (f \<star>\<^sub>C w\<^sub>C') \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F w\<^sub>C'\<guillemotright>"
	+ by (simp add: \<Phi>_in_hom(2) w\<^sub>C')
	+ show "\<guillemotleft>F f \<star>\<^sub>D \<phi>' : F f \<star>\<^sub>D F w\<^sub>C' \<Rightarrow>\<^sub>D F f \<star>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>"
	+ using w' w\<^sub>C' \<phi>' by (intro D.hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] : F f \<star>\<^sub>D w' \<star>\<^sub>D e \<Rightarrow>\<^sub>D (F f \<star>\<^sub>D w') \<star>\<^sub>D e\<guillemotright>"
	+ using w' D.assoc'_in_hom by simp
	+ show "\<guillemotleft>\<theta>' \<star>\<^sub>D e : (F f \<star>\<^sub>D w') \<star>\<^sub>D e \<Rightarrow>\<^sub>D u \<star>\<^sub>D e\<guillemotright>"
	+ using w' \<theta>' by (intro D.hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<psi> : u \<star>\<^sub>D e \<Rightarrow>\<^sub>D F u\<^sub>C\<guillemotright>"
	+ using \<psi> by simp
	+ qed
	+ have 2: "\<exists>\<theta>\<^sub>C'. \<guillemotleft>\<theta>\<^sub>C' : f \<star>\<^sub>C w\<^sub>C' \<Rightarrow>\<^sub>C u\<^sub>C\<guillemotright> \<and> F \<theta>\<^sub>C' = F\<theta>\<^sub>C'"
	+ using u\<^sub>C w\<^sub>C' 1 e \<theta> \<phi> locally_full by simp
	+ obtain \<theta>\<^sub>C' where \<theta>\<^sub>C': "\<guillemotleft>\<theta>\<^sub>C' : f \<star>\<^sub>C w\<^sub>C' \<Rightarrow>\<^sub>C u\<^sub>C\<guillemotright> \<and> F \<theta>\<^sub>C' = F\<theta>\<^sub>C'"
	+ using 2 by auto
	+
	+ define F\<beta>\<^sub>C where
	+ "F\<beta>\<^sub>C = \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ have F\<beta>\<^sub>C: "\<guillemotleft>F\<beta>\<^sub>C: F (g \<star>\<^sub>C w\<^sub>C) \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C w\<^sub>C')\<guillemotright>"
	+ proof (unfold F\<beta>\<^sub>C_def, intro D.comp_in_homI)
	+ show "\<guillemotleft>D.inv (\<Phi> (g, w\<^sub>C)) : F (g \<star>\<^sub>C w\<^sub>C) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F w\<^sub>C\<guillemotright>"
	+ by (simp add: \<Phi>_in_hom(2) w\<^sub>C)
	+ show "\<guillemotleft>F g \<star>\<^sub>D \<phi> : F g \<star>\<^sub>D F w\<^sub>C \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w \<star>\<^sub>D e\<guillemotright>"
	+ using w\<^sub>C \<phi> apply (intro D.hcomp_in_vhom) by auto
	+ show "\<guillemotleft>\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] : F g \<star>\<^sub>D w \<star>\<^sub>D e \<Rightarrow>\<^sub>D (F g \<star>\<^sub>D w) \<star>\<^sub>D e\<guillemotright>"
	+ using w D.assoc'_in_hom by simp
	+ show "\<guillemotleft>\<beta> \<star>\<^sub>D e : (F g \<star>\<^sub>D w) \<star>\<^sub>D e \<Rightarrow>\<^sub>D (F g \<star>\<^sub>D w') \<star>\<^sub>D e\<guillemotright>"
	+ using w \<beta> apply (intro D.hcomp_in_vhom) by auto
	+ show "\<guillemotleft>\<a>\<^sub>D[F g, w', e] : (F g \<star>\<^sub>D w') \<star>\<^sub>D e \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>"
	+ using w' e.antipar D.assoc_in_hom by simp
	+ show "\<guillemotleft>F g \<star>\<^sub>D D.inv \<phi>' : F g \<star>\<^sub>D w' \<star>\<^sub>D e \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F w\<^sub>C'\<guillemotright>"
	+ using w' w\<^sub>C' \<phi>' by (intro D.hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<Phi> (g, w\<^sub>C') : F g \<star>\<^sub>D F w\<^sub>C' \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C w\<^sub>C')\<guillemotright>"
	+ using w\<^sub>C' \<Phi>_in_hom by simp
	+ qed
	+
	+ have 1: "\<exists>\<beta>\<^sub>C. \<guillemotleft>\<beta>\<^sub>C : g \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<^sub>C'\<guillemotright> \<and> F \<beta>\<^sub>C = F\<beta>\<^sub>C"
	+ using w\<^sub>C w\<^sub>C' F\<beta>\<^sub>C locally_full by simp
	+ obtain \<beta>\<^sub>C where \<beta>\<^sub>C: "\<guillemotleft>\<beta>\<^sub>C : g \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<^sub>C'\<guillemotright> \<and> F \<beta>\<^sub>C = F\<beta>\<^sub>C"
	+ using 1 by auto
	+
	+ text \<open>
	+ The following is the main calculation that needs to be done, to permit us
	+ to apply \<open>T.T2\<close>.
	+ Once again, it started out looking simple, but once all the necessary
	+ isomorphisms are thrown in it looks much more complicated.
	+ \<close>
	+
	+ have *: "T.composite_cell w\<^sub>C \<theta>\<^sub>C = T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C"
	+ proof -
	+ have par: "C.par (T.composite_cell w\<^sub>C \<theta>\<^sub>C) (T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C)"
	+ proof -
	+ have "\<guillemotleft>T.composite_cell w\<^sub>C \<theta>\<^sub>C : g \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<^sub>C\<guillemotright>"
	+ using w\<^sub>C \<theta>\<^sub>C T.composite_cell_in_hom by simp
	+ moreover have "\<guillemotleft>T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C : g \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<^sub>C\<guillemotright>"
	+ proof (intro C.comp_in_homI)
	+ show "\<guillemotleft>\<beta>\<^sub>C : g \<star>\<^sub>C w\<^sub>C \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<^sub>C'\<guillemotright>"
	+ using \<beta>\<^sub>C by simp
	+ show "\<guillemotleft>\<rho> \<star>\<^sub>C w\<^sub>C' : g \<star>\<^sub>C w\<^sub>C' \<Rightarrow>\<^sub>C (r \<star>\<^sub>C f) \<star>\<^sub>C w\<^sub>C'\<guillemotright>"
	+ using w\<^sub>C' by (intro C.hcomp_in_vhom, auto)
	+ show "\<guillemotleft>\<a>\<^sub>C[r, f, w\<^sub>C'] : (r \<star>\<^sub>C f) \<star>\<^sub>C w\<^sub>C' \<Rightarrow>\<^sub>C r \<star>\<^sub>C f \<star>\<^sub>C w\<^sub>C'\<guillemotright>"
	+ using w\<^sub>C' C.assoc_in_hom by simp
	+ show "\<guillemotleft>r \<star>\<^sub>C \<theta>\<^sub>C' : r \<star>\<^sub>C f \<star>\<^sub>C w\<^sub>C' \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<^sub>C\<guillemotright>"
	+ using w\<^sub>C' \<theta>\<^sub>C' by (intro C.hcomp_in_vhom, auto)
	+ qed
	+ ultimately show ?thesis
	+ by (metis C.in_homE)
	+ qed
	+ moreover have "F (T.composite_cell w\<^sub>C \<theta>\<^sub>C) = F (T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C)"
	+ proof -
	+ have "F (T.composite_cell w\<^sub>C \<theta>\<^sub>C) = F (r \<star>\<^sub>C \<theta>\<^sub>C) \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w\<^sub>C] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w\<^sub>C)"
	+ using par by auto
	+ also have "... = (\<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C))) \<cdot>\<^sub>D
	+ (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C))) \<cdot>\<^sub>D
	+ (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C)))"
	+ proof -
	+ have "src\<^sub>C f = trg\<^sub>C w\<^sub>C \<and> C.hseq r \<theta>\<^sub>C \<and> C.hseq \<rho> w\<^sub>C"
	+ using par by auto
	+ thus ?thesis
	+ using w\<^sub>C \<theta>\<^sub>C preserves_assoc preserves_hcomp
	+ by (metis C.ideD(2) C.ideD(3) C.in_homE T.ide_base T.ide_leg0 T.leg0_simps(3)
	+ T.tab_simps(4) T.tab_simps(5))
	+ qed
	+ also have
	+ "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C) \<cdot>\<^sub>D (((D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C))) \<cdot>\<^sub>D
	+ (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C))) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D ((D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C))) \<cdot>\<^sub>D
	+ (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C)) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C)) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using D.comp_assoc by simp
	+ also have
	+ "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D ((F r \<star>\<^sub>D F \<theta>\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w\<^sub>C] \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have
	+ "(D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (r \<star>\<^sub>C f, w\<^sub>C)) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C) = F \<rho> \<star>\<^sub>D F w\<^sub>C"
	+ using w\<^sub>C \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> D.comp_inv_arr' \<Phi>_in_hom \<Phi>_components_are_iso
	+ D.comp_cod_arr D.hseqI'
	+ by simp
	+ moreover have
	+ "((D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C))) \<cdot>\<^sub>D (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C))) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C)) =
	+ F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C)"
	+ using w\<^sub>C \<Phi>_in_hom \<Phi>_components_are_iso D.comp_cod_arr
	+ D.comp_inv_arr' D.hseqI' \<Phi>_simps(1) \<Phi>_simps(4) by auto
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C] \<cdot>\<^sub>D
	+ (?\<rho>' \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "(F r \<star>\<^sub>D F \<theta>\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C)) = F r \<star>\<^sub>D F \<theta>\<^sub>C \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C)"
	+ using \<theta>\<^sub>C w\<^sub>C D.whisker_left \<Phi>_in_hom
	+ by (metis C.hseqE C.seqE D.seqI' T'.ide_base T.tab_simps(2) T.ide_leg0
	+ par preserves_hom)
	+ moreover have "(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C) = ?\<rho>' \<star>\<^sub>D F w\<^sub>C"
	+ using D.whisker_right by (simp add: w\<^sub>C)
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C] \<cdot>\<^sub>D
	+ (?\<rho>' \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using \<theta>\<^sub>C F\<theta>\<^sub>C_def D.comp_assoc by simp
	+ also have
	+ "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C]) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C) =
	+ F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)"
	+ using \<Phi>_in_hom \<Phi>_components_are_iso D.comp_arr_dom
	+ by (metis C.arrI D.cod_inv D.comp_inv_arr' D.seqE F\<theta>\<^sub>C_def T.tab_simps(2)
	+ T.ide_leg0 \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> \<theta>\<^sub>C preserves_arr w\<^sub>C)
	+ also have "... = (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>)"
	+ using D.whisker_left
	+ by (metis (no_types, lifting) C.in_homE D.comp_assoc D.seqE F\<theta>\<^sub>C_def T'.ide_base
	+ \<theta>\<^sub>C preserves_arr)
	+ finally have "F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C) =
	+ (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>)"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e] \<cdot>\<^sub>D (((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "(F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C] =
	+ \<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>)"
	+ using w\<^sub>C \<phi> \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> D.assoc_naturality [of "F r" "F f" \<phi>]
	+ by (metis (mono_tags, lifting) C.ideD(1) D.in_homE D.vconn_implies_hpar(2)
	+ T'.base_simps(2-4) T'.leg0_simps(2-5) T.leg0_simps(2)
	+ T.tab_simps(2) preserves_src preserves_trg)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e]) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D w \<star>\<^sub>D e) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C) = ?\<rho>' \<star>\<^sub>D \<phi> \<cdot>\<^sub>D F w\<^sub>C"
	+ using \<phi> D.interchange
	+ by (metis D.comp_arr_dom D.comp_cod_arr D.in_homE T'.tab_simps(1,5))
	+ also have "... = ?\<rho>' \<star>\<^sub>D (w \<star>\<^sub>D e) \<cdot>\<^sub>D \<phi>"
	+ using \<phi> w\<^sub>C D.comp_arr_dom D.comp_cod_arr by auto
	+ also have "... = (?\<rho>' \<star>\<^sub>D w \<star>\<^sub>D e) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>)"
	+ using \<phi> D.interchange
	+ by (metis D.comp_arr_dom D.hcomp_simps(3) D.ide_char D.in_hhomE D.in_homE
	+ D.seqI T'.tab_in_hom(2) T.tab_simps(2) T.leg0_simps(2) e.ide_left
	+ preserves_src w we)
	+ finally have
	+ "((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C) = (?\<rho>' \<star>\<^sub>D w \<star>\<^sub>D e) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>)"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e]) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w, e] \<cdot>\<^sub>D
	+ (?\<rho>' \<star>\<^sub>D w \<star>\<^sub>D e)) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "D.inv (F r \<star>\<^sub>D \<a>\<^sub>D[F f, w, e]) = F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
	+ using w by simp
	+ moreover have "D.seq (F r \<star>\<^sub>D \<a>\<^sub>D[F f, w, e])
	+ (\<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e))"
	+ using w D.hseqI'
	+ by (intro D.seqI D.hseqI, auto)
	+ moreover have
	+ "(F r \<star>\<^sub>D \<a>\<^sub>D[F f, w, e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e) =
	+ \<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e] \<cdot>\<^sub>D \<a>\<^sub>D[F r \<star>\<^sub>D F f, w, e]"
	+ using w D.pentagon by simp
	+ ultimately
	+ have "(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e] =
	+ \<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w, e]"
	+ using w D.comp_assoc
	+ D.invert_opposite_sides_of_square
	+ [of "F r \<star>\<^sub>D \<a>\<^sub>D[F f, w, e]" "\<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e)"
	+ "\<a>\<^sub>D[F r, F f, w \<star>\<^sub>D e]" "\<a>\<^sub>D[F r \<star>\<^sub>D F f, w, e]"]
	+ by auto
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D (((F r \<star>\<^sub>D \<theta>) \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e) \<cdot>\<^sub>D ((?\<rho>' \<star>\<^sub>D w) \<star>\<^sub>D e)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have
	+ "(F r \<star>\<^sub>D \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D w, e] = \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta>) \<star>\<^sub>D e)"
	+ using D.assoc_naturality [of "F r" \<theta> e] \<theta> by auto
	+ moreover have "\<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w, e] \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D w \<star>\<^sub>D e) =
	+ ((?\<rho>' \<star>\<^sub>D w) \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]"
	+ using w we e.ide_left D.assoc'_naturality [of ?\<rho>' w e] by simp
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D
	+ (T'.composite_cell w \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "((F r \<star>\<^sub>D \<theta>) \<star>\<^sub>D e) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w] \<star>\<^sub>D e) \<cdot>\<^sub>D ((?\<rho>' \<star>\<^sub>D w) \<star>\<^sub>D e) =
	+ T'.composite_cell w \<theta> \<star>\<^sub>D e"
	+ proof -
	+ have "\<guillemotleft>T'.composite_cell w \<theta> : F g \<star>\<^sub>D w \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u\<guillemotright>"
	+ using w we \<theta> \<open>src\<^sub>D \<theta> = a\<close> \<open>trg\<^sub>D e = a\<close> T'.composite_cell_in_hom
	+ by (metis D.ideD(1) D.ide_in_hom(1) D.not_arr_null D.seq_if_composable
	+ T'.leg1_simps(3) T.leg1_simps(2-3) T.tab_simps(2)
	+ \<open>trg\<^sub>D w = map\<^sub>0 (src\<^sub>C \<rho>)\<close> a_def preserves_src ue)
	+ thus ?thesis
	+ using D.whisker_right D.arrI by auto
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ finally have L: "F (T.composite_cell w\<^sub>C \<theta>\<^sub>C) =
	+ \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D
	+ (T'.composite_cell w \<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ by simp
	+
	+ have "F (T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C) =
	+ F ((r \<star>\<^sub>C \<theta>\<^sub>C') \<cdot>\<^sub>C \<a>\<^sub>C[r, f, w\<^sub>C'] \<cdot>\<^sub>C (\<rho> \<star>\<^sub>C w\<^sub>C') \<cdot>\<^sub>C \<beta>\<^sub>C)"
	+ using C.comp_assoc by simp
	+ also have "... = F(r \<star>\<^sub>C \<theta>\<^sub>C') \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w\<^sub>C'] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w\<^sub>C') \<cdot>\<^sub>D F \<beta>\<^sub>C"
	+ using C.comp_assoc par by fastforce
	+ also have "... = (\<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C') \<cdot>\<^sub>D D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C'))) \<cdot>\<^sub>D
	+ (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C'] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C'))) \<cdot>\<^sub>D
	+ (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C'))) \<cdot>\<^sub>D
	+ \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "C.hseq r \<theta>\<^sub>C' \<and> C.hseq \<rho> w\<^sub>C'"
	+ using par by blast
	+ thus ?thesis
	+ using w\<^sub>C' \<theta>\<^sub>C' \<beta>\<^sub>C F\<beta>\<^sub>C_def preserves_assoc [of r f w\<^sub>C'] preserves_hcomp C.hseqI'
	+ by force
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C') \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C'))) \<cdot>\<^sub>D
	+ (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C'] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D ((D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) \<cdot>\<^sub>D
	+ \<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C')) \<cdot>\<^sub>D ((D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D
	+ \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using D.comp_assoc by simp
	+ also have
	+ "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w\<^sub>C'] \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "(D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C'))) \<cdot>\<^sub>D (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) =
	+ F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')"
	+ proof -
	+ have "D.seq (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C')) (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) \<and>
	+ D.arr (D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C'))) \<and>
	+ D.dom (D.inv (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C'))) =
	+ D.cod (\<Phi> (r, f \<star>\<^sub>C w\<^sub>C') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')))"
	+ by (metis D.seqE calculation par preserves_arr)
	+ thus ?thesis
	+ using C.ide_hcomp C.ideD(1) C.trg_hcomp' D.invert_side_of_triangle(1)
	+ T.ide_base T.ide_leg0 T.leg0_simps(3) T.tab_simps(2) \<Phi>_components_are_iso
	+ \<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close> w\<^sub>C'
	+ by presburger
	+ qed
	+ moreover have
	+ "(D.inv (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w\<^sub>C') =
	+ F \<rho> \<star>\<^sub>D F w\<^sub>C'"
	+ proof -
	+ have "D.seq (F \<rho> \<star>\<^sub>D F w\<^sub>C') (D.inv (\<Phi> (C.dom \<rho>, C.dom w\<^sub>C'))) \<and>
	+ D.arr (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) \<and>
	+ D.dom (\<Phi> (r \<star>\<^sub>C f, w\<^sub>C')) =
	+ D.cod ((F \<rho> \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D D.inv (\<Phi> (C.dom \<rho>, C.dom w\<^sub>C')))"
	+ by (metis C.hseqI' C.ide_char D.seqE T.tab_simps(1) T.tab_simps(5)
	+ \<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close> preserves_arr preserves_hcomp w\<^sub>C')
	+ thus ?thesis
	+ by (metis (no_types) C.ide_hcomp C.ide_char C.hcomp_simps(1)
	+ D.cod_comp D.comp_inv_arr' D.seqE T.ide_base T.ide_leg0 T.leg0_simps(3)
	+ T.tab_simps(2) \<Phi>_components_are_iso D.comp_cod_arr
	+ \<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close> w\<^sub>C')
	+ qed
	+ moreover have "(D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') =
	+ F g \<star>\<^sub>D D.inv \<phi>'"
	+ proof -
	+ have "(D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') =
	+ (F g \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')"
	+ using w\<^sub>C' \<beta>\<^sub>C F\<beta>\<^sub>C_def \<Phi>_components_are_iso D.comp_inv_arr' by simp
	+ also have "... = F g \<star>\<^sub>D D.inv \<phi>'"
	+ using D.comp_cod_arr [of "F g \<star>\<^sub>D D.inv \<phi>'" "F g \<star>\<^sub>D F w\<^sub>C'"]
	+ by (metis D.hcomp_simps(4) D.cod_inv D.comp_null(2) D.hseq_char' D.in_homE
	+ T'.leg1_simps(6) \<phi>')
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>\<^sub>C') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w\<^sub>C'] \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using w\<^sub>C' D.whisker_right \<Phi>_in_hom \<Phi>_components_are_iso by simp
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w\<^sub>C'] \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using \<theta>\<^sub>C' F\<theta>\<^sub>C'_def by simp
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D (F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
	+ (((F r \<star>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w\<^sub>C']) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "F r \<star>\<^sub>D \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f, w\<^sub>C')) =
	+ (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F r \<star>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C')))"
	+ using D.whisker_left \<Phi>_in_hom \<Phi>_components_are_iso
	+ by (metis C.arrI D.src.preserves_reflects_arr D.src_vcomp D.vseq_implies_hpar(1)
	+ F\<theta>\<^sub>C'_def T'.ide_base \<theta>\<^sub>C' preserves_arr)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D ((F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w\<^sub>C']) \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "((F r \<star>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w\<^sub>C'))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w\<^sub>C'] =
	+ \<a>\<^sub>D[F r, F f, F w\<^sub>C']"
	+ using \<Phi>_in_hom \<Phi>_components_are_iso D.comp_cod_arr
	+ D.whisker_left [of "F r" "D.inv (\<Phi> (f, w\<^sub>C'))" "\<Phi> (f, w\<^sub>C')"]
	+ by (simp add: D.comp_inv_arr' w\<^sub>C')
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e] \<cdot>\<^sub>D
	+ (((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "(F r \<star>\<^sub>D F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w\<^sub>C'] =
	+ \<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>')"
	+ using w\<^sub>C' \<phi>' D.assoc_naturality [of "F r" "F f" \<phi>']
	+ by (metis C.ideD(1) D.dom_trg D.in_homE D.trg.preserves_dom
	+ T'.leg0_simps(2-5) T'.base_simps(2-4) T.tab_simps(2) T.leg0_simps(2)
	+ \<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close> preserves_src preserves_trg)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e] \<cdot>\<^sub>D
	+ (?\<rho>' \<star>\<^sub>D w' \<star>\<^sub>D e) \<cdot>\<^sub>D (((F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, w', e]) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "((F r \<star>\<^sub>D F f) \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D F w\<^sub>C') = (?\<rho>' \<star>\<^sub>D w' \<star>\<^sub>D e) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>')"
	+ using \<phi>' D.interchange D.comp_arr_dom D.comp_cod_arr
	+ by (metis D.in_homE T'.tab_in_hom(2))
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ ((F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e]) \<cdot>\<^sub>D
	+ (?\<rho>' \<star>\<^sub>D w' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "((F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] = \<a>\<^sub>D[F g, w', e]"
	+ proof -
	+ have "((F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] =
	+ (F g \<star>\<^sub>D w' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e]"
	+ by (metis D.arr_inv D.cod_inv D.comp_arr_inv' D.in_homE D.seqI
	+ D.whisker_left T'.ide_leg1 \<phi>')
	+ also have "... = \<a>\<^sub>D[F g, w', e]"
	+ using w' D.comp_cod_arr by simp
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e]) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w', e] \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D w' \<star>\<^sub>D e)) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D
	+ (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "D.inv (F r \<star>\<^sub>D \<a>\<^sub>D[F f, w', e]) = F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]"
	+ using w' by simp
	+ moreover have "D.seq (F r \<star>\<^sub>D \<a>\<^sub>D[F f, w', e])
	+ (\<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e))"
	+ using w' D.hseqI'
	+ by (intro D.seqI D.hseqI, auto)
	+ moreover have "D.iso (F r \<star>\<^sub>D \<a>\<^sub>D[F f, w', e])"
	+ using w' by simp
	+ moreover have "D.iso \<a>\<^sub>D[F r \<star>\<^sub>D F f, w', e]"
	+ using w' by simp
	+ moreover have "(F r \<star>\<^sub>D \<a>\<^sub>D[F f, w', e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e) =
	+ \<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e] \<cdot>\<^sub>D \<a>\<^sub>D[F r \<star>\<^sub>D F f, w', e]"
	+ using w' D.pentagon by simp
	+ ultimately
	+ have "(F r \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e] =
	+ \<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w', e]"
	+ using w' D.comp_assoc
	+ D.invert_opposite_sides_of_square
	+ [of "F r \<star>\<^sub>D \<a>\<^sub>D[F f, w', e]" "\<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e] \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e)"
	+ "\<a>\<^sub>D[F r, F f, w' \<star>\<^sub>D e]" "\<a>\<^sub>D[F r \<star>\<^sub>D F f, w', e]"]
	+ by auto
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D (((F r \<star>\<^sub>D \<theta>') \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e) \<cdot>\<^sub>D ((?\<rho>' \<star>\<^sub>D w') \<star>\<^sub>D e)) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w', e] \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e]) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "(F r \<star>\<^sub>D \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f \<star>\<^sub>D w', e] =
	+ \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta>') \<star>\<^sub>D e)"
	+ using D.assoc_naturality [of "F r" \<theta>' e] \<theta>' by auto
	+ moreover have "\<a>\<^sub>D\<^sup>-\<^sup>1[F r \<star>\<^sub>D F f, w', e] \<cdot>\<^sub>D (?\<rho>' \<star>\<^sub>D w' \<star>\<^sub>D e) =
	+ ((?\<rho>' \<star>\<^sub>D w') \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w', e]"
	+ using w' w'e D.assoc'_naturality [of ?\<rho>' w' e] D.hseqI' by simp
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D
	+ (T'.composite_cell w' \<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "((F r \<star>\<^sub>D \<theta>') \<star>\<^sub>D e) \<cdot>\<^sub>D (\<a>\<^sub>D[F r, F f, w'] \<star>\<^sub>D e) \<cdot>\<^sub>D ((?\<rho>' \<star>\<^sub>D w') \<star>\<^sub>D e) =
	+ T'.composite_cell w' \<theta>' \<star>\<^sub>D e"
	+ proof -
	+ have "\<guillemotleft>T'.composite_cell w' \<theta>' : F g \<star>\<^sub>D w' \<Rightarrow>\<^sub>D F r \<star>\<^sub>D u\<guillemotright>"
	+ using \<theta>' w' T'.composite_cell_in_hom D.vconn_implies_hpar(3) by simp
	+ thus ?thesis
	+ using D.whisker_right D.arrI by auto
	+ qed
	+ moreover have "(\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w', e] \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e]) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) = \<beta> \<star>\<^sub>D e"
	+ using w' \<beta> e.ide_left \<open>src\<^sub>D w' = a\<close> \<open>trg\<^sub>D e = a\<close> F\<beta>\<^sub>C F\<beta>\<^sub>C_def D.comp_cod_arr
	+ D.comp_arr_inv'
	+ by (metis (no_types, lifting) D.hcomp_simps(4) D.comp_assoc_assoc'(2) D.ide_char
	+ D.in_homE D.seqE T'.ide_leg1 T'.leg1_simps(3) T.leg0_simps(2) T.tab_simps(2)
	+ \<open>trg\<^sub>D w' = map\<^sub>0 (src\<^sub>C \<rho>)\<close> preserves_src)
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D
	+ (T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ proof -
	+ have "D.arr (T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<beta>)"
	+ by (metis (full_types) D.hseq_char D.seqE L eq par preserves_arr)
	+ thus ?thesis
	+ using D.whisker_right by (metis D.comp_assoc e.ide_left)
	+ qed
	+ finally have R: "F (T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C) =
	+ \<Phi> (r, u\<^sub>C) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<psi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, u, e] \<cdot>\<^sub>D
	+ (T'.composite_cell w' \<theta>' \<cdot>\<^sub>D \<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ by simp
	+
	+ show "F (T.composite_cell w\<^sub>C \<theta>\<^sub>C) = F (T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C)"
	+ using eq L R by simp
	+ qed
	+ ultimately show ?thesis
	+ using is_faithful [of "T.composite_cell w\<^sub>C \<theta>\<^sub>C" "T.composite_cell w\<^sub>C' \<theta>\<^sub>C' \<cdot>\<^sub>C \<beta>\<^sub>C"]
	+ by simp
	+ qed
	+ have **: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w\<^sub>C \<Rightarrow>\<^sub>C w\<^sub>C'\<guillemotright> \<and> \<beta>\<^sub>C = g \<star>\<^sub>C \<gamma> \<and> \<theta>\<^sub>C = \<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
	+ using * w\<^sub>C w\<^sub>C' \<theta>\<^sub>C \<theta>\<^sub>C' \<beta>\<^sub>C T.T2 [of w\<^sub>C w\<^sub>C' \<theta>\<^sub>C u\<^sub>C \<theta>\<^sub>C' \<beta>\<^sub>C] by simp
	+ obtain \<gamma>\<^sub>C where
	+ \<gamma>\<^sub>C: "\<guillemotleft>\<gamma>\<^sub>C : w\<^sub>C \<Rightarrow>\<^sub>C w\<^sub>C'\<guillemotright> \<and> \<beta>\<^sub>C = g \<star>\<^sub>C \<gamma>\<^sub>C \<and> \<theta>\<^sub>C = \<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C)"
	+ using ** by auto
	+ have \<gamma>\<^sub>C_unique: "\<And>\<gamma>\<^sub>C'. \<guillemotleft>\<gamma>\<^sub>C' : w\<^sub>C \<Rightarrow>\<^sub>C w\<^sub>C'\<guillemotright> \<and> \<beta>\<^sub>C = g \<star>\<^sub>C \<gamma>\<^sub>C' \<and>
	+ \<theta>\<^sub>C = \<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C') \<Longrightarrow> \<gamma>\<^sub>C' = \<gamma>\<^sub>C"
	+ using \<gamma>\<^sub>C ** by blast
	+
	+ text \<open>
	+ Now use \<open>F\<close> to map everything back to \<open>D\<close>, transport the result along the
	+ equivalence map \<open>e\<close>, and cancel all of the isomorphisms that got introduced.
	+ \<close>
	+
	+ let ?P = "\<lambda>\<gamma>. \<guillemotleft>\<gamma> : w \<star>\<^sub>D e \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright> \<and>
	+ \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] = F g \<star>\<^sub>D \<gamma> \<and>
	+ \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] =
	+ \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>)"
	+ define \<gamma>e where "\<gamma>e = \<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>"
	+ have P\<gamma>e: "?P \<gamma>e"
	+ proof -
	+ have 1: "\<guillemotleft>F \<gamma>\<^sub>C : F w\<^sub>C \<Rightarrow>\<^sub>D F w\<^sub>C'\<guillemotright> \<and>
	+ F \<beta>\<^sub>C = \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C)) \<and>
	+ F \<theta>\<^sub>C = F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, C.cod \<gamma>\<^sub>C) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
	+ using \<beta>\<^sub>C \<theta>\<^sub>C \<gamma>\<^sub>C preserves_hcomp [of f \<gamma>\<^sub>C] preserves_hcomp [of g \<gamma>\<^sub>C] by force
	+ have A: "\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] =
	+ F g \<star>\<^sub>D \<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>"
	+ proof -
	+ have "F g \<star>\<^sub>D F \<gamma>\<^sub>C = D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D F \<beta>\<^sub>C \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C)"
	+ proof -
	+ have "F \<beta>\<^sub>C = \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using 1 by simp
	+ hence "D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D F \<beta>\<^sub>C = (F g \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using w\<^sub>C w\<^sub>C' \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> \<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close> \<Phi>_components_are_iso
	+ D.invert_side_of_triangle(1)
	+ by (metis D.arrI F\<beta>\<^sub>C T.ide_leg1 T.leg1_simps(3) T.tab_simps(2) \<beta>\<^sub>C)
	+ hence "(D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D F \<beta>\<^sub>C) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C) = F g \<star>\<^sub>D F \<gamma>\<^sub>C"
	+ using \<Phi>_components_are_iso D.invert_side_of_triangle(2)
	+ by (metis "1" D.arrI D.inv_inv D.iso_inv_iso D.seqE F\<beta>\<^sub>C T.ide_leg1
	+ T.leg1_simps(3) T.tab_simps(2) \<beta>\<^sub>C \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> w\<^sub>C)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = ((D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C)"
	+ using \<beta>\<^sub>C F\<beta>\<^sub>C_def D.comp_assoc by simp
	+ also have "... = (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>)"
	+ proof -
	+ have "(D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') = F g \<star>\<^sub>D D.inv \<phi>'"
	+ proof -
	+ have "(D.inv (\<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') =
	+ (F g \<star>\<^sub>D F w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>')"
	+ using w\<^sub>C' \<phi>' \<Phi>_components_are_iso D.comp_inv_arr' by simp
	+ also have "... = F g \<star>\<^sub>D D.inv \<phi>'"
	+ using w\<^sub>C' \<phi>' D.comp_cod_arr
	+ by (metis D.arr_inv D.cod_inv D.in_homE D.whisker_left T'.ide_leg1)
	+ finally show ?thesis by blast
	+ qed
	+ moreover have "(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C) = F g \<star>\<^sub>D \<phi>"
	+ proof -
	+ have "(F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C)) \<cdot>\<^sub>D \<Phi> (g, w\<^sub>C) =
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D (F g \<star>\<^sub>D F w\<^sub>C)"
	+ using w\<^sub>C \<phi> \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> \<Phi>_components_are_iso \<Phi>_in_hom
	+ D.comp_inv_arr'
	+ by simp
	+ also have "... = F g \<star>\<^sub>D \<phi>"
	+ using w\<^sub>C \<phi> D.comp_arr_dom
	+ by (metis D.hcomp_simps(3) D.hseqI' D.in_hhom_def D.in_homE
	+ D.vconn_implies_hpar(2) D.vconn_implies_hpar(4) T'.leg1_simps(2,5)
	+ T.leg1_simps(2-3) T.tab_simps(2) preserves_src we)
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis by simp
	+ qed
	+ finally have 2: "(F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D (\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) =
	+ F g \<star>\<^sub>D F \<gamma>\<^sub>C"
	+ using D.comp_assoc by simp
	+ have 3: "(\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) =
	+ (F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>C)"
	+ proof -
	+ have "D.hseq (F g) (F \<gamma>\<^sub>C)"
	+ using "1" F\<beta>\<^sub>C \<beta>\<^sub>C by auto
	+ moreover have "D.iso (F g \<star>\<^sub>D D.inv \<phi>')"
	+ by (metis "2" D.iso_hcomp D.hseqE D.ide_is_iso D.iso_inv_iso D.seqE
	+ T'.ide_leg1 \<phi>' calculation)
	+ moreover have "D.inv (F g \<star>\<^sub>D D.inv \<phi>') = F g \<star>\<^sub>D \<phi>'"
	+ by (metis D.hseqE D.ide_is_iso D.inv_hcomp D.inv_ide D.inv_inv D.iso_inv_iso
	+ D.iso_is_arr T'.ide_leg1 \<phi>' calculation(2))
	+ ultimately show ?thesis
	+ using 2 \<phi> \<phi>' D.hseqI'
	+ D.invert_side_of_triangle(1)
	+ [of "F g \<star>\<^sub>D F \<gamma>\<^sub>C" "F g \<star>\<^sub>D D.inv \<phi>'"
	+ "(\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>)"]
	+ by auto
	+ qed
	+ hence "\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] =
	+ ((F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>C)) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>)"
	+ proof -
	+ have "D.seq (F g \<star>\<^sub>D \<phi>') (F g \<star>\<^sub>D F \<gamma>\<^sub>C)"
	+ by (metis "1" "2" "3" D.arrI D.comp_null(1) D.comp_null(2) D.ext F\<beta>\<^sub>C \<beta>\<^sub>C)
	+ moreover have "D.iso (F g \<star>\<^sub>D \<phi>)"
	+ using D.vconn_implies_hpar(2) D.vconn_implies_hpar(4) \<phi> we by auto
	+ moreover have "D.inv (F g \<star>\<^sub>D \<phi>) = F g \<star>\<^sub>D D.inv \<phi>"
	+ by (metis D.hseqE D.ide_is_iso D.inv_hcomp D.inv_ide D.iso_is_arr
	+ T'.ide_leg1 \<phi> calculation(2))
	+ ultimately show ?thesis
	+ using 3 \<phi> \<phi>'
	+ D.invert_side_of_triangle(2)
	+ [of "(F g \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>C)"
	+ "\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]" "F g \<star>\<^sub>D \<phi>"]
	+ by auto
	+ qed
	+ also have "... = F g \<star>\<^sub>D \<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>"
	+ using \<phi>' D.whisker_left
	+ by (metis "1" D.arr_inv D.cod_comp D.cod_inv D.comp_assoc D.in_homE D.seqI
	+ T'.ide_leg1 \<phi>)
	+ finally show ?thesis by simp
	+ qed
	+ have B: "\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] =
	+ \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>)"
	+ proof -
	+ have "F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C)) =
	+ (\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
	+ \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C)) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
	+ using \<gamma>\<^sub>C \<theta>\<^sub>C' F\<theta>\<^sub>C'_def D.comp_assoc by auto
	+ also have "... = \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
	+ proof -
	+ have "(D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) = F f \<star>\<^sub>D F \<gamma>\<^sub>C"
	+ using D.comp_cod_arr
	+ by (metis (mono_tags, lifting) C.in_homE D.cod_comp D.comp_inv_arr' D.seqE
	+ T.tab_simps(2) T.ide_leg0 \<Phi>_components_are_iso \<gamma>\<^sub>C 1 \<open>trg\<^sub>C w\<^sub>C' = src\<^sub>C \<rho>\<close>
	+ \<theta>\<^sub>C preserves_arr w\<^sub>C')
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ finally have "F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C)) =
	+ \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
	+ by simp
	+ hence 3: "F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) =
	+ \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C)"
	+ using \<Phi>_components_are_iso D.iso_inv_iso D.iso_is_retraction D.retraction_is_epi
	+ D.epiE
	+ by (metis C.in_homE D.comp_assoc T.tab_simps(2) T.ide_leg0 \<gamma>\<^sub>C 1
	+ \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> \<theta>\<^sub>C preserves_arr w\<^sub>C)
	+ hence "(\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C)) =
	+ (\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D F \<gamma>\<^sub>C)) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
	+ using 1 \<theta>\<^sub>C F\<theta>\<^sub>C_def D.comp_assoc by (metis C.in_homE \<gamma>\<^sub>C)
	+ hence 2: "(\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) =
	+ \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C)"
	+ using \<gamma>\<^sub>C \<Phi>_components_are_iso D.iso_inv_iso D.iso_is_retraction D.retraction_is_epi
	+ D.epiE
	+ by (metis (mono_tags, lifting) 1 3 C.in_homE D.comp_assoc T.tab_simps(2)
	+ T.ide_leg0 \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close> \<theta>\<^sub>C preserves_arr w\<^sub>C)
	+ hence "\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] =
	+ (\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>)"
	+ proof -
	+ have "D.inv (F f \<star>\<^sub>D \<phi>) = F f \<star>\<^sub>D D.inv \<phi>"
	+ using \<phi>
	+ by (metis C.arrI D.hseq_char D.ide_is_iso D.inv_hcomp D.inv_ide D.seqE F\<theta>\<^sub>C_def
	+ T'.ide_leg0 preserves_arr \<theta>\<^sub>C)
	+ thus ?thesis
	+ using \<phi> \<phi>' \<theta> \<theta>' \<gamma>\<^sub>C D.invert_side_of_triangle(2)
	+ by (metis 2 C.arrI D.comp_assoc D.iso_hcomp D.hseqE D.ide_is_iso D.seqE
	+ F\<theta>\<^sub>C_def T'.ide_leg0 \<theta>\<^sub>C preserves_arr)
	+ qed
	+ also have "... = \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>C) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>)"
	+ using D.comp_assoc by simp
	+ also have
	+ "... = \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>)"
	+ proof -
	+ have "D.arr (\<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi>)"
	+ using "1" \<phi> \<phi>' by blast
	+ thus ?thesis
	+ using D.whisker_left by auto
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ have C: "\<guillemotleft>\<phi>' \<cdot>\<^sub>D F \<gamma>\<^sub>C \<cdot>\<^sub>D D.inv \<phi> : w \<star>\<^sub>D e \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>"
	+ using \<phi> \<phi>' \<gamma>\<^sub>C 1 by (meson D.comp_in_homI D.inv_in_hom)
	+ show ?thesis
	+ unfolding \<gamma>e_def
	+ using A B C by simp
	+ qed
	+ have UN: "\<And>\<gamma>. ?P \<gamma> \<Longrightarrow> \<gamma> = \<gamma>e"
	+ proof -
	+ fix \<gamma>
	+ assume \<gamma>: "?P \<gamma>"
	+ show "\<gamma> = \<gamma>e"
	+ proof -
	+ let ?\<gamma>' = "D.inv \<phi>' \<cdot>\<^sub>D \<gamma> \<cdot>\<^sub>D \<phi>"
	+ have \<gamma>': "\<guillemotleft>?\<gamma>' : F w\<^sub>C \<Rightarrow>\<^sub>D F w\<^sub>C'\<guillemotright>"
	+ using \<gamma> \<phi> \<phi>' by auto
	+ obtain \<gamma>\<^sub>C' where \<gamma>\<^sub>C': "\<guillemotleft>\<gamma>\<^sub>C' : w\<^sub>C \<Rightarrow>\<^sub>C w\<^sub>C'\<guillemotright> \<and> F \<gamma>\<^sub>C' = ?\<gamma>'"
	+ using w\<^sub>C w\<^sub>C' \<gamma> \<gamma>' locally_full by fastforce
	+ have 1: "\<beta>\<^sub>C = g \<star>\<^sub>C \<gamma>\<^sub>C'"
	+ proof -
	+ have "F \<beta>\<^sub>C = F (g \<star>\<^sub>C \<gamma>\<^sub>C')"
	+ proof -
	+ have "F \<beta>\<^sub>C =
	+ \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using \<beta>\<^sub>C F\<beta>\<^sub>C_def by simp
	+ have "F (g \<star>\<^sub>C \<gamma>\<^sub>C') =
	+ \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>' \<cdot>\<^sub>D \<gamma> \<cdot>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using \<gamma>\<^sub>C' preserves_hcomp
	+ by (metis C.hseqI' C.in_homE C.trg_dom T.tab_simps(2) T.leg1_simps(2)
	+ T.leg1_simps(3,5-6) \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close>)
	+ also have "... = \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using \<phi> \<phi>' D.whisker_left D.comp_assoc
	+ by (metis D.arrI D.seqE F\<beta>\<^sub>C_def T'.ide_leg1 \<gamma> \<gamma>')
	+ also have "... = \<Phi> (g, w\<^sub>C') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (g, w\<^sub>C))"
	+ using \<gamma> D.comp_assoc by simp
	+ also have "... = F \<beta>\<^sub>C"
	+ using \<beta>\<^sub>C F\<beta>\<^sub>C_def D.comp_assoc by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis using is_faithful
	+ by (metis C.hcomp_simps(3-4) C.in_homE D.arrI D.not_arr_null
	+ F\<beta>\<^sub>C T.leg1_simps(5) T.leg1_simps(6) \<beta>\<^sub>C \<gamma>\<^sub>C' is_extensional)
	+ qed
	+ have 2: "\<theta>\<^sub>C = \<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C')"
	+ proof -
	+ have "F \<theta>\<^sub>C = F (\<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C'))"
	+ proof -
	+ have "F (\<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C')) = F \<theta>\<^sub>C' \<cdot>\<^sub>D F (f \<star>\<^sub>C \<gamma>\<^sub>C')"
	+ using \<theta>\<^sub>C' \<gamma>\<^sub>C' by force
	+ also have
	+ "... = F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>' \<cdot>\<^sub>D \<gamma> \<cdot>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
	+ using w\<^sub>C w\<^sub>C' \<theta>\<^sub>C' \<gamma>\<^sub>C' preserves_hcomp
	+ by (metis C.hseqI' C.in_homE C.trg_dom T.tab_simps(2) T.leg0_simps(2)
	+ T.leg0_simps(4-5) \<open>trg\<^sub>C w\<^sub>C = src\<^sub>C \<rho>\<close>)
	+ also have "... = F \<theta>\<^sub>C' \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') \<cdot>\<^sub>D
	+ ((F f \<star>\<^sub>D D.inv \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (f, w\<^sub>C))"
	+ using D.whisker_left
	+ by (metis D.arrI D.seqE T'.ide_leg0 \<gamma>')
	+ also have "... = \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (((F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<gamma>)) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
	+ using \<theta>\<^sub>C' F\<theta>\<^sub>C'_def D.comp_assoc by simp
	+ also have "... = (\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>)) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
	+ proof -
	+ have "D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C') = F f \<star>\<^sub>D F w\<^sub>C'"
	+ using w\<^sub>C' \<Phi>_in_hom \<Phi>_components_are_iso
	+ by (simp add: D.comp_inv_arr')
	+ moreover have "D.hseq (F f) (D.inv \<phi>')"
	+ using \<phi>' D.hseqI'
	+ by (metis D.ide_is_iso D.in_hhom_def D.iso_inv_iso D.iso_is_arr
	+ D.trg_inv D.vconn_implies_hpar(2) D.vconn_implies_hpar(4)
	+ T'.ide_leg0 T'.leg1_simps(3) T.leg1_simps(2-3)
	+ T.tab_simps(2) \<gamma> preserves_src we)
	+ ultimately have "(D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>') =
	+ F f \<star>\<^sub>D D.inv \<phi>'"
	+ using w\<^sub>C' \<phi>' D.comp_cod_arr [of "F f \<star>\<^sub>D D.inv \<phi>'" "F f \<star>\<^sub>D F w\<^sub>C'"]
	+ by auto
	+ hence "((F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>) =
	+ ((F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>)"
	+ by simp
	+ also have "... = F f \<star>\<^sub>D \<gamma>"
	+ using \<gamma> \<phi>' \<theta>\<^sub>C' F\<theta>\<^sub>C'_def D.comp_cod_arr D.whisker_left D.hseqI'
	+ by (metis D.comp_arr_inv' D.in_hhom_def D.in_homE T'.ide_leg0 w'e)
	+ finally have "((F f \<star>\<^sub>D \<phi>') \<cdot>\<^sub>D (D.inv (\<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D \<Phi> (f, w\<^sub>C')) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D D.inv \<phi>')) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>) =
	+ F f \<star>\<^sub>D \<gamma>"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w\<^sub>C))"
	+ using \<gamma> D.comp_assoc by metis
	+ also have "... = F \<theta>\<^sub>C"
	+ using \<theta>\<^sub>C F\<theta>\<^sub>C_def by simp
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis using is_faithful [of \<theta>\<^sub>C "\<theta>\<^sub>C' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>C')"]
	+ by (metis C.cod_comp C.dom_comp C.hcomp_simps(3) C.in_homE C.seqE
	+ D.not_arr_null T.leg0_simps(4) \<gamma>\<^sub>C' \<theta>\<^sub>C \<theta>\<^sub>C' is_extensional preserves_arr)
	+ qed
	+ have "F \<gamma>\<^sub>C' = F \<gamma>\<^sub>C"
	+ using ** \<gamma>\<^sub>C \<gamma>\<^sub>C' 1 2 by blast
	+ hence "?\<gamma>' = F \<gamma>\<^sub>C"
	+ using \<gamma>\<^sub>C' by simp
	+ thus "\<gamma> = \<gamma>e"
	+ unfolding \<gamma>e_def
	+ by (metis D.arrI D.comp_assoc D.inv_inv D.invert_side_of_triangle(1)
	+ D.invert_side_of_triangle(2) D.iso_inv_iso \<gamma>' \<phi> \<phi>')
	+ qed
	+ qed
	+
	+ text \<open>We are now in a position to exhibit the 2-cell \<open>\<gamma>\<close> and show that it
	+ is unique with the required properties.\<close>
	+
	+ show ?thesis
	+ proof
	+ let ?\<gamma> = "\<r>\<^sub>D[w'] \<cdot>\<^sub>D (w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[w', e, d] \<cdot>\<^sub>D (\<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D
	+ (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
	+ have \<gamma>: "\<guillemotleft>?\<gamma> : w \<Rightarrow>\<^sub>D w'\<guillemotright>"
	+ using P\<gamma>e w w' e.counit_in_hom(2) e.counit_is_iso
	+ apply (intro D.comp_in_homI, auto)
	+ apply (intro D.hcomp_in_vhom, auto simp add: D.vconn_implies_hpar(4))
	+ by (intro D.hcomp_in_vhom, auto)
	+ moreover have "\<beta> = F g \<star>\<^sub>D ?\<gamma>"
	+ proof -
	+ have "F g \<star>\<^sub>D ?\<gamma> =
	+ (F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ using w w' \<gamma> P\<gamma>e D.whisker_left e.antipar
	+ by (metis D.arrI D.seqE T'.ide_leg1)
	+ also have "... =
	+ (F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F g \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F g \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] =
	+ \<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
	+ using w w' e.antipar P\<gamma>e D.assoc'_naturality [of "F g" \<gamma>e d]
	+ by (metis D.dom_trg D.ideD(1-3) D.in_hhomE D.in_homE
	+ D.src_dom D.trg.preserves_dom T'.leg1_simps(2) T'.leg1_simps(3,5-6)
	+ T.tab_simps(2) T.leg0_simps(2) e e.ide_right preserves_src we)
	+ also have
	+ "... = (\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
	+ using D.comp_assoc by simp
	+ also have "... = F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
	+ proof -
	+ have "(\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) =
	+ (F g \<star>\<^sub>D (w' \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
	+ using D.isomorphic_implies_ide(2) w\<^sub>C' D.comp_assoc_assoc' by auto
	+ also have "... = F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
	+ proof -
	+ have "\<guillemotleft>F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d : F g \<star>\<^sub>D (w \<star>\<^sub>D e) \<star>\<^sub>D d \<Rightarrow>\<^sub>D F g \<star>\<^sub>D (w' \<star>\<^sub>D e) \<star>\<^sub>D d\<guillemotright>"
	+ using we e.ide_right e.antipar P\<gamma>e D.hseqI'
	+ by (intro D.hcomp_in_vhom, auto)
	+ thus ?thesis
	+ using D.comp_cod_arr by auto
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ finally have
	+ "\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F g \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] =
	+ F g \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
	+ by simp
	+ thus ?thesis by simp
	+ qed
	+ also have "... =
	+ (F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ using P\<gamma>e by simp
	+ also have
	+ "... =
	+ (F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (\<a>\<^sub>D[F g, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ ((\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d =
	+ (\<a>\<^sub>D[F g, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D ((\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d)"
	+ proof -
	+ have "D.arr (\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e])"
	+ using D.arrI D.in_hhom_def D.vconn_implies_hpar(2) P\<gamma>e we by auto
	+ thus ?thesis
	+ using D.whisker_right by auto
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... =
	+ (F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D
	+ ((F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (\<a>\<^sub>D[F g, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d]) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D[F g \<star>\<^sub>D w, e, d]) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d])) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d =
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D[F g \<star>\<^sub>D w, e, d]"
	+ proof -
	+ have "src\<^sub>D \<beta> = trg\<^sub>D e"
	+ using \<beta>
	+ by (metis D.dom_trg D.hseq_char' D.in_homE D.src_dom D.src_hcomp'
	+ D.trg.is_extensional D.trg.preserves_arr D.trg.preserves_dom
	+ \<open>trg\<^sub>D e = a\<close> a_def)
	+ moreover have "src\<^sub>D (F g) = trg\<^sub>D w"
	+ by simp
	+ moreover have "src\<^sub>D (F g) = trg\<^sub>D w'"
	+ by simp
	+ moreover have
	+ "\<guillemotleft>(\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d : ((F g \<star>\<^sub>D w) \<star>\<^sub>D e) \<star>\<^sub>D d \<Rightarrow>\<^sub>D ((F g \<star>\<^sub>D w') \<star>\<^sub>D e) \<star>\<^sub>D d\<guillemotright>"
	+ using \<beta> w w' e e.antipar
	+ by (intro D.hcomp_in_vhom, auto)
	+ ultimately have
	+ "\<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D[F g \<star>\<^sub>D w, e, d] =
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D \<a>\<^sub>D[F g \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D ((\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d)"
	+ using w' e e.ide_left e.ide_right e.antipar \<beta> D.assoc'_naturality
	+ by (metis D.assoc_naturality D.in_homE e.triangle_equiv_form(1)
	+ e.triangle_in_hom(3) e.triangle_in_hom(4) e.triangle_right
	+ e.triangle_right' e.triangle_right_implies_left)
	+ also have
	+ "... = (\<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D \<a>\<^sub>D[F g \<star>\<^sub>D w', e, d]) \<cdot>\<^sub>D ((\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d)"
	+ using D.comp_assoc by simp
	+ also have "... = (((F g \<star>\<^sub>D w') \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D ((\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d)"
	+ using w' e e.antipar \<beta> D.comp_assoc_assoc' by simp
	+ also have "... = (\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d"
	+ proof -
	+ have "\<guillemotleft>(\<beta> \<star>\<^sub>D e) \<star>\<^sub>D d : ((F g \<star>\<^sub>D w) \<star>\<^sub>D e) \<star>\<^sub>D d \<Rightarrow>\<^sub>D ((F g \<star>\<^sub>D w') \<star>\<^sub>D e) \<star>\<^sub>D d\<guillemotright>"
	+ using w e e.antipar \<beta>
	+ by (intro D.hcomp_in_vhom, auto)
	+ thus ?thesis
	+ using D.comp_cod_arr by auto
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = (F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e \<star>\<^sub>D d]) \<cdot>\<^sub>D
	+ (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e \<star>\<^sub>D d] \<cdot>\<^sub>D (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (\<a>\<^sub>D[F g, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w', e, d] =
	+ \<a>\<^sub>D[F g, w', e \<star>\<^sub>D d]"
	+ proof -
	+ have "D.seq (F g \<star>\<^sub>D \<a>\<^sub>D[w', e, d])
	+ (\<a>\<^sub>D[F g, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (\<a>\<^sub>D[F g, w', e] \<star>\<^sub>D d))"
	+ using w w' e e.antipar D.hseqI'
	+ by (intro D.seqI D.hseqI, auto)
	+ thus ?thesis
	+ using w w' e e.antipar D.pentagon [of "F g" w' e d] D.invert_side_of_triangle(2)
	+ D.assoc'_eq_inv_assoc D.comp_assoc D.ide_hcomp D.ideD(1)
	+ D.iso_assoc D.hcomp_simps(1) T'.ide_leg1 T.leg1_simps(2-3)
	+ T.tab_simps(2) \<open>src\<^sub>D w' = a\<close> \<open>trg\<^sub>D e = a\<close> \<open>trg\<^sub>D w' = map\<^sub>0 (src\<^sub>C \<rho>)\<close>
	+ e.ide_left e.ide_right preserves_src
	+ by metis
	+ qed
	+ moreover have
	+ "\<a>\<^sub>D[F g \<star>\<^sub>D w, e, d] \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) =
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e \<star>\<^sub>D d]"
	+ proof -
	+ have "D.seq (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] \<star>\<^sub>D d)
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]))"
	+ using w w' e e.antipar D.hseqI'
	+ by (intro D.seqI D.hseqI, auto)
	+ moreover have "D.inv \<a>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w, e, d] = \<a>\<^sub>D[F g \<star>\<^sub>D w, e, d]"
	+ using w w' e e.antipar D.iso_inv_iso D.inv_inv by simp
	+ ultimately show ?thesis
	+ using w w' e e.antipar D.pentagon' [of "F g" w e d]
	+ D.iso_inv_iso D.inv_inv D.comp_assoc D.invert_side_of_triangle(1)
	+ by (metis D.assoc'_simps(3) D.comp_null(2) D.ide_hcomp D.ideD(1)
	+ D.iso_assoc' D.not_arr_null D.seq_if_composable D.src_hcomp' T'.ide_leg1
	+ \<open>trg\<^sub>D e = a\<close> a_def e.ide_left e.ide_right)
	+ qed
	+ ultimately show ?thesis
	+ using w w' e e.antipar \<beta> D.comp_assoc by metis
	+ qed
	+ also have "... = (F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', trg\<^sub>D e] \<cdot>\<^sub>D
	+ (((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, trg\<^sub>D e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(F g \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', e \<star>\<^sub>D d] =
	+ \<a>\<^sub>D[F g, w', trg\<^sub>D e] \<cdot>\<^sub>D ((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>)"
	+ using w' e e.antipar D.assoc_naturality [of "F g" w' \<epsilon>] by simp
	+ moreover have "\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e \<star>\<^sub>D d] \<cdot>\<^sub>D (F g \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) =
	+ ((F g \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, trg\<^sub>D e]"
	+ using w e e.antipar D.assoc'_naturality [of "F g" w "D.inv \<epsilon>"]
	+ e.counit_is_iso e.counit_in_hom
	+ by simp
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = ((F g \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D \<a>\<^sub>D[F g, w', trg\<^sub>D e]) \<cdot>\<^sub>D
	+ (\<beta> \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, trg\<^sub>D e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]))"
	+ proof -
	+ have "((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>) =
	+ \<beta> \<star>\<^sub>D trg\<^sub>D e"
	+ proof -
	+ have "((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>) =
	+ ((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D D.inv \<epsilon>)"
	+ using w w' e e.antipar D.interchange [of \<beta> "F g \<star>\<^sub>D w" "e \<star>\<^sub>D d" "D.inv \<epsilon>"]
	+ D.comp_arr_dom D.comp_cod_arr e.counit_is_iso
	+ by (metis D.in_homE \<beta> d.unit_simps(1) d.unit_simps(3))
	+ also have "... = ((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w') \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D trg\<^sub>D e)"
	+ using w w' e e.antipar \<beta> D.interchange [of "F g \<star>\<^sub>D w'" \<beta> "D.inv \<epsilon>" "trg\<^sub>D e"]
	+ D.comp_arr_dom D.comp_cod_arr e.counit_is_iso
	+ by auto
	+ also have
	+ "... = (((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((F g \<star>\<^sub>D w') \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D trg\<^sub>D e)"
	+ using D.comp_assoc by simp
	+ also have "... = ((F g \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon> \<cdot>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D trg\<^sub>D e)"
	+ using w' D.whisker_left [of "F g \<star>\<^sub>D w'"] by simp
	+ also have "... = ((F g \<star>\<^sub>D w') \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D trg\<^sub>D e)"
	+ by (simp add: D.comp_arr_inv')
	+ also have "... = \<beta> \<star>\<^sub>D trg\<^sub>D e"
	+ using \<beta> D.comp_cod_arr D.hseqI'
	+ by (metis D.hcomp_simps(4) D.comp_null(2) D.hseq_char' D.in_homE
	+ D.src.preserves_cod D.src_cod e.counit_in_hom(2) e.counit_simps(4))
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[F g \<star>\<^sub>D w'] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w]"
	+ using w w' D.runit_hcomp D.runit_hcomp [of "F g" w] by simp
	+ also have "... = \<r>\<^sub>D[F g \<star>\<^sub>D w'] \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w'] \<cdot>\<^sub>D \<beta>"
	+ using \<beta> D.runit'_naturality
	+ by (metis D.arr_cod D.arr_dom D.cod_dom D.in_homE D.src.preserves_cod
	+ D.src_dom D.src_hcomp' \<open>src\<^sub>D w' = a\<close> \<open>trg\<^sub>D e = a\<close>)
	+ also have "... = (\<r>\<^sub>D[F g \<star>\<^sub>D w'] \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F g \<star>\<^sub>D w']) \<cdot>\<^sub>D \<beta>"
	+ using D.comp_assoc by simp
	+ also have "... = \<beta>"
	+ using w' \<beta> D.comp_cod_arr D.comp_arr_inv' D.iso_runit by auto
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "\<theta> = \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D ?\<gamma>)"
	+ proof -
	+ have "\<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D ?\<gamma>) =
	+ \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D[w']) \<cdot>\<^sub>D (F f \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ using w \<theta> \<gamma> D.whisker_left
	+ by (metis D.arrI D.seqE T'.ide_leg0)
	+ also have
	+ "... = (\<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D[w'])) \<cdot>\<^sub>D (F f \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have 1: "\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] =
	+ \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
	+ using w w' e we w'e e.antipar P\<gamma>e D.assoc'_naturality [of "F f" \<gamma>e d]
	+ by (metis D.cod_trg D.in_hhomE D.in_homE D.src_cod D.trg.preserves_cod
	+ T'.leg0_simps(2,4-5) T.tab_simps(2) T.leg0_simps(2)
	+ e.triangle_in_hom(4) e.triangle_right' preserves_src)
	+ also have
	+ 2: "... = (\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
	+ using D.comp_assoc by simp
	+ also have "... = F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
	+ proof -
	+ have "(\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) =
	+ (F f \<star>\<^sub>D (w' \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
	+ using 1 2 e.antipar D.isomorphic_implies_ide(2) w\<^sub>C' D.comp_assoc_assoc'
	+ by force
	+ also have "... = F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
	+ proof -
	+ have "\<guillemotleft>F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d : F f \<star>\<^sub>D (w \<star>\<^sub>D e) \<star>\<^sub>D d \<Rightarrow>\<^sub>D F f \<star>\<^sub>D (w' \<star>\<^sub>D e) \<star>\<^sub>D d\<guillemotright>"
	+ using we 1 2 e.antipar P\<gamma>e D.hseqI'
	+ by (intro D.hcomp_in_vhom, auto)
	+ thus ?thesis
	+ using D.comp_cod_arr by blast
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ finally have
	+ "\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) =
	+ F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = ((\<theta>' \<cdot>\<^sub>D \<r>\<^sub>D[F f \<star>\<^sub>D w']) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', src\<^sub>D w']) \<cdot>\<^sub>D (F f \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D (\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ using w' D.runit_hcomp(3) [of "F f" w'] D.comp_assoc by simp
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D src\<^sub>D w') \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', src\<^sub>D w'] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w' \<star>\<^sub>D \<epsilon>)) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ using \<theta>' D.runit_naturality [of \<theta>'] D.comp_assoc by fastforce
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D ((\<theta>' \<star>\<^sub>D src\<^sub>D w') \<cdot>\<^sub>D ((F f \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ using w' D.assoc'_naturality [of "F f" w' \<epsilon>] D.comp_assoc by simp
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(\<theta>' \<star>\<^sub>D src\<^sub>D w') \<cdot>\<^sub>D ((F f \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) = \<theta>' \<star>\<^sub>D \<epsilon>"
	+ using D.interchange D.comp_arr_dom D.comp_cod_arr
	+ by (metis D.in_homE \<open>src\<^sub>D w' = a\<close> \<open>trg\<^sub>D e = a\<close> \<theta>' e.counit_simps(1)
	+ e.counit_simps(3))
	+ also have "... = (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d)"
	+ using \<theta>' D.interchange [of u \<theta>' \<epsilon> "e \<star>\<^sub>D d"] D.comp_arr_dom D.comp_cod_arr
	+ by auto
	+ finally have "(\<theta>' \<star>\<^sub>D src\<^sub>D w') \<cdot>\<^sub>D ((F f \<star>\<^sub>D w') \<star>\<^sub>D \<epsilon>) = (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d)"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D ((\<a>\<^sub>D[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d])) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) =
	+ (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D[F f, w \<star>\<^sub>D e, d]"
	+ using D.assoc_naturality [of "F f" \<gamma>e d]
	+ by (metis D.cod_trg D.in_hhomE D.in_homE D.src_cod D.trg.preserves_cod P\<gamma>e
	+ T'.leg0_simps(2,4-5) T.tab_simps(2) T.leg0_simps(2) e e.antipar(1)
	+ e.triangle_in_hom(4) e.triangle_right' preserves_src w'e)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(\<a>\<^sub>D[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) =
	+ F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]"
	+ using w D.comp_cod_arr D.comp_assoc_assoc' by (simp add: D.hseqI')
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ ((\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D
	+ ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d =
	+ \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d]"
	+ proof -
	+ have "\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] =
	+ \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
	+ using P\<gamma>e e.antipar D.assoc'_naturality
	+ by (metis D.in_hhom_def D.in_homE D.vconn_implies_hpar(1)
	+ D.vconn_implies_hpar(2) T'.leg0_simps(2,4-5)
	+ T.leg0_simps(2) T.tab_simps(2) \<open>src\<^sub>D e = map\<^sub>0 a\<^sub>C\<close>
	+ d.triangle_equiv_form(1) d.triangle_in_hom(3) d.triangle_left
	+ preserves_src we)
	+ also have
	+ "... = (\<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
	+ using D.comp_assoc by simp
	+ also have "... = (F f \<star>\<^sub>D (w' \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d)"
	+ using D.isomorphic_implies_ide(2) w\<^sub>C' D.comp_assoc_assoc' by auto
	+ also have "... = F f \<star>\<^sub>D \<gamma>e \<star>\<^sub>D d"
	+ using D.comp_cod_arr
	+ by (metis D.comp_cod_arr D.comp_null(2) D.hseq_char D.hseq_char'
	+ D.in_homE D.whisker_left D.whisker_right P\<gamma>e T'.ide_leg0 e.ide_right)
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F f \<star>\<^sub>D w', e, d]) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e \<star>\<^sub>D d]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d] =
	+ \<a>\<^sub>D[F f \<star>\<^sub>D w', e, d] \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<star>\<^sub>D d)"
	+ proof -
	+ have "\<a>\<^sub>D[F f, w', e \<star>\<^sub>D d] \<cdot>\<^sub>D \<a>\<^sub>D[F f \<star>\<^sub>D w', e, d] =
	+ ((F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d]) \<cdot>\<^sub>D (\<a>\<^sub>D[F f, w', e] \<star>\<^sub>D d)"
	+ using w' D.pentagon D.comp_assoc by simp
	+ moreover have "D.seq \<a>\<^sub>D[F f, w', e \<star>\<^sub>D d] \<a>\<^sub>D[F f \<star>\<^sub>D w', e, d]"
	+ using w' by simp
	+ moreover have "D.inv (\<a>\<^sub>D[F f, w', e] \<star>\<^sub>D d) = \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<star>\<^sub>D d"
	+ using w' by simp
	+ ultimately show ?thesis
	+ using w' D.comp_assoc
	+ D.invert_opposite_sides_of_square
	+ [of "\<a>\<^sub>D[F f, w', e \<star>\<^sub>D d]" "\<a>\<^sub>D[F f \<star>\<^sub>D w', e, d]"
	+ "(F f \<star>\<^sub>D \<a>\<^sub>D[w', e, d]) \<cdot>\<^sub>D \<a>\<^sub>D[F f, w' \<star>\<^sub>D e, d]"
	+ "\<a>\<^sub>D[F f, w', e] \<star>\<^sub>D d"]
	+ by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have
	+ "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
	+ (((\<theta>' \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(\<theta>' \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D[F f \<star>\<^sub>D w', e, d] = \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D ((\<theta>' \<star>\<^sub>D e) \<star>\<^sub>D d)"
	+ using w' \<theta>' e.ide_left e.ide_right e.antipar D.assoc_naturality [of \<theta>' e d]
	+ by auto
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
	+ ((\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "((\<theta>' \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<star>\<^sub>D d) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d) =
	+ (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e) \<star>\<^sub>D d"
	+ using w' w'e \<theta>' \<theta>\<^sub>C e.ide_left e.ide_right e.antipar D.whisker_right
	+ by (metis (full_types) C.arrI D.cod_comp D.seqE D.seqI F\<theta>\<^sub>C_def P\<gamma>e
	+ preserves_arr)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
	+ ((\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e) =
	+ \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
	+ using P\<gamma>e by simp
	+ moreover have "D.arr (\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e))"
	+ by (metis C.in_homE D.comp_assoc D.comp_null(1) D.ext F\<theta>\<^sub>C_def P\<gamma>e \<theta>\<^sub>C
	+ preserves_arr)
	+ moreover have "D.arr (\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e])"
	+ using P\<gamma>e calculation(2) by auto
	+ ultimately have "(\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>e) =
	+ (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
	+ using \<psi> \<theta>\<^sub>C F\<theta>\<^sub>C_def D.iso_is_section D.section_is_mono
	+ by (metis D.monoE)
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
	+ ((\<theta> \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D ((\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<star>\<^sub>D d) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w \<star>\<^sub>D e, d] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d])) \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<star>\<^sub>D d =
	+ ((\<theta> \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] \<star>\<^sub>D d)"
	+ proof -
	+ have "D.arr ((\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e])"
	+ by (metis C.arrI D.cod_comp D.seqE D.seqI F\<theta>\<^sub>C_def \<theta>\<^sub>C preserves_arr)
	+ thus ?thesis
	+ using D.whisker_right e.ide_right by blast
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
	+ (((\<theta> \<star>\<^sub>D e) \<star>\<^sub>D d) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f \<star>\<^sub>D w, e, d]) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e \<star>\<^sub>D d] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ using w D.pentagon' D.comp_assoc by simp
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((\<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[u, e, d]) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e \<star>\<^sub>D d] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ using \<theta> e.antipar D.assoc'_naturality [of \<theta> e d] D.comp_assoc by fastforce
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D (\<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e \<star>\<^sub>D d] \<cdot>\<^sub>D
	+ (F f \<star>\<^sub>D w \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(\<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u, e, d]) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d) = \<theta> \<star>\<^sub>D e \<star>\<^sub>D d"
	+ proof -
	+ have "(\<a>\<^sub>D[u, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[u, e, d]) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d) =
	+ (u \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d)"
	+ using \<theta> ue e.ide_left e.ide_right e.antipar D.comp_arr_inv' D.comp_cod_arr
	+ by auto
	+ also have "... = \<theta> \<star>\<^sub>D e \<star>\<^sub>D d"
	+ using ue e.ide_left e.ide_right e.antipar D.hcomp_simps(4) D.hseq_char' \<theta>
	+ D.comp_cod_arr [of "\<theta> \<star>\<^sub>D e \<star>\<^sub>D d" "u \<star>\<^sub>D e \<star>\<^sub>D d"]
	+ by force
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D ((u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d)) \<cdot>\<^sub>D ((F f \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ using w e.antipar D.assoc'_naturality [of "F f" w "D.inv \<epsilon>"] D.comp_assoc by simp
	+ also have
	+ "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D (((F f \<star>\<^sub>D w) \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((F f \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e]) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(u \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e \<star>\<^sub>D d) = (\<theta> \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D ((F f \<star>\<^sub>D w) \<star>\<^sub>D \<epsilon>)"
	+ using \<theta> e.antipar D.interchange D.comp_arr_dom D.comp_cod_arr
	+ by (metis D.in_homE \<open>trg\<^sub>D e = a\<close> e.counit_simps(1-3,5))
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[u] \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w])"
	+ proof -
	+ have "(((F f \<star>\<^sub>D w) \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((F f \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e] =
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e]"
	+ proof -
	+ have "(((F f \<star>\<^sub>D w) \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D ((F f \<star>\<^sub>D w) \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e] =
	+ ((F f \<star>\<^sub>D w) \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e]"
	+ using w e.ide_left e.ide_right e.antipar e.counit_is_iso D.comp_arr_inv'
	+ D.comp_assoc D.whisker_left
	+ by (metis D.ide_hcomp D.seqI' T'.ide_leg0 T'.leg1_simps(3)
	+ T.leg1_simps(2-3) T.tab_simps(2) \<open>trg\<^sub>D w = map\<^sub>0 (src\<^sub>C \<rho>)\<close>
	+ d.unit_in_vhom e.counit_in_hom(2) e.counit_simps(3) preserves_src)
	+ also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, trg\<^sub>D e]"
	+ using w D.comp_cod_arr D.assoc'_in_hom(2) [of "F f" w "trg\<^sub>D e"] D.hseqI'
	+ \<open>trg\<^sub>D e = a\<close> \<open>trg\<^sub>D w = map\<^sub>0 (src\<^sub>C \<rho>)\<close>
	+ by (metis D.assoc'_is_natural_1 D.ideD(1) D.ideD(2) D.trg.preserves_ide
	+ D.trg_trg T'.leg0_simps(2,4) T'.leg1_simps(3)
	+ T.leg1_simps(2-3) T.tab_simps(2) a_def e.ide_left
	+ preserves_src)
	+ finally show ?thesis by blast
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (\<r>\<^sub>D[u] \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D trg\<^sub>D e)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f \<star>\<^sub>D w]"
	+ using w D.runit_hcomp(2) [of "F f" w] D.comp_assoc by simp
	+ also have 1: "... = (\<theta> \<cdot>\<^sub>D \<r>\<^sub>D[F f \<star>\<^sub>D w]) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[F f \<star>\<^sub>D w]"
	+ using \<theta> D.runit_naturality [of \<theta>] by auto
	+ also have "... = \<theta>"
	+ using w \<theta> D.comp_arr_dom D.comp_assoc
	+ by (metis D.hcomp_arr_obj(2) D.in_homE D.obj_src 1 \<open>src\<^sub>D \<theta> = a\<close> \<open>trg\<^sub>D e = a\<close>)
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show "\<guillemotleft>?\<gamma> : w \<Rightarrow>\<^sub>D w'\<guillemotright> \<and> \<beta> = F g \<star>\<^sub>D ?\<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D ?\<gamma>)"
	+ by simp
	+
	+ show "\<And>\<gamma>'. \<guillemotleft>\<gamma>' : w \<Rightarrow>\<^sub>D w'\<guillemotright> \<and> \<beta> = F g \<star>\<^sub>D \<gamma>' \<and> \<theta> = \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>') \<Longrightarrow> \<gamma>' = ?\<gamma>"
	+ proof -
	+ fix \<gamma>'
	+ assume \<gamma>': "\<guillemotleft>\<gamma>' : w \<Rightarrow>\<^sub>D w'\<guillemotright> \<and> \<beta> = F g \<star>\<^sub>D \<gamma>' \<and> \<theta> = \<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>')"
	+ show "\<gamma>' = ?\<gamma>"
	+ proof -
	+ have "?\<gamma> = \<r>\<^sub>D[w'] \<cdot>\<^sub>D (w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<a>\<^sub>D[w', e, d] \<cdot>\<^sub>D ((\<gamma>' \<star>\<^sub>D e) \<star>\<^sub>D d)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
	+ proof -
	+ have "\<gamma>e = \<gamma>' \<star>\<^sub>D e"
	+ proof -
	+ have "\<guillemotleft>\<gamma>' \<star>\<^sub>D e : w \<star>\<^sub>D e \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>"
	+ using \<gamma>' by (intro D.hcomp_in_vhom, auto)
	+ moreover have
	+ "\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] = F g \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e"
	+ proof -
	+ have "\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D (\<beta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e] =
	+ \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D ((F g \<star>\<^sub>D \<gamma>') \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w, e]"
	+ using \<gamma>' by simp
	+ also have "... = \<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w', e] \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e)"
	+ using \<gamma>' D.assoc_naturality
	+ by (metis D.assoc'_naturality D.hcomp_in_vhomE D.ideD(2) D.ideD(3)
	+ D.in_homE T'.leg1_simps(5-6) \<beta>
	+ \<open>\<guillemotleft>\<gamma>' \<star>\<^sub>D e : w \<star>\<^sub>D e \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>\<close> e.ide_left)
	+ also have "... = (\<a>\<^sub>D[F g, w', e] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F g, w', e]) \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e)"
	+ using D.comp_assoc by simp
	+ also have "... = F g \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e"
	+ by (metis D.hcomp_reassoc(2) D.in_homE D.not_arr_null D.seq_if_composable
	+ T'.leg1_simps(2,5-6) \<beta> \<gamma>' calculation
	+ \<open>\<guillemotleft>\<gamma>' \<star>\<^sub>D e : w \<star>\<^sub>D e \<Rightarrow>\<^sub>D w' \<star>\<^sub>D e\<guillemotright>\<close> e.triangle_equiv_form(1)
	+ e.triangle_in_hom(3) e.triangle_right e.triangle_right_implies_left)
	+ finally show ?thesis by simp
	+ qed
	+ moreover have "\<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e] =
	+ \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e)"
	+ proof -
	+ have "\<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w', e] \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>' \<star>\<^sub>D e) =
	+ \<psi> \<cdot>\<^sub>D (\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>') \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
	+ using \<gamma>' \<theta> e.ide_left D.assoc'_naturality
	+ by (metis D.hcomp_in_vhomE D.ideD(2) D.ideD(3) D.in_homE
	+ T'.leg0_simps(2,4-5) T'.leg1_simps(3) \<beta> calculation(1))
	+ also have "... = \<psi> \<cdot>\<^sub>D ((\<theta>' \<star>\<^sub>D e) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<gamma>') \<star>\<^sub>D e)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
	+ using D.comp_assoc by simp
	+ also have "... = \<psi> \<cdot>\<^sub>D (\<theta>' \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>') \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
	+ using D.whisker_right \<gamma>' \<theta> by auto
	+ also have "... = \<psi> \<cdot>\<^sub>D (\<theta> \<star>\<^sub>D e) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, w, e]"
	+ using \<gamma>' by simp
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using UN by simp
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<r>\<^sub>D[w'] \<cdot>\<^sub>D ((w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<gamma>' \<star>\<^sub>D e \<star>\<^sub>D d)) \<cdot>\<^sub>D \<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
	+ using w' \<gamma>' D.comp_assoc D.assoc_naturality
	+ by (metis D.in_homE D.src_dom \<open>trg\<^sub>D e = a\<close> a_def e.antipar(1)
	+ e.triangle_equiv_form(1) e.triangle_in_hom(3-4)
	+ e.triangle_right e.triangle_right' e.triangle_right_implies_left)
	+ also have "... = (\<r>\<^sub>D[w'] \<cdot>\<^sub>D (\<gamma>' \<star>\<^sub>D trg\<^sub>D e)) \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D
	+ \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
	+ proof -
	+ have "(w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<gamma>' \<star>\<^sub>D e \<star>\<^sub>D d) = \<gamma>' \<star>\<^sub>D \<epsilon>"
	+ using w' \<gamma>' e.antipar D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of w' \<gamma>' \<epsilon> "e \<star>\<^sub>D d"]
	+ by auto
	+ also have "... = (\<gamma>' \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>)"
	+ using w \<gamma>' e.antipar D.comp_arr_dom D.comp_cod_arr D.interchange
	+ by (metis D.in_homE \<open>trg\<^sub>D e = a\<close> e.counit_simps(1) e.counit_simps(3,5))
	+ finally have "(w' \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<gamma>' \<star>\<^sub>D e \<star>\<^sub>D d) = (\<gamma>' \<star>\<^sub>D trg\<^sub>D e) \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>)"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<gamma>' \<cdot>\<^sub>D \<r>\<^sub>D[w] \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D
	+ (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
	+ using \<gamma>' D.runit_naturality D.comp_assoc
	+ by (metis D.in_homE D.src_dom \<open>trg\<^sub>D e = a\<close> a_def)
	+ also have "... = \<gamma>'"
	+ proof -
	+ have "\<r>\<^sub>D[w] \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D
	+ \<r>\<^sub>D\<^sup>-\<^sup>1[w] =
	+ \<r>\<^sub>D[w] \<cdot>\<^sub>D ((w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (\<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d]) \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D
	+ \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
	+ using D.comp_assoc by simp
	+ also have "... = \<r>\<^sub>D[w] \<cdot>\<^sub>D ((w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (w \<star>\<^sub>D e \<star>\<^sub>D d) \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D
	+ \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
	+ using w \<gamma> e.ide_left e.ide_right we e.antipar D.comp_assoc_assoc'(1)
	+ \<open>trg\<^sub>D e = a\<close> a_def
	+ by presburger
	+ also have "... = \<r>\<^sub>D[w] \<cdot>\<^sub>D ((w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D (w \<star>\<^sub>D D.inv \<epsilon>)) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
	+ using w \<gamma> e.ide_left e.ide_right we e.antipar D.comp_cod_arr
	+ by (metis D.whisker_left d.unit_simps(1,3))
	+ also have "... = \<r>\<^sub>D[w] \<cdot>\<^sub>D (w \<star>\<^sub>D src\<^sub>D w) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
	+ using w e.counit_is_iso C.comp_arr_inv'
	+ by (metis D.comp_arr_inv' D.seqI' D.whisker_left \<open>trg\<^sub>D e = a\<close> a_def
	+ d.unit_in_vhom e.counit_in_hom(2) e.counit_simps(3))
	+ also have "... = \<r>\<^sub>D[w] \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w]"
	+ using w e.antipar D.comp_cod_arr by simp
	+ also have "... = w"
	+ using w
	+ by (simp add: D.comp_arr_inv')
	+ finally have "\<r>\<^sub>D[w] \<cdot>\<^sub>D (w \<star>\<^sub>D \<epsilon>) \<cdot>\<^sub>D \<a>\<^sub>D[w, e, d] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[w, e, d] \<cdot>\<^sub>D
	+ (w \<star>\<^sub>D D.inv \<epsilon>) \<cdot>\<^sub>D \<r>\<^sub>D\<^sup>-\<^sup>1[w] = w"
	+ by simp
	+ thus ?thesis
	+ using \<gamma>' D.comp_arr_dom by auto
	+ qed
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+ qed
	+ qed
	+ show ?thesis ..
	+ qed
	+
	+ lemma reflects_tabulation:
	+ assumes "C.ide r" and "C.ide f" and "\<guillemotleft>\<rho> : g \<Rightarrow>\<^sub>C r \<star>\<^sub>C f\<guillemotright>"
	+ assumes "tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F r) (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>) (F f) (F g)"
	+ shows "tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> f g"
	+ proof -
	+ interpret \<rho>': tabulation V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
	+ \<open>F r\<close> \<open>D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>\<close> \<open>F f\<close> \<open>F g\<close>
	+ using assms by auto
	+ interpret \<rho>: tabulation_data V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> f g
	+ using assms by (unfold_locales, simp_all)
	+ interpret \<rho>: tabulation V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C r \<rho> f g
	+ proof
	+ show "\<And>u \<omega>. \<lbrakk> C.ide u; \<guillemotleft>\<omega> : C.dom \<omega> \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<guillemotright> \<rbrakk> \<Longrightarrow>
	+ \<exists>w \<theta> \<nu>. C.ide w \<and> \<guillemotleft>\<theta> : f \<star>\<^sub>C w \<Rightarrow>\<^sub>C u\<guillemotright> \<and> \<guillemotleft>\<nu> : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<guillemotright> \<and>
	+ C.iso \<nu> \<and> \<rho>.composite_cell w \<theta> \<cdot>\<^sub>C \<nu> = \<omega>"
	+ proof -
	+ fix u \<omega>
	+ assume u: "C.ide u"
	+ assume \<omega>: "\<guillemotleft>\<omega> : C.dom \<omega> \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<guillemotright>"
	+ have hseq_ru: "src\<^sub>C r = trg\<^sub>C u"
	+ using \<omega> C.ide_cod C.ideD(1) by fastforce
	+ hence 1: "\<guillemotleft>D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F \<omega> : F (C.dom \<omega>) \<Rightarrow>\<^sub>D F r \<star>\<^sub>D F u\<guillemotright>"
	+ using assms u \<omega> \<Phi>_in_hom \<Phi>_components_are_iso
	+ by (intro D.comp_in_homI, auto)
	+ hence 2: "D.dom (D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F \<omega>) = F (C.dom \<omega>)"
	+ by auto
	+ obtain w \<theta> \<nu>
	+ where w\<theta>\<nu>: "D.ide w \<and> \<guillemotleft>\<theta> : F f \<star>\<^sub>D w \<Rightarrow>\<^sub>D F u\<guillemotright> \<and>
	+ \<guillemotleft>\<nu> : F (C.dom \<omega>) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w\<guillemotright> \<and> D.iso \<nu> \<and>
	+ \<rho>'.composite_cell w \<theta> \<cdot>\<^sub>D \<nu> = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F \<omega>"
	+ using 1 2 u \<rho>'.T1 [of "F u" "D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F \<omega>"] by auto
	+ have hseq_Ff_w: "src\<^sub>D (F f) = trg\<^sub>D w"
	+ using u \<omega> w\<theta>\<nu>
	+ by (metis "1" D.arrI D.not_arr_null D.seqE D.seq_if_composable \<rho>'.tab_simps(2))
	+ have hseq_Fg_w: "src\<^sub>D (F g) = trg\<^sub>D w"
	+ using u \<omega> w\<theta>\<nu> by (simp add: hseq_Ff_w)
	+ have w: "\<guillemotleft>w : map\<^sub>0 (src\<^sub>C \<omega>) \<rightarrow>\<^sub>D map\<^sub>0 (src\<^sub>C f)\<guillemotright>"
	+ using u \<omega> w\<theta>\<nu> hseq_Fg_w
	+ by (metis "1" C.arrI D.arrI D.hseqI' D.ideD(1) D.in_hhom_def D.src_hcomp'
	+ D.src_vcomp D.vconn_implies_hpar(1) D.vconn_implies_hpar(3)
	+ D.vseq_implies_hpar(1) \<rho>'.leg1_simps(2) \<rho>.leg0_simps(2) hseq_Ff_w
	+ preserves_src)
	+ obtain w' where w': "\<guillemotleft>w' : src\<^sub>C \<omega> \<rightarrow>\<^sub>C src\<^sub>C f\<guillemotright> \<and> C.ide w' \<and> D.isomorphic (F w') w"
	+ using assms w \<omega> w\<theta>\<nu> locally_essentially_surjective by force
	+ obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : F w' \<Rightarrow>\<^sub>D w\<guillemotright> \<and> D.iso \<phi>"
	+ using w' D.isomorphic_def by blast
	+ have src_fw': "src\<^sub>C (f \<star>\<^sub>C w') = src\<^sub>C u"
	+ using u w' \<omega>
	+ by (metis C.cod_src C.hseqI' C.ideD(1) C.in_hhom_def C.in_homE C.src.preserves_cod
	+ C.hcomp_simps(1) \<rho>.leg0_in_hom(1) \<rho>.base_simps(2) hseq_ru)
	+ have 3: "\<guillemotleft>\<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w')) : F (f \<star>\<^sub>C w') \<Rightarrow>\<^sub>D F u\<guillemotright>"
	+ proof (intro D.comp_in_homI)
	+ show "\<guillemotleft>D.inv (\<Phi> (f, w')) : F (f \<star>\<^sub>C w') \<Rightarrow>\<^sub>D F f \<star>\<^sub>D F w'\<guillemotright>"
	+ using assms w' \<Phi>_in_hom \<Phi>_components_are_iso by auto
	+ show "\<guillemotleft>F f \<star>\<^sub>D \<phi> : F f \<star>\<^sub>D F w' \<Rightarrow>\<^sub>D F f \<star>\<^sub>D w\<guillemotright>"
	+ using \<phi> \<rho>'.leg0_in_hom(2) w' by auto
	+ show "\<guillemotleft>\<theta> : F f \<star>\<^sub>D w \<Rightarrow>\<^sub>D F u\<guillemotright>"
	+ using w\<theta>\<nu> by simp
	+ qed
	+ have 4: "\<exists>\<theta>'. \<guillemotleft>\<theta>' : f \<star>\<^sub>C w' \<Rightarrow>\<^sub>C u\<guillemotright> \<and> F \<theta>' = \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))"
	+ using w' u hseq_ru src_fw' 3 locally_full by auto
	+ obtain \<theta>' where
	+ \<theta>': "\<guillemotleft>\<theta>' : f \<star>\<^sub>C w' \<Rightarrow>\<^sub>C u\<guillemotright> \<and> F \<theta>' = \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))"
	+ using 4 by auto
	+ have 5: "\<guillemotleft>\<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D \<nu> : F (C.dom \<omega>) \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C w')\<guillemotright>"
	+ proof (intro D.comp_in_homI)
	+ show "\<guillemotleft>\<nu> : F (C.dom \<omega>) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D w\<guillemotright>"
	+ using w\<theta>\<nu> by simp
	+ show "\<guillemotleft>F g \<star>\<^sub>D D.inv \<phi> : F g \<star>\<^sub>D w \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F w'\<guillemotright>"
	+ using assms \<phi>
	+ by (meson D.hcomp_in_vhom D.inv_in_hom \<rho>'.leg1_in_hom(2) hseq_Fg_w)
	+ show "\<guillemotleft>\<Phi> (g, w') : F g \<star>\<^sub>D F w' \<Rightarrow>\<^sub>D F (g \<star>\<^sub>C w')\<guillemotright>"
	+ using assms w' \<Phi>_in_hom by auto
	+ qed
	+ have 6: "\<exists>\<nu>'. \<guillemotleft>\<nu>' : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w'\<guillemotright> \<and>
	+ F \<nu>' = \<Phi>(g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D \<nu>"
	+ using u w' \<omega> C.in_hhom_def hseq_ru C.hseqI' C.hcomp_simps(1-2)
	+ by (metis "5" C.arrI C.ide_hcomp C.ideD(1) C.ide_dom C.vconn_implies_hpar(1,4)
	+ \<rho>.base_simps(2) \<rho>.ide_leg1 \<rho>.leg1_in_hom(1) locally_full)
	+ obtain \<nu>' where
	+ \<nu>': "\<guillemotleft>\<nu>' : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w'\<guillemotright> \<and> F \<nu>' = \<Phi>(g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D \<nu>"
	+ using 6 by auto
	+ have "C.ide w' \<and> \<guillemotleft>\<theta>' : f \<star>\<^sub>C w' \<Rightarrow>\<^sub>C u\<guillemotright> \<and> \<guillemotleft>\<nu>' : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w'\<guillemotright> \<and> C.iso \<nu>' \<and>
	+ \<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>' = \<omega>"
	+ using w' \<theta>' \<nu>'
	+ apply (intro conjI)
	+ apply auto
	+ proof -
	+ show "C.iso \<nu>'"
	+ proof -
	+ have "D.iso (F \<nu>')"
	+ proof -
	+ have "D.iso (\<Phi>(g, w'))"
	+ using w' \<Phi>_components_are_iso by auto
	+ moreover have "D.iso (F g \<star>\<^sub>D D.inv \<phi>)"
	+ using \<phi>
	+ by (meson "5" D.arrI D.iso_hcomp D.hseq_char' D.ide_is_iso D.iso_inv_iso
	+ D.seqE D.seq_if_composable \<rho>'.ide_leg1)
	+ moreover have "D.iso \<nu>"
	+ using w\<theta>\<nu> by simp
	+ ultimately show ?thesis
	+ using \<nu>' D.isos_compose
	+ by (metis "5" D.arrI D.seqE)
	+ qed
	+ thus ?thesis using reflects_iso by blast
	+ qed
	+ have 7: "\<guillemotleft>\<rho>.composite_cell w' \<theta>' : g \<star>\<^sub>C w' \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<guillemotright>"
	+ using u w' \<theta>' \<rho>.composite_cell_in_hom hseq_ru src_fw' C.hseqI'
	+ by (metis C.in_hhomE C.hcomp_simps(1) \<rho>.leg0_simps(2))
	+ hence 8: "\<guillemotleft>\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>' : C.dom \<omega> \<Rightarrow>\<^sub>C r \<star>\<^sub>C u\<guillemotright>"
	+ using \<nu>' by blast
	+ show "\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>' = \<omega>"
	+ proof -
	+ have 1: "C.par (\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>') \<omega>"
	+ using \<omega> 8 hseq_ru C.hseqI' C.in_homE by metis
	+ moreover have "F (\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>') = F \<omega>"
	+ proof -
	+ have "F (\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>') =
	+ F (r \<star>\<^sub>C \<theta>') \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w'] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w') \<cdot>\<^sub>D F \<nu>'"
	+ using w' \<theta>' \<nu>' 1 C.comp_assoc
	+ by (metis C.seqE preserves_comp)
	+ also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D
	+ \<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w'))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D
	+ \<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w')) \<cdot>\<^sub>D D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<nu>'"
	+ proof -
	+ have "F \<a>\<^sub>C[r, f, w'] =
	+ \<Phi> (r, f \<star>\<^sub>C w') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w'))"
	+ using assms w'
	+ by (simp add: C.in_hhom_def preserves_assoc(1))
	+ moreover have
	+ "F (r \<star>\<^sub>C \<theta>') = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D D.inv (\<Phi> (r, f \<star>\<^sub>C w'))"
	+ using assms \<theta>' preserves_hcomp [of r \<theta>']
	+ by (metis "1" C.in_homE C.seqE \<rho>.base_simps(3) \<rho>.base_simps(4))
	+ moreover have
	+ "F (\<rho> \<star>\<^sub>C w') = \<Phi> (r \<star>\<^sub>C f, w') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D D.inv (\<Phi> (g, w'))"
	+ using w' preserves_hcomp [of \<rho> w'] by auto
	+ ultimately show ?thesis
	+ by (simp add: D.comp_assoc)
	+ qed
	+ also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D
	+ (F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<nu>'"
	+ proof -
	+ have "(D.inv (\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) =
	+ F r \<star>\<^sub>D \<Phi> (f, w')"
	+ using w' \<Phi>_components_are_iso D.comp_cod_arr C.hseqI' D.hseqI'
	+ C.in_hhom_def C.trg_hcomp' D.comp_inv_arr' C.ide_hcomp
	+ by (metis C.ideD(1) D.hcomp_simps(4) \<Phi>_simps(1,3-5)
	+ \<rho>'.leg0_simps(3) \<rho>'.base_simps(2,4) \<rho>.ide_leg0 \<rho>.ide_base
	+ \<rho>.leg0_simps(3))
	+ moreover have "(D.inv (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D \<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') =
	+ F \<rho> \<star>\<^sub>D F w'"
	+ using w' D.comp_inv_arr' \<Phi>_components_are_iso D.hseqI' hseq_Fg_w D.comp_cod_arr
	+ by auto
	+ ultimately show ?thesis by simp
	+ qed
	+ also have "... = \<Phi> (r, u) \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D \<Phi> (f, w'))) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w')) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D \<nu>"
	+ using w' \<theta>' \<nu>' D.comp_assoc by simp
	+ also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w')) \<cdot>\<^sub>D
	+ \<Phi> (f, w')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D
	+ F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D ((D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D \<Phi> (g, w')) \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D D.inv \<phi>)) \<cdot>\<^sub>D \<nu>"
	+ proof -
	+ have "(F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) =
	+ F r \<star>\<^sub>D (\<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))) \<cdot>\<^sub>D \<Phi> (f, w')"
	+ proof -
	+ have "D.seq (\<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w'))) (\<Phi> (f, w'))"
	+ using assms 3 \<rho>.ide_base w' w\<theta>\<nu> \<Phi>_in_hom [of f w'] \<Phi>_components_are_iso
	+ C.in_hhom_def
	+ apply (intro D.seqI)
	+ using C.in_hhom_def
	+ apply auto[3]
	+ apply blast
	+ by auto
	+ thus ?thesis
	+ using assms w' w\<theta>\<nu> \<Phi>_in_hom \<Phi>_components_are_iso D.whisker_left by simp
	+ qed
	+ moreover have "(D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') =
	+ D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w'"
	+ using w' D.whisker_right by simp
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D
	+ (F g \<star>\<^sub>D D.inv \<phi>)) \<cdot>\<^sub>D \<nu>"
	+ proof -
	+ have "(F f \<star>\<^sub>D \<phi>) \<cdot>\<^sub>D D.inv (\<Phi> (f, w')) \<cdot>\<^sub>D \<Phi> (f, w') = F f \<star>\<^sub>D \<phi>"
	+ using assms(2) w' \<phi> 3 \<Phi>_components_are_iso \<Phi>_in_hom D.hseqI' D.comp_inv_arr'
	+ D.comp_arr_dom
	+ by (metis C.in_hhom_def D.hcomp_simps(3) D.in_homE D.seqE \<rho>'.leg0_simps(4))
	+ moreover have "(D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D \<Phi> (g, w')) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) =
	+ F g \<star>\<^sub>D D.inv \<phi>"
	+ using assms w' \<phi> 3 \<Phi>_components_are_iso \<Phi>_in_hom D.hseqI' D.comp_inv_arr'
	+ D.comp_cod_arr
	+ by (metis "5" C.in_hhom_def D.arrI D.comp_assoc D.seqE \<rho>.ide_leg1
	+ \<rho>.leg1_simps(3))
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)) \<cdot>\<^sub>D
	+ (\<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F f) \<star>\<^sub>D D.inv \<phi>)) \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w) \<cdot>\<^sub>D \<nu>"
	+ proof -
	+ have "(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) =
	+ D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D D.inv \<phi>"
	+ using assms w' \<phi> \<Phi>_in_hom \<Phi>_components_are_iso D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of "D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>" "F g" "F w'" "D.inv \<phi>"]
	+ by auto
	+ also have "... = ((F r \<star>\<^sub>D F f) \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w)"
	+ using assms w' \<phi> \<Phi>_components_are_iso D.comp_arr_dom D.comp_cod_arr
	+ D.interchange [of "F r \<star>\<^sub>D F f" "D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho>" "D.inv \<phi>" w]
	+ by auto
	+ finally have "(D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv \<phi>) =
	+ ((F r \<star>\<^sub>D F f) \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w)"
	+ by simp
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u) \<cdot>\<^sub>D ((F r \<star>\<^sub>D \<theta> \<cdot>\<^sub>D (F f \<star>\<^sub>D \<phi>)) \<cdot>\<^sub>D
	+ (F r \<star>\<^sub>D F f \<star>\<^sub>D D.inv \<phi>)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w) \<cdot>\<^sub>D \<nu>"
	+ proof -
	+ have "\<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D ((F r \<star>\<^sub>D F f) \<star>\<^sub>D D.inv \<phi>) =
	+ (F r \<star>\<^sub>D F f \<star>\<^sub>D D.inv \<phi>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w]"
	+ proof -
	+ have "src\<^sub>D (F r) = trg\<^sub>D (F f)"
	+ by simp
	+ moreover have "src\<^sub>D (F f) = trg\<^sub>D (D.inv \<phi>)"
	+ using \<phi>
	+ by (metis "5" D.arrI D.hseqE D.seqE \<rho>'.leg1_simps(3))
	+ ultimately show ?thesis
	+ using assms w' \<phi> D.assoc_naturality [of "F r" "F f" "D.inv \<phi>"] by auto
	+ qed
	+ thus ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<theta>) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D w) \<cdot>\<^sub>D \<nu>"
	+ using assms \<phi> w\<theta>\<nu> D.comp_arr_inv' D.comp_arr_dom D.comp_cod_arr
	+ D.whisker_left D.whisker_left D.comp_assoc
	+ by (metis D.ideD(1) D.in_homE \<rho>'.ide_base tabulation_data.leg0_simps(1)
	+ tabulation_def)
	+ also have "... = (\<Phi> (r, u) \<cdot>\<^sub>D D.inv (\<Phi> (r, u))) \<cdot>\<^sub>D F \<omega>"
	+ using w\<theta>\<nu> D.comp_assoc by simp
	+ also have "... = F \<omega>"
	+ using u \<omega> \<Phi>_in_hom \<Phi>.components_are_iso D.comp_arr_inv'
	+ by (metis C.in_homE \<Phi>_components_are_iso \<Phi>_simps(5) \<rho>.ide_base is_natural_1
	+ naturality hseq_ru)
	+ finally show ?thesis by blast
	+ qed
	+ ultimately show ?thesis
	+ using is_faithful [of "\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<nu>'" \<omega>] by simp
	+ qed
	+ qed
	+ thus "\<exists>w \<theta> \<nu>. C.ide w \<and> \<guillemotleft>\<theta> : f \<star>\<^sub>C w \<Rightarrow>\<^sub>C u\<guillemotright> \<and> \<guillemotleft>\<nu> : C.dom \<omega> \<Rightarrow>\<^sub>C g \<star>\<^sub>C w\<guillemotright> \<and>
	+ C.iso \<nu> \<and> \<rho>.composite_cell w \<theta> \<cdot>\<^sub>C \<nu> = \<omega>"
	+ by auto
	+ qed
	+
	+ show "\<And>u w w' \<theta> \<theta>' \<beta>. \<lbrakk> C.ide w; C.ide w'; \<guillemotleft>\<theta> : f \<star>\<^sub>C w \<Rightarrow>\<^sub>C u\<guillemotright>; \<guillemotleft>\<theta>' : f \<star>\<^sub>C w' \<Rightarrow>\<^sub>C u\<guillemotright>;
	+ \<guillemotleft>\<beta> : g \<star>\<^sub>C w \<Rightarrow>\<^sub>C g \<star>\<^sub>C w'\<guillemotright>;
	+ \<rho>.composite_cell w \<theta> = \<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<beta> \<rbrakk>
	+ \<Longrightarrow> \<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
	+ proof -
	+ fix u w w' \<theta> \<theta>' \<beta>
	+ assume w: "C.ide w"
	+ assume w': "C.ide w'"
	+ assume \<theta>: "\<guillemotleft>\<theta> : f \<star>\<^sub>C w \<Rightarrow>\<^sub>C u\<guillemotright>"
	+ assume \<theta>': "\<guillemotleft>\<theta>' : f \<star>\<^sub>C w' \<Rightarrow>\<^sub>C u\<guillemotright>"
	+ assume \<beta>: "\<guillemotleft>\<beta> : g \<star>\<^sub>C w \<Rightarrow>\<^sub>C g \<star>\<^sub>C w'\<guillemotright>"
	+ assume eq: "\<rho>.composite_cell w \<theta> = \<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<beta>"
	+ show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
	+ proof -
	+ have hseq_ru: "src\<^sub>C r = trg\<^sub>C u"
	+ using w \<theta>
	+ by (metis C.horizontal_homs_axioms C.ideD(1) C.in_homE C.hcomp_simps(2)
	+ C.vconn_implies_hpar(4) \<rho>.leg0_simps(3) category.ide_dom horizontal_homs_def)
	+ have hseq_fw: "src\<^sub>C f = trg\<^sub>C w \<and> src\<^sub>C f = trg\<^sub>C w'"
	+ using w w' \<rho>.ide_leg0 \<theta> \<theta>'
	+ by (metis C.horizontal_homs_axioms C.ideD(1) C.in_homE C.not_arr_null
	+ C.seq_if_composable category.ide_dom horizontal_homs_def)
	+ have hseq_gw: "src\<^sub>C g = trg\<^sub>C w \<and> src\<^sub>C g = trg\<^sub>C w'"
	+ using w w' \<rho>.ide_leg0 \<theta> \<theta>' \<open>src\<^sub>C f = trg\<^sub>C w \<and> src\<^sub>C f = trg\<^sub>C w'\<close> by auto
	+ have *: "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : F w \<Rightarrow>\<^sub>D F w'\<guillemotright> \<and>
	+ D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = F g \<star>\<^sub>D \<gamma> \<and>
	+ F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>)"
	+ proof -
	+ have "D.ide (F w) \<and> D.ide (F w')"
	+ using w w' by simp
	+ moreover have 1: "\<guillemotleft>F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) : F f \<star>\<^sub>D F w \<Rightarrow>\<^sub>D F u\<guillemotright>"
	+ using w \<theta> \<Phi>_in_hom \<rho>.ide_leg0 hseq_fw by blast
	+ moreover have 2: "\<guillemotleft>F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') : F f \<star>\<^sub>D F w' \<Rightarrow>\<^sub>D F u\<guillemotright>"
	+ using w' \<theta>' \<Phi>_in_hom \<rho>.ide_leg0 hseq_fw by blast
	+ moreover have
	+ "\<guillemotleft>D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) : F g \<star>\<^sub>D F w \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F w'\<guillemotright>"
	+ using w w' \<beta> \<rho>.ide_leg1 \<Phi>_in_hom \<Phi>_components_are_iso hseq_gw preserves_hom
	+ by force
	+ moreover have "\<rho>'.composite_cell (F w) (F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)) =
	+ \<rho>'.composite_cell (F w') (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
	+ proof -
	+ have "\<rho>'.composite_cell (F w') (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) =
	+ (F r \<star>\<^sub>D F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<cdot>\<^sub>D F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
	+ using D.comp_assoc by simp
	+ also have "... =
	+ (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
	+ using w' \<theta>' 2 D.whisker_left D.whisker_right D.comp_assoc by auto
	+ also have "... = (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D
	+ \<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w'))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D
	+ \<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w')) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
	+ proof -
	+ have "(D.inv (\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) =
	+ F r \<star>\<^sub>D \<Phi> (f, w')"
	+ using w' \<Phi>_components_are_iso D.comp_cod_arr C.hseqI' D.hseqI'
	+ C.in_hhom_def C.trg_hcomp' D.comp_inv_arr' C.ide_hcomp
	+ by (metis C.ideD(1) D.hcomp_simps(4) \<Phi>_simps(1) \<Phi>_simps(3-5)
	+ \<rho>'.leg0_simps(3) \<rho>'.base_simps(2,4) \<rho>.ide_leg0 \<rho>.ide_base
	+ \<rho>.leg0_simps(3) hseq_fw)
	+ moreover have "(D.inv (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D \<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') =
	+ F \<rho> \<star>\<^sub>D F w'"
	+ using w' D.comp_inv_arr' \<Phi>_in_hom \<Phi>_components_are_iso D.hseqI'
	+ D.comp_cod_arr hseq_fw
	+ by auto
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D
	+ (\<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D (D.inv (\<Phi> (r, f \<star>\<^sub>C w'))) \<cdot>\<^sub>D
	+ (\<Phi> (r, f \<star>\<^sub>C w')) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D
	+ (\<Phi> (r \<star>\<^sub>C f, w')) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w')) \<cdot>\<^sub>D
	+ D.inv (\<Phi> (g, w'))) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
	+ proof -
	+ have "(D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u)) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') = F r \<star>\<^sub>D F \<theta>'"
	+ using assms(1) \<theta>' \<Phi>_components_are_iso D.comp_cod_arr D.hseqI' hseq_ru
	+ D.comp_inv_arr'
	+ by auto
	+ thus ?thesis
	+ using D.comp_assoc by metis
	+ qed
	+ also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D
	+ (F (r \<star>\<^sub>C \<theta>') \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w'] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w')) \<cdot>\<^sub>D
	+ F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
	+ proof -
	+ have "F (r \<star>\<^sub>C \<theta>') = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>') \<cdot>\<^sub>D D.inv (\<Phi> (r, f \<star>\<^sub>C w'))"
	+ using w' \<theta>' preserves_hcomp C.hseqI' hseq_ru by auto
	+ moreover have "F \<a>\<^sub>C[r, f, w'] =
	+ \<Phi> (r, f \<star>\<^sub>C w') \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w'] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w') \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w'))"
	+ using w' preserves_assoc(1) hseq_fw by force
	+ moreover have
	+ "F (\<rho> \<star>\<^sub>C w') = \<Phi> (r \<star>\<^sub>C f, w') \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w') \<cdot>\<^sub>D D.inv (\<Phi> (g, w'))"
	+ using w' preserves_hcomp C.hseqI' hseq_fw by fastforce
	+ ultimately show ?thesis
	+ using D.comp_assoc by auto
	+ qed
	+ also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F (\<rho>.composite_cell w' \<theta>') \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"
	+ using w' \<theta>' C.comp_assoc hseq_ru hseq_fw C.hseqI' by auto
	+ also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D (F (\<rho>.composite_cell w' \<theta>') \<cdot>\<^sub>D F \<beta>) \<cdot>\<^sub>D \<Phi> (g, w)"
	+ using D.comp_assoc by simp
	+ also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F (\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<beta>) \<cdot>\<^sub>D \<Phi> (g, w)"
	+ proof -
	+ have "F (\<rho>.composite_cell w' \<theta>') \<cdot>\<^sub>D F \<beta> = F (\<rho>.composite_cell w' \<theta>' \<cdot>\<^sub>C \<beta>)"
	+ using w w' \<theta>' \<beta> \<rho>.composite_cell_in_hom
	+ preserves_comp [of "\<rho>.composite_cell w' \<theta>'" \<beta>]
	+ by (metis C.dom_comp C.hcomp_simps(3) C.ide_char C.in_homE C.seqE C.seqI
	+ D.ext D.seqE \<rho>.tab_in_hom(2) is_extensional preserves_reflects_arr)
	+ thus ?thesis by simp
	+ qed
	+ also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D F (\<rho>.composite_cell w \<theta>) \<cdot>\<^sub>D \<Phi> (g, w)"
	+ using eq by simp
	+ also have "... = D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D
	+ F (r \<star>\<^sub>C \<theta>) \<cdot>\<^sub>D F \<a>\<^sub>C[r, f, w] \<cdot>\<^sub>D F (\<rho> \<star>\<^sub>C w) \<cdot>\<^sub>D \<Phi> (g, w)"
	+ using w \<theta> C.comp_assoc hseq_ru hseq_fw C.hseqI' D.comp_assoc by auto
	+ also have "... = ((D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D
	+ \<Phi> (r, u)) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>)) \<cdot>\<^sub>D ((D.inv (\<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D
	+ \<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w))) \<cdot>\<^sub>D
	+ \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D
	+ ((D.inv (\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D
	+ \<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w)) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D \<Phi> (g, w)"
	+ proof -
	+ have "F (r \<star>\<^sub>C \<theta>) = \<Phi> (r, u) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D D.inv (\<Phi> (r, f \<star>\<^sub>C w))"
	+ using w \<theta> preserves_hcomp C.hseqI' hseq_ru by auto
	+ moreover have "F \<a>\<^sub>C[r, f, w] =
	+ \<Phi> (r, f \<star>\<^sub>C w) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (r \<star>\<^sub>C f, w))"
	+ using w preserves_assoc(1) hseq_fw by force
	+ moreover have
	+ "F (\<rho> \<star>\<^sub>C w) = \<Phi> (r \<star>\<^sub>C f, w) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
	+ using w preserves_hcomp C.hseqI' hseq_fw by fastforce
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = (F r \<star>\<^sub>D F \<theta>) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) \<cdot>\<^sub>D \<a>\<^sub>D[F r, F f, F w] \<cdot>\<^sub>D
	+ (D.inv (\<Phi> (r, f)) \<star>\<^sub>D F w) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w)"
	+ proof -
	+ have "(D.inv (\<Phi> (r, u)) \<cdot>\<^sub>D \<Phi> (r, u)) \<cdot>\<^sub>D (F r \<star>\<^sub>D F \<theta>) = F r \<star>\<^sub>D F \<theta>"
	+ using \<theta> \<Phi>_in_hom \<Phi>_components_are_iso D.comp_cod_arr hseq_ru D.hseqI'
	+ D.comp_inv_arr'
	+ by auto
	+ moreover have
	+ "(D.inv (\<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D \<Phi> (r, f \<star>\<^sub>C w)) \<cdot>\<^sub>D (F r \<star>\<^sub>D \<Phi> (f, w)) =
	+ F r \<star>\<^sub>D \<Phi> (f, w)"
	+ using w \<Phi>_components_are_iso D.comp_cod_arr C.hseqI' D.hseqI'
	+ C.in_hhom_def C.trg_hcomp' D.comp_inv_arr' C.ide_hcomp
	+ by (metis C.ideD(1) D.hcomp_simps(4) \<Phi>_simps(1) \<Phi>_simps(3-5)
	+ \<rho>'.leg0_simps(3) \<rho>'.base_simps(2,4) \<rho>.ide_leg0 \<rho>.ide_base
	+ \<rho>.leg0_simps(3) hseq_fw)
	+ moreover have "(D.inv (\<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D \<Phi> (r \<star>\<^sub>C f, w)) \<cdot>\<^sub>D (F \<rho> \<star>\<^sub>D F w) =
	+ F \<rho> \<star>\<^sub>D F w"
	+ using w D.comp_inv_arr' \<Phi>_components_are_iso D.hseqI' D.comp_cod_arr hseq_fw
	+ by simp
	+ moreover have "(F \<rho> \<star>\<^sub>D F w) \<cdot>\<^sub>D D.inv (\<Phi> (g, w)) \<cdot>\<^sub>D \<Phi> (g, w) = F \<rho> \<star>\<^sub>D F w"
	+ using w \<theta> \<Phi>_components_are_iso D.comp_arr_dom D.comp_inv_arr'
	+ hseq_gw D.hseqI'
	+ by simp
	+ ultimately show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ also have "... = \<rho>'.composite_cell (F w) (F \<theta> \<cdot>\<^sub>D \<Phi> (f, w))"
	+ using w \<theta> 1 D.whisker_left D.whisker_right D.comp_assoc by auto
	+ finally show ?thesis by simp
	+ qed
	+ ultimately show ?thesis
	+ using w w' \<theta> \<theta>' \<beta> eq
	+ \<rho>'.T2 [of "F w" "F w'" "F \<theta> \<cdot>\<^sub>D \<Phi> (f, w)" "F u" "F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')"
	+ "D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w)"]
	+ by blast
	+ qed
	+
	+ obtain \<gamma>' where \<gamma>': "\<guillemotleft>\<gamma>' : F w \<Rightarrow>\<^sub>D F w'\<guillemotright> \<and>
	+ D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = F g \<star>\<^sub>D \<gamma>' \<and>
	+ F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>')"
	+ using * by auto
	+ obtain \<gamma> where \<gamma>: "\<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> F \<gamma> = \<gamma>'"
	+ using \<theta> \<theta> w w' \<gamma>' locally_full [of w w' \<gamma>']
	+ by (metis C.hseqI' C.ideD(1) C.src_hcomp' C.vconn_implies_hpar(3)
	+ \<rho>.leg0_simps(2) \<theta>' hseq_fw)
	+ have "\<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
	+ proof -
	+ have "F \<theta> = F (\<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>))"
	+ proof -
	+ have "F \<theta> = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D \<gamma>') \<cdot>\<^sub>D D.inv (\<Phi> (f, w))"
	+ using w' \<theta>' \<gamma>' preserves_hcomp hseq_fw D.comp_assoc D.invert_side_of_triangle
	+ by (metis C.in_homE D.comp_arr_inv' \<Phi>_components_are_iso \<Phi>_simps(5) \<rho>.ide_leg0
	+ \<theta> is_natural_1 w)
	+ also have "... = F \<theta>' \<cdot>\<^sub>D F (f \<star>\<^sub>C \<gamma>)"
	+ using w' D.comp_assoc hseq_fw preserves_hcomp \<Phi>_components_are_iso
	+ D.comp_arr_inv'
	+ by (metis C.hseqI' C.in_homE C.trg_cod \<gamma> \<rho>.leg0_in_hom(2))
	+ also have "... = F (\<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>))"
	+ using \<gamma> \<theta>' hseq_fw C.hseqI' preserves_comp
	+ by (metis C.hcomp_simps(4) C.in_homE C.seqI D.seqE \<rho>.leg0_simps(5) \<theta>
	+ calculation preserves_reflects_arr)
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using \<gamma> \<theta> \<theta>' is_faithful
	+ by (metis (mono_tags, lifting) C.cod_comp C.dom_comp C.hcomp_simps(3)
	+ C.in_homE C.seqE \<rho>.leg0_simps(4) preserves_reflects_arr)
	+ qed
	+ moreover have "\<beta> = g \<star>\<^sub>C \<gamma>"
	+ proof -
	+ have "F \<beta> = F (g \<star>\<^sub>C \<gamma>)"
	+ proof -
	+ have "F \<beta> = \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D \<gamma>') \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
	+ by (metis (no_types) C.in_homE D.comp_arr_inv' D.comp_assoc
	+ \<Phi>_components_are_iso \<Phi>_simps(5) \<beta> \<gamma>' \<rho>.ide_leg1 hseq_gw is_natural_1
	+ naturality w w')
	+ also have "... = F (g \<star>\<^sub>C \<gamma>)"
	+ using w \<gamma> \<gamma>' preserves_hcomp hseq_gw
	+ by (metis C.hseqE C.hseqI' C.in_homE C.seqE \<open>\<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)\<close>
	+ \<rho>.leg1_simps(2) \<rho>.leg1_simps(5) \<rho>.leg1_simps(6) \<theta> hseq_fw)
	+ finally show ?thesis by simp
	+ qed
	+ thus ?thesis
	+ using \<gamma> \<beta> is_faithful
	+ by (metis C.hcomp_simps(3-4) C.in_homE \<rho>.leg1_simps(5-6) preserves_reflects_arr)
	+ qed
	+ ultimately have "\<exists>\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
	+ using \<gamma> by blast
	+ moreover have "\<And>\<gamma>\<^sub>1 \<gamma>\<^sub>2. \<guillemotleft>\<gamma>\<^sub>1 : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma>\<^sub>1 \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>1) \<Longrightarrow>
	+ \<guillemotleft>\<gamma>\<^sub>2 : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma>\<^sub>2 \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>2) \<Longrightarrow> \<gamma>\<^sub>1 = \<gamma>\<^sub>2"
	+ proof -
	+ fix \<gamma>\<^sub>1 \<gamma>\<^sub>2
	+ assume \<gamma>\<^sub>1: "\<guillemotleft>\<gamma>\<^sub>1 : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma>\<^sub>1 \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>1)"
	+ assume \<gamma>\<^sub>2: "\<guillemotleft>\<gamma>\<^sub>2 : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma>\<^sub>2 \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>2)"
	+ have F\<beta>\<^sub>1: "F \<beta> = \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>1) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
	+ using w w' \<beta> hseq_gw \<gamma>\<^sub>1 preserves_hcomp [of g \<gamma>\<^sub>1] \<Phi>_components_are_iso
	+ by auto
	+ have F\<beta>\<^sub>2: "F \<beta> = \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>2) \<cdot>\<^sub>D D.inv (\<Phi> (g, w))"
	+ using w w' \<beta> hseq_gw \<gamma>\<^sub>2 preserves_hcomp [of g \<gamma>\<^sub>2] \<Phi>_components_are_iso
	+ by auto
	+ have "D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = F g \<star>\<^sub>D F \<gamma>\<^sub>1"
	+ proof -
	+ have "F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>1)"
	+ using w w' \<beta> hseq_gw \<gamma>\<^sub>1 F\<beta>\<^sub>1 preserves_hcomp \<Phi>_components_are_iso
	+ D.invert_side_of_triangle D.iso_inv_iso
	+ by (metis C.arrI D.comp_assoc D.inv_inv \<rho>.ide_leg1 preserves_reflects_arr)
	+ thus ?thesis
	+ using w w' \<beta> hseq_gw \<gamma>\<^sub>1 preserves_hcomp \<Phi>_components_are_iso
	+ D.invert_side_of_triangle
	+ by (metis C.arrI D.cod_comp D.seqE D.seqI F\<beta>\<^sub>1 \<rho>.ide_leg1 preserves_arr)
	+ qed
	+ moreover have "D.inv (\<Phi> (g, w')) \<cdot>\<^sub>D F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = F g \<star>\<^sub>D F \<gamma>\<^sub>2"
	+ proof -
	+ have "F \<beta> \<cdot>\<^sub>D \<Phi> (g, w) = \<Phi> (g, w') \<cdot>\<^sub>D (F g \<star>\<^sub>D F \<gamma>\<^sub>2)"
	+ using w w' \<beta> hseq_gw \<gamma>\<^sub>2 F\<beta>\<^sub>2 preserves_hcomp \<Phi>_components_are_iso
	+ D.invert_side_of_triangle D.iso_inv_iso
	+ by (metis C.arrI D.comp_assoc D.inv_inv \<rho>.ide_leg1 preserves_reflects_arr)
	+ thus ?thesis
	+ using w w' \<beta> hseq_gw \<gamma>\<^sub>2 preserves_hcomp \<Phi>_components_are_iso
	+ D.invert_side_of_triangle
	+ by (metis C.arrI D.cod_comp D.seqE D.seqI F\<beta>\<^sub>2 \<rho>.ide_leg1 preserves_arr)
	+ qed
	+ moreover have "F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>1)"
	+ proof -
	+ have "F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = F (\<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>1)) \<cdot>\<^sub>D \<Phi> (f, w)"
	+ using \<gamma>\<^sub>1 by blast
	+ also have "... = (F \<theta>' \<cdot>\<^sub>D F (f \<star>\<^sub>C \<gamma>\<^sub>1)) \<cdot>\<^sub>D \<Phi> (f, w)"
	+ using \<gamma>\<^sub>1 \<theta> by auto
	+ also have
	+ "... = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>1) \<cdot>\<^sub>D D.inv (\<Phi> (f, w))) \<cdot>\<^sub>D \<Phi> (f, w)"
	+ using C.hseqI' \<gamma>\<^sub>1 hseq_fw preserves_hcomp by auto
	+ also have
	+ "... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>1) \<cdot>\<^sub>D D.inv (\<Phi> (f, w)) \<cdot>\<^sub>D \<Phi> (f, w)"
	+ using D.comp_assoc by simp
	+ also have "... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>1) \<cdot>\<^sub>D (F f \<star>\<^sub>D F w)"
	+ by (simp add: D.comp_inv_arr' hseq_fw w)
	+ also have "... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>1)"
	+ using w \<gamma>\<^sub>1 D.whisker_left [of "F f" "F \<gamma>\<^sub>1" "F w"] D.comp_arr_dom by auto
	+ finally show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ moreover have "F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w')) \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>2)"
	+ proof -
	+ have "F \<theta> \<cdot>\<^sub>D \<Phi> (f, w) = F (\<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>\<^sub>2)) \<cdot>\<^sub>D \<Phi> (f, w)"
	+ using \<gamma>\<^sub>2 by blast
	+ also have "... = (F \<theta>' \<cdot>\<^sub>D F (f \<star>\<^sub>C \<gamma>\<^sub>2)) \<cdot>\<^sub>D \<Phi> (f, w)"
	+ using \<gamma>\<^sub>2 \<theta> by auto
	+ also have
	+ "... = (F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>2) \<cdot>\<^sub>D D.inv (\<Phi> (f, w))) \<cdot>\<^sub>D \<Phi> (f, w)"
	+ using C.hseqI' \<gamma>\<^sub>2 hseq_fw preserves_hcomp by auto
	+ also have
	+ "... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>2) \<cdot>\<^sub>D D.inv (\<Phi> (f, w)) \<cdot>\<^sub>D \<Phi> (f, w)"
	+ using D.comp_assoc by simp
	+ also have "... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>2) \<cdot>\<^sub>D (F f \<star>\<^sub>D F w)"
	+ by (simp add: D.comp_inv_arr' hseq_fw w)
	+ also have "... = F \<theta>' \<cdot>\<^sub>D \<Phi> (f, w') \<cdot>\<^sub>D (F f \<star>\<^sub>D F \<gamma>\<^sub>2)"
	+ using w \<gamma>\<^sub>2 D.whisker_left [of "F f" "F \<gamma>\<^sub>2" "F w"] D.comp_arr_dom by auto
	+ finally show ?thesis
	+ using D.comp_assoc by simp
	+ qed
	+ ultimately have "F \<gamma>\<^sub>1 = F \<gamma>\<^sub>2"
	+ using \<gamma>\<^sub>1 \<gamma>\<^sub>2 * by blast
	+ thus "\<gamma>\<^sub>1 = \<gamma>\<^sub>2"
	+ using \<gamma>\<^sub>1 \<gamma>\<^sub>2 is_faithful [of \<gamma>\<^sub>1 \<gamma>\<^sub>2] by auto
	+ qed
	+ ultimately show "\<exists>!\<gamma>. \<guillemotleft>\<gamma> : w \<Rightarrow>\<^sub>C w'\<guillemotright> \<and> \<beta> = g \<star>\<^sub>C \<gamma> \<and> \<theta> = \<theta>' \<cdot>\<^sub>C (f \<star>\<^sub>C \<gamma>)"
	+ by blast
	+ qed
	+ qed
	+ qed
	+ show ?thesis ..
	+ qed
	+
	+ end
	+
	+end
	diff --git a/thys/Bicategory/document/root.bib b/thys/Bicategory/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/document/root.bib
	@@ -0,0 +1,110 @@
	+@article{Category3-AFP,
	+ author = {Eugene W. Stark},
	+ title = {Category Theory with Adjunctions and Limits},
	+ journal = {Archive of Formal Proofs},
	+ month = jun,
	+ year = 2016,
	+ note = {\url{http://isa-afp.org/entries/Category3.shtml}, Formal proof development},
	+ ISSN = {2150-914x},
	+}
	+@article{MonoidalCategory-AFP,
	+ author = {Eugene W. Stark},
	+ title = {Monoidal Categories},
	+ journal = {Archive of Formal Proofs},
	+ month = may,
	+ year = 2017,
	+ note = {\url{http://isa-afp.org/entries/MonoidalCategory.shtml},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}
	+@INPROCEEDINGS{benabou,
	+ author = "J. B{\'{e}}nabou",
	+ title = "Introduction to Bicategories",
	+ booktitle = "Reports of the Midwest Category Seminar",
	+ series = "Lecture Notes in Mathematics",
	+ publisher = "Springer-Verlag",
	+ volume = "47",
	+ year = "1967",
	+ pages = "1-77"
	+}
	+@ARTICLE{carboni-et-al,
	+ author = "A. Carboni and S. Kasangian and R. Street",
	+ title = "Bicategories of Spans and Relations",
	+ journal = "Journal of Pure and Applied Algebra",
	+ volume = "33",
	+ year = "1984",
	+ pages = "259-267",
	+ publisher = "North-Holland"
	+}
	+@misc{nlab-zigzag-diagram,
	+ author = "Mike Shulman",
	+ title = "zigzag identity 1 implies 2",
	+ year = "2010",
	+ note = {\url{https://ncatlab.org/nlab/show/zigzag%20identity%201%20implies%202%20-%20SVG},
	+ [Online; accessed 4-November-2019]}
	+}
	+@misc{nlab-adjoint-equivalence,
	+ author = "{nLab (various contributors)}",
	+ title = "Adjoint Equivalence",
	+ year = "2010",
	+ note = {\url{https://ncatlab.org/nlab/show/adjoint+equivalence},
	+ [Online; accessed 4-November-2019]}
	+}
	+@misc{nlab-equivalence-of-2-categories,
	+ author = "{nLab (various contributors)}",
	+ title = "Equivalence of 2-Categories",
	+ year = "2018",
	+ note = {\url{https://ncatlab.org/nlab/show/equivalence+of+2-categories},
	+ [Online; accessed 4-November-2019]}
	+}
	+@misc{unapologetic-strictification,
	+ author = "John Armstrong",
	+ title = "The ``Strictification'' Theorem",
	+ year = "2007",
	+ note = {\url{https://unapologetic.wordpress.com/2007/07/01/the-strictification-theorem/},
	+ [Online; accessed 4-November-2019]}
	+}
	+@article{street-fibrations-ii,
	+ author = {R. Street},
	+ title = {Fibrations in Bicategories},
	+ journal = {Cahiers de Topologie et G\'{e}om\'{e}trie Diff\'{e}rentielle Cat\'{e}goriques},
	+ volume = {XXI},
	+ number = {2},
	+ year = 1980,
	+ pages = {111--159}
	+}
	+@INPROCEEDINGS{street-fibrations-i,
	+ AUTHOR = {R. H. Street},
	+ TITLE = {Fibrations and {Y}oneda's Lemma in a 2-Category},
	+ BOOKTITLE = {Lecture Notes in Mathematics 420},
	+ PUBLISHER = {Springer-Verlag},
	+ YEAR = {1974},
	+ PAGES = {104-133}
	+}
	+@ARTICLE{cartesian-bicategories-i,
	+ author = {A. Carboni and R. F. C. Walters},
	+ title = {Cartesian Bicategories {I}},
	+ journal = {Journal of Pure and Applied Algebra},
	+ volume = {49},
	+ year = {1987},
	+ pages = {11-32},
	+ publisher = {North-Holland}
	+}
	+@ARTICLE{cartesian-bicategories-ii,
	+ author = {A. Carboni and G. M. Kelly and R. F. C. Walters and R. J. Wood},
	+ title = {Cartesian Bicategories {II}},
	+ journal = {Theory and Applications of Categories},
	+ volume = {19},
	+ number = {6},
	+ year = {2008},
	+ pages = {93--124}
	+}
	+@ARTICLE{carboni-partial-maps,
	+ author = {A. Carboni},
	+ title = {Bicategories of Partial Maps},
	+ journal = {Cahiers de Topologie et G\'{e}om\'{e}trie Diff\'{e}rentielle Cat\'{e}goriques},
	+ volume = {XXVIII},
	+ number = {2},
	+ year = {1987},
	+ pages = {111--126}
	+}
	diff --git a/thys/Bicategory/document/root.tex b/thys/Bicategory/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Bicategory/document/root.tex
	@@ -0,0 +1,346 @@
	+\documentclass[11pt,notitlepage,a4paper]{report}
	+\usepackage{isabelle,isabellesym,eufrak}
	+\usepackage[english]{babel}
	+
	+% For graphics files
	+\usepackage[pdftex]{graphicx}
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+% XYPic package, for drawing commutative diagrams.
	+\input{xy}
	+\xyoption{curve}
	+\xyoption{arrow}
	+\xyoption{matrix}
	+\xyoption{2cell}
	+\xyoption{line}
	+\UseAllTwocells
	+
	+% Even though I stayed within the default boundary in the JEdit buffer,
	+% some proof lines wrap around in the PDF document. To minimize this,
	+% increase the text width a bit from the default.
	+\addtolength\textwidth{60pt}
	+\addtolength\oddsidemargin{-30pt}
	+\addtolength\evensidemargin{-30pt}
	+
	+\begin{document}
	+
	+\title{Bicategories}
	+\author{Eugene W. Stark\\[\medskipamount]
	+ Department of Computer Science\\
	+ Stony Brook University\\
	+ Stony Brook, New York 11794 USA}
	+\maketitle
	+
	+\begin{abstract}
	+Taking as a starting point the author's previous work
	+(\cite{Category3-AFP} \cite{MonoidalCategory-AFP})
	+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 \cite{carboni-et-al}, 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.
	+\end{abstract}
	+
	+\tableofcontents
	+
	+\phantomsection
	+\addcontentsline{toc}{chapter}{Introduction}
	+\chapter*{Introduction}
	+
	+Bicategories, introduced by B\'{e}nabou \cite{benabou}, are a generalization of categories
	+in which the sets of arrows between pairs of objects (\emph{i.e.}~the ``hom-sets'')
	+themselves have the structure of categories. In a typical formulation, the definition of
	+bicategories involves three separate kinds of entities: \emph{objects} (or \emph{$0$-cells}),
	+\emph{arrows} (or \emph{$1$-cells}), and morphisms between arrows (or \emph{$2$-cells}).
	+There are two kinds of composition: \emph{vertical} composition, which composes $2$-cells
	+within a single hom-category, and \emph{horizontal} composition, which composes $2$-cells in
	+``adjacent'' hom-categories ${\rm hom}(A, B)$ and ${\rm hom}(B, C)$.
	+Horizontal composition is required to be functorial with respect to vertical composition;
	+the identification of a $1$-cell with the corresponding identity $2$-cell then leads to the
	+ability to horizontally compose $1$-cells with $2$-cells (\emph{i.e.}~``whiskering'')
	+and to horizontally compose $1$-cells with each other.
	+Each hom-category ${\rm hom}(A, A)$ is further equipped with an \emph{identity} $1$-cell
	+${\rm id}_A$, which serves as a unit for horizontal composition.
	+In a \emph{strict} bicategory, also known as a \emph{$2$-category}, the usual unit and
	+associativity laws for horizontal composition are required to hold exactly,
	+or (as it is said) ``on the nose''.
	+In a general bicategory, these laws are only required to hold ``weakly'';
	+that is, up to a collection of (vertical) isomorphisms that satisfy certain
	+\emph{coherence conditions}.
	+A bicategory, all of whose hom-categories are discrete, is essentially an ordinary category.
	+A bicategory with just one object amounts to a monoidal category whose tensor is given by
	+horizontal composition.
	+Alternatively, we may think of bicategories as a generalization of monoidal categories in
	+which the tensor is permitted to be a partial operation, in analogy to the way in which
	+ordinary categories can be considered as a generalization of monoids.
	+
	+A standard example of a bicategory is \textbf{Cat}, the bicategory whose $0$-cells are
	+categories, whose $1$-cells are functors, and whose $2$-cells are natural transformations.
	+This is in fact a $2$-category; however, as two categories that are related by an equivalence
	+of categories have the same ``categorical'' properties, it is often more sensible to
	+consider constructions on categories as given up to equivalence, rather than up to
	+isomorphism, and this leads to considering \textbf{Cat} as a bicategory and using
	+bicategorical constructions rather than as a $2$-category and using $2$-categorical ones.
	+This is one reason for the importance of bicategories: as Street \cite{street-fibrations-ii} remarks,
	+``In recent years it has become even more obvious that, although the fundamental constructions
	+of set theory are categorical, the fundamental constructions of category theory are bicategorical.''
	+
	+An alternative reason for studying bicategories, which is more aligned with my own
	+personal interests and forms a major reason why I chose to pursue the present project,
	+is that they provide an elegant framework for theories of generalized relations,
	+as has been shown by Carboni, Walters, Street, and others \cite{carboni-et-al}
	+\cite{cartesian-bicategories-i} \cite{cartesian-bicategories-ii} \cite{carboni-partial-maps}.
	+Indeed, the category of sets and relations becomes a bicategory by taking the inclusions
	+between relations as $2$-cells and thereby becomes an exemplar of the notion
	+bicategory of relations which itself is a specialization of the notion of
	+cartesian bicategory \cite{cartesian-bicategories-i} \cite{cartesian-bicategories-ii}.
	+In the study of the semantics of programming languages containing nondeterministic or
	+concurrent constructs, it is natural to consider the meaning of a program in such a language
	+as some kind of relation between inputs and outputs. Ordinary relations can be used for
	+this purpose in simple situations, but they fail to be adequate for the study of higher-order
	+nondeterministic programs or for concurrent programs that engage in interaction with their environment,
	+so some sort of notion of generalized relation is needed. One is therefore led to try to identify
	+some kind of bicategories of generalized relations as framework suitable for defining the
	+semantics of such programs. One expects these to be instances of cartesian bicategories.
	+
	+I attempted for a long time to try to develop a semantic framework for a certain class of
	+interactive concurrent programs along the lines outlined above, but ultimately failed to obtain
	+the kind of comprehensive understanding that I was seeking. The basic idea was to try to
	+regard a program as denoting a kind of generalized machine, expressed as some sort of
	+bimodule or two-sided fibration ({\em cf.}~\cite{street-fibrations-i} \cite{street-fibrations-ii}),
	+to be represented as a certain kind of span in an underlying category of ``maps'',
	+which would correspond to the meanings of deterministic programs.
	+A difficulty with trying to formulate any kind of theory like this is that there quickly gets
	+to be a lot of data and a lot of properties to keep track of, and it was certainly more than
	+I could handle.
	+For example, bicategories have objects, $1$-cells, and $2$-cells, as well as domains, codomains,
	+composition and identities for both the horizontal and vertical structure.
	+In addition, there are unit and associativity isomorphisms for the weak horizontal composition,
	+as well as their associated coherence conditions.
	+Cartesian bicategories are symmetric monoidal bicategories, which means that there is an additional
	+tensor product, which comes with another set of canonical isomorphisms and coherence conditions.
	+Still more canonical morphisms and coherence conditions are associated with the cartesian structure.
	+Even worse, in order to give a proper account of the computational ideas I was hoping to capture,
	+the underlying category of maps would at least have to be regarded as an ordered category,
	+if not a more general $2$-category or bicategory, so the situation starts to become truly daunting.
	+
	+With so much data and so many properties, it is unusual in the literature to find proofs written
	+out in anything approaching complete detail.
	+To the extent that proofs are given, they often involve additional assumptions made purely for
	+convenience and presentational clarity, such as assuming that the bicategories under consideration
	+are strict when actually they are not, and then discharging these assumptions by appeals to informal
	+arguments such as ``the result holds in the general case because we can always replace a non-strict
	+bicategory by an equivalent strict one.''
	+This is perhaps fine if you happen to have finely honed insight, but in my case I am always left
	+wondering if something important hasn't been missed or glossed over, and I don't trust very much
	+my own ability to avoid gross errors if I were to work at the same level of detail as the proofs
	+that I see in the literature.
	+So my real motivation for the present project was to try to see whether a proof assistant
	+would actually be useful in carrying out fully formalized, machine-checkable proofs of some kind
	+of interesting facts about bicategories. I also hoped in the process to develop a better
	+understanding of some concepts that I knew that I hadn't understood very well.
	+
	+The project described in the present article is divided into two main parts.
	+The first part, which comprises Chapter 1, seeks to develop a formalization of the notion of
	+bicategory using Isabelle/HOL and to prove various facts about bicategories that are required
	+for a subsequent application. Additional goals here are:
	+(1) to be able to make as much use as possible of the formalizations previously created for
	+categories \cite{Category3-AFP} and monoidal categories \cite{MonoidalCategory-AFP};
	+(2) to create a plausibly useful framework for future extension; and
	+(3) to better understand some subtleties involved in the definition of bicategory.
	+In this chapter, we give an HOL formalization of bicategories that makes use of and extends the
	+formalization of categories given in \cite{Category3-AFP}. In that previous work, categories
	+were formalized in an ``object-free'' style in terms of a suitably defined associative partial
	+binary operation of composition on a single type. Elements of the type that behave as units
	+for the composition were called ``identities'' and the ``arrows'' were identified as
	+the elements of the type that are composable both on the left and on the right with identities.
	+The identities composable in this way with an arrow were then shown to be uniquely determined,
	+which permitted domain and codomain functions to be defined.
	+This formalization of categories is economical in terms of basic data (only a single partial
	+binary operation is required), but perhaps more importantly, functors and natural transformations
	+need not be defined as structured objects, but instead can be taken to be ordinary functions
	+between types that suitably preserve arrows and composition.
	+
	+In order to carry forward unchanged the framework developed for categories, for the
	+formalization of bicategories we take as a jumping-off point the somewhat offbeat view of
	+a bicategory as a single global category under vertical composition (the arrows are
	+the $2$-cells), which is then equipped with an additional partial binary operation of
	+horizontal composition. This point of view corresponds to thinking of bicategories as
	+generalizations of monoidal categories in which the tensor is allowed to be a partial
	+operation. In a direct generalization of the approach taken for categories,
	+we then show that certain \emph{weak units} with respect to the horizontal composition play
	+the role of $0$-cells (the identities with respect to vertical composition play the role
	+of $1$-cells) and that we can define the \emph{sources} and \emph{targets} of an arrow
	+as the sets of weak units horizontally composable on the right and on the left with it.
	+We then define a notion of weak associativity for the horizontal composition and arrive
	+at the definition of a \emph{prebicategory}, which consists of a (vertical) category equipped
	+with an associative weak (horizontal) composition, subject to the additional assumption
	+that every vertical arrow has a nonempty set of sources and targets with respect to
	+the horizontal composition.
	+We then show that, to obtain from a prebicategory a structure that satisfies a more
	+traditional-looking definition of a bicategory, all that is necessary is to choose
	+arbitrarily a particular representative source and target for each arrow.
	+Moreover, every bicategory determines a prebicategory by simply forgetting the chosen
	+sources and targets.
	+This development clarifies that an \emph{a priori} assignment of source and target objects
	+for each $2$-cell is merely a convenience, rather than an element essential to the notion
	+of bicategory.
	+
	+Additional highlights of Chapter 1 are as follows:
	+\begin{itemize}
	+\item As a result of having formalized bicategories essentially as ``monoidal categories with
	+ partial tensor'', we are able to generalize to bicategories, in a mostly straightforward way,
	+ the proof of the Coherence Theorem we previously gave for monoidal categories in
	+ \cite{MonoidalCategory-AFP}.
	+ We then develop some machinery that enables us to apply the Coherence Theorem to shortcut
	+ certain kinds of reasoning involving canonical isomorphisms.
	+%
	+\item Using the syntactic setup developed for the proof of the Coherence Theorem, we also
	+ give a proof of the Strictness Theorem, which states that every bicategory is biequivalent
	+ to a $2$-category, its so-called ``strictification''.
	+%
	+\item We define the notions of internal equivalence and internal adjunction in a bicategory
	+ and prove a number of basic facts about these notions, including composition of equivalences
	+ and adjunctions, and that every equivalence can be refined to an adjoint equivalence.
	+%
	+\item We formalize the notion of a pseudofunctor between bicategories, generalizing the
	+ notion of a monoidal functor between monoidal categories and we show that pseudofunctors
	+ preserve internal equivalences and adjunctions.
	+%
	+\item We define a sub-class of pseudofunctors which we call \emph{equivalence pseudofunctors}.
	+ Equivalence pseudofunctors are intended to coincide with those pseudofunctors that can
	+ be extended to an equivalence of bicategories, but we do not attempt to give an independent
	+ definition equivalence of bicategories in the present development. Instead, we establish various
	+ properties of equivalence pseudofunctors to provide some confidence that the notion has been
	+ formalized correctly. Besides establishing various preservation results, we prove that,
	+ given an equivalence pseudofunctor, we may obtain one in the converse direction.
	+ For the rest of this article we use the property of two bicategories being connected by an
	+ equivalence pseudofunctor as a surrogate for the property of biequivalence,
	+ leaving for future work a more proper formulation of equivalence of bicategories and a
	+ full verification of the relationship of this notion with equivalence pseudofunctors.
	+\end{itemize}
	+
	+The second part of the project, presented in Chapter 2, is to demonstrate the utility of
	+the framework by giving a formalized proof of a nontrivial theorem about bicategories.
	+For this part, I chose to tackle a theorem of Carboni, Kasangian, and Street
	+(\cite{carboni-et-al}, ``CKS'' for short)
	+which gives axioms that characterize up to equivalence those bicategories whose $1$-cells are
	+spans of arrows in an underlying category with pullbacks and whose $2$-cells are arrows
	+of spans. The original paper is very short (nine pages in total) and the result I planned to
	+formalize (Theorem 4) was given on the sixth page. I thought I had basically understood this result
	+and that the formalization would not take very long to accomplish, but I definitely
	+underestimated both my prior understanding of the result and the amount of auxiliary material
	+that it would be necessary to formalize before I could complete the main proof.
	+Eventually I did complete the formalization, and in the process filled in what seemed to me
	+to be significant omissions in Carboni, Kasangian, and Street's presentation, as well as
	+correcting some errors of a minor nature.
	+
	+Highlights of Chapter 2 are the following:
	+\begin{itemize}
	+\item A formalization of the notion of a category with chosen pullbacks, a proof that
	+ this formalization is in agreement with the general definition of limits we gave
	+ previously in \cite{Category3-AFP}, and the development of some basic properties
	+ of a category with pullbacks.
	+%
	+\item A construction, given a category $C$ with chosen pullbacks, of the ``span bicategory''
	+ ${\rm Span}(C)$, whose objects are those of the given category, whose $1$-cells are spans
	+ of arrows of $C$, and whose $2$-cells are arrows of spans.
	+ We characterize the maps (the \emph{i.e.}~left adjoints) in ${\rm Span}(C)$ as
	+ exactly those spans whose ``input leg'' is invertible.
	+%
	+\item A formalization of the notion of \emph{tabulation} of a $1$-cell in a bicategory
	+ and a development of some of its properties. Tabulations are a kind of bicategorical
	+ limit introduced by CKS, which can be used to define a kind of biuniversal way of factoring
	+ a $1$-cell up to isomorphism as the horizontal composition of a map and the adjoint of
	+ a map.
	+%
	+\item A formalization of \emph{bicategories of spans}, which are bicategories that satisfy
	+ three axioms introduced in CKS. We give a formal proof of CKS Theorem 4,
	+ which characterizes the bicategories of spans as those bicategories that are biequivalent
	+ to a bicategory ${\rm Span}(C)$ for some category $C$ with pullbacks.
	+ One direction of the proof shows that if $C$ is a category with pullbacks,
	+ then ${\rm Span}(C)$ satisfies the axioms for a bicategory of spans.
	+ Moreover, we show that the notion ``bicategory of spans'' is preserved under equivalence
	+ of bicategories, so that in fact any bicategory biequivalent to one of the form ${\rm Span}(C)$
	+ is a bicategory of spans.
	+ Conversely, we show that if $B$ is a bicategory of spans, then $B$ is biequivalent
	+ to ${\rm Span}({\rm Maps}(B))$, where ${\rm Maps}(B)$ is the so-called \emph{classifying category}
	+ of the maps in $B$, which has as objects those of $B$ and as arrows the isomorphism classes
	+ of maps in $B$.
	+
	+ In order to formalize the proof of this result, it was necessary to develop a number of
	+ details not mentioned by CKS, including ways of composing tabulations vertically and
	+ horizontally, and spelling out a way to choose pullbacks in ${\rm Maps}(B)$ so that
	+ the tupling of arrows of ${\rm Maps}(B)$ obtained using the chosen pullbacks agrees
	+ with that obtained through horizontal composition of tabulations.
	+ These details were required in order to give the definition of the compositor for an equivalence
	+ pseudofunctor ${\rm SPN}$ from $B$ to ${\rm Span}({\rm Maps}(B))$ and establish the
	+ necessary coherence conditions.
	+\end{itemize}
	+
	+In the end, I think it can be concluded that Isabelle/HOL can be used with benefit to formalize
	+proofs about bicategories. It is certainly very helpful for keeping track of the data
	+involved and the proof obligations required. For example, in the formalization given here,
	+a total of 99 separate subgoals are involved in proving that a given set of data constitutes
	+a bicategory (only 7 subgoals are required for an ordinary category)
	+and another 29 subgoals must be proved in order to establish a pseudofunctor between two
	+bicategories (only 5 additional subgoals are required for an ordinary functor),
	+but the proof assistant assumes the burden of keeping track of these proof obligations and
	+presenting them to the human user in a structured, understandable fashion.
	+On the other hand, some of the results proved here still required some lengthy equational
	+``diagram chases'' for which the proof assistant (at least so far) didn't provide that much help
	+(aside from checking their correctness).
	+An exception to this was in the case of equational reasoning about expressions constructed
	+purely of canonical isomorphisms, which our formulation of the Coherence Theorem permitted
	+to be carried out automatically by the simplifier.
	+It seems likely, though, that there is still room for more general procedures to be developed
	+in order to allow other currently lengthy chains of equational reasoning to be carried out
	+automatically.
	+
	+\phantomsection
	+\addcontentsline{toc}{chapter}{Preliminaries}
	+\chapter*{Preliminaries}
	+
	+\input{ConcreteCategory.tex}
	+\input{IsomorphismClass.tex}
	+
	+\chapter{Bicategories}
	+
	+\input{Prebicategory.tex}
	+\input{Bicategory.tex}
	+\input{Coherence.tex}
	+\input{CanonicalIsos.tex}
	+\input{Subbicategory.tex}
	+\input{InternalEquivalence.tex}
	+\input{Pseudofunctor.tex}
	+\input{Strictness.tex}
	+\input{InternalAdjunction.tex}
	+
	+\chapter{Bicategories of Spans}
	+
	+\input{CategoryWithPullbacks.tex}
	+\input{SpanBicategory.tex}
	+\input{Tabulation.tex}
	+\input{BicategoryOfSpans.tex}
	+
	+\phantomsection
	+\addcontentsline{toc}{chapter}{Bibliography}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	diff --git a/thys/Bicategory/document/triangle_right_implies_left.png b/thys/Bicategory/document/triangle_right_implies_left.png
	new file mode 100644
	index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..e9d3fe9fe8a46f76a951b5c38b7f89a50256cd00
	GIT binary patch
	literal 41954
	zc%1CK^;cG1wEn$m5F{i8Y3UY01!)8c>6AuL2?^;IM5L7xR7$!_r8@<bZY2dl8U$&4
	z=YGyPf5Q9QmuEaf2i)BEUTe*HU7u_1wGGoyQ@nVA_5y++7nSbHYas}>DuQ5i;N!w~
	zRzmDA!XLPnDvIRKlH!!hTJ&#4uR8MLl=gu\|WUF$dk&ofp6luD&4z-_mdEtKv1;q
	z{h0uQFd<6vGCH19>(gEaI!g<9+gn8MIr-=KgN%a0bMn%I2shs;>cw;m@\|Qt(md&
	z>Q!<7$Xhic-&UMv6kn4aBwo$4sL;d0#8UC4(b2^}z^Pwp`AvDUFrlwh\|FBD%(bu=a
	zk7hjjPW=1p@~~w{rRD$k>yn572HF374gR4?BK_aL+gO;({_iWYUIY^S?{{OUaM}Ow
	z7w`YS7yrK(\|GyXi\|M_B}B{n7&_%cyaR+e>l7hN4MeO2qWwi`rB7SpnTPmca<=<N$a
	z>Wq8uMYs3&mpYh^$!ltALc_vjyuHN)aAQ)11ewuSr3i`e(a#y{=(I=3>~T=>8a&f0
	zzCZunu?c=<Ncev~JxloE!-vSTg#}Afq6{hKknkc_`QxtU;86IQxP0{*DG_BD(MoEE
	zinP_??(S}x-8g^nix(f1;@Fdf9}(M*6?GHJ$;+=3UDEwbOe=SXr7izeJ+^#E\|M)m{
	zY5nenhkeOm+uKfyi;IHjHM!%46$q)i%H4jYA\|{cgc7A?XR}#8cn}jGADk-TgN~6
	z{JFd?g`x%7W#SSGS*y8>jEsRiO;#kk1)Vtbhlycf1Z(&)fphreTFFgKQmU$\|bE~W2
	zVs5M3LGjvm@8Z\|jJu4RGcdq+ad9!FVPUz}U6!nMB4D0hPxt~^m4OAMB=k}QNLr?
	z+y19C%*@PA?(V;ExH#a\|MaDIkitm4x_4U1NY+^FMx!H$~u5<Emk(ON^W~NgMuKKQx
	zr5JzCl8$6*YU;{RHX(zgZ)nSNytdBH5b761S{4?}EUc_#R8%1_@Y}wJq&qu1ch%Gs
	zw6rc&R8(jf7=(WPsu~\|3-`v`YDPlJke7{)X?07#r!2ZdT!CE)FPqw2Mo_w!-5f>LX
	zc;-(*MYYhEBCb(5N)-M(AS)}2>Gtg_2V1j>R#sOR78YJ7Cr5U@Vr1pvA^iROHzz;8
	zf}S1~lCG8_CMYBn2y+X?LqbPKcirI!4d4Aw(uI1(1MnF)Z{7Of_2-wu&e73c@`\|I_
	z<0~)jSl!%@fobV%&e~ny*sySP>?f4LW#i{3e$<!TGFqtbyfG#6qt>m^II1ov2$O<>
	z;x7G{CQA#8z-W5$44;F\|mGM$WTq2rhol$gjd!Ln5Rpk#hr!C;;r>DMDZ)}UQvarWX
	z&AOm&o#35}8@wsY%gdL<6dpcgN0\|8dF2XDY9C<\|1iUfW9DD1tr5{Q9?oBpUjwXCd6
	zaH5YXEp^zeyT4!2)3bW7KaNA4l#%gOd%HZ$$ZhJz2-}f73?3eyiHV8381*!ql`w~D
	zYHE3AO^uqq{w06ptfUWkO)<4-vB)zDWJs}%>pjVuPIn1U&(6qbX^*7>v`bATZr;4v
	z+\|q*aWa^X5&(5g9B17Tpwj=m&-n_}v&L#f(^{e^Ahao?H7$e!4LRwl{uVZ6_a@EsV
	zL`A7IH8n%S!&\|qS{zZTKbR8QHkM-tF8c9h><QYtj<=)C5jqpPvQ~x7tcl_>jtA`I4
	z=31T~?vI-}ua0nK<>W{n%#PZMtgo+U)ml0_zGA=kE?qNI;qgQnGcO-scAuHQf1^$`
	zR8E$6YJF_%F1JTMa7>`Z`A?+Bx7S^=eD;0s;a&eS9(>etU<m0+j#ulwE1d)YMeE
	z*mGZRwT#(-fAlgkGS%)Iv?V5WA+TB!)FEH8??g~(<xMmN1h{U^nA\|rXCB-5iBV)m3
	z*SQE~cTF%q3l`d@Ku%SaXyNBiv_-SBu3A}HrRU}0U%q^K;PG\|j+0<vdwviDEx787u
	z=eQRK(q*u&KbfL{7K+We6)L_(^L}s76+h@1=$CBqF9ow&(#w~_HojLq=uedZy^1++
	zs80G=S0@hZjiIlve@8~4hhp1s)N8jmq&*n$H7rDpQOviMcN4aIkg->?l#KXDj
	zU7u`i5~X6n?MA(xB{8HS%?M@9HKiWVY=5>?#L\|x^n9&wwIUJP{7CX^1zob@x1@8
	z6Tthsu8m#P)6=V%<=FgD^L%d392*B`e((42-Me?2;WwR651qfh6Csp)Nt\|%5pVpK{
	zM3JAKjzEKT4Q48mk&-@Be8q6qKMQ4sR!VeqbXirEVx~gW02GUXk&()Lox!W{@bK3u
	zDN!(WT+h@&!ChUigM@9*wP2y^HsAKr^KhG)nBg`)l4n%K4;_OD2na;did^_?H!d1U
	zObg1^qCpVEw0-UM5ItU$!t>x@?B\|RMj`+&T%2\|CM4zt<UDNu@!T0T$aCnFTKA3c
	zM!%ER>FH_CN<LU!(Ta~Bci_`LIZVI9QILTS>VVmITKq!B6<G+MXzH^e5=kS3iG@cz
	z(o4QJGNN;Ma?;k{Pr{*={8}sr>OD!&0`m>ONx?xy%)58o7ti>)xnpUYboQ+tJ$ld;
	zO>fZTF9GI~6)^ij4lj~koC>DvMMOk\|X{zPRkdTFe4\|3ao{<M92e<M5K-;j!c#Z0\|d
	zlF)+?)0}nt$qF3dM}6&urH$Nf#`)g(7cR7dxb6JumtvKWFgZSe4\|nqLP%JfV071V%
	zO-()dJ<`z7u-fYnyR57%DFsFF$4C8=H;xMxqG)MuJ-s^Pvn4@9BPd-ea{#R-=(eg;
	zzuUuu_LiYjC{2=v?&fI({fqc`3Vws*puW)$axbA<UTNp5o&EMEUeI}&XzERH@7?v7
	zoLdHlh9BHFrUY-?P=w+\|7ce7(<?(e\|=uc(!`wSA^S0!x1qN2{ykWP^82JijWJk3nO
	zhhJ$XCMPd1ey*sjQ~>X7ZEc;Kn`>^(eAb&N@Sr=Et=efG^V!gEthSJgZ6o>GLQfa(
	zj^t^!nfHl+V*C61PgFaz!pM;L=!ZVbDIR6^lh>}>jj0MOC%k<d2Fr$tfaemezKgki
	zfsk-#+GEzDBb?Inc#rGZ5XXXcj%rJmQrtkc3iWfbSuh)Pe!o{fk-LAN7Cw\|9&HtE-
	zT\|KpESo+b)-;E^EC$tKYG=Z6luU0qSp}qt!Z9Dq2?0k0Yw)pE;YkNC(ikO@1)=Yzt
	z%P&>e^@4lCLy&Ij<b?QCUsOzXMf-CZEdWt&n+#zuxJbUpq?fv7VtQ8@bNYP#rbs
	z8@lQZJ_lL<#v16d=KYeCWNfm@3?bH>4xyP-_R(gBEI*mCsVgj0u8qVI!Cbv#@X+
	z_2T8DqodaIvlAS3b@dj\|*jhCN+s@9;qCJ$XwdvoP<9vG<xvZsSM$uMETpX)$qpu-M
	zT&AFP4@Jw&%z4d$e!fo7`}gnXe*R>IBBdK~vl~bcM5OUAUbJS8orDnwkDCRUaN~j9
	zQatQW<pYAb+;L=9?Ic4Z>09l34y{Ke>hOaTTzTcx`03N9S%1Ft^jOXpSo$9=QGd`a
	z)En\|xpPOT{pZe52=P&TDz~290+9N0>CB^j\|l!@A5x;Fcx%fx59L`0fK%r(!nL`GIN
	zNYHsfzGY-&uf`\|suaxcQ`!wS2MPM7PvSt`;Y;3K6H@>Iw*nPGgy)@%@U^0Jt^vC<?
	ziGR%ZDn~+><vz;Qk$lz^$F;HI7mWUgGRw=gun-u}20*PFOyfX^Ek+A;(IO1ax%d9U
	zw\|Q5R8-VJp}v4cOAt;gtb@Toe$NAQ+3=pPUjFbKn&}df\|#zdvtO8*nURfSzn5y4
	z<hC)TYtZOh<Mexo?L&37!SXUC0\|USPM48O?_BJVCRo0&Z{nAvyfOFq@5I\|h#v-Y)\|
	z-cCQ=+`-4e#YR;Z+}6e@5&WE-oYuOnMjoK42~H_>4UN}xzkabN%+ECV5DpFwib=c#
	zG5mctJTzqRr66>1(aPfVaA(K^7MRC=x>i@9X)+-pF_ELlwBdePc{v$^4@BCUo915-
	z*I)6dp8?~Upm{Tr60m6&aHjisBrj&q$$X;B0-e7Xzy{1BBD$WZhviNy1I!k!!30AM
	z11&8wK(FRFoG(ExE<jOxmy`h64RN;S0(x0Y*Sg6L=iJNwvo)Cc(&=E+BqgOyUFz)W
	zbkiO)$PjRCw8qDW-<mE`a;PRXYs3JX>*^>ghwo+DMqX5\|DecI(6A?@+VtaSIy{}Kr
	zpwj;B_Q_Tg-AIk3RH(5$A?h^l~0U8{3WKG4mRfNdx<ht<{J)&KM(100$p~x\|vv6
	z<+k_s;u{~`xKYI\|<gJ)Fh);LJfx>pYgbyL56}9I~7WYtlv}LBH#bToEH-0%*5hj&l
	z;@!J<7a0BaVqV9^J=ja*VP=-u-rbGuS%c=IBsn@gJ;g?3XB++8jtv35cwR7>)VWjo
	zpKMf7pP!\|OdjyL<nZie~eSCai$`U9)5LvVp8Ggi0P-a6&?d\|P@OPkK8I2qq9EiU4l
	z`5$F#01{z5Gk0*{2eeqT`qT~T3GWZa?RH)xU\|h}g$$nDn_}<EBVPcuXwAlRd{#xsE
	zJd$8o5{rN5XRQ<E4{$!;hw)sYr@zd73CJs4w7os\|=BTcwW=xswDEIFW9?ATPD#tVp
	z9UZHIWm6dJ6)AsXAec1QO\|-IneSNW`6fzTCYzH%5Akx*\|``kPRY<J}4@#)1}Nf8vy
	zT31I4FFJ&}T1)sIYB)JN$E2ojO_a+$+Ts(vns(c(we{g*rTrw!y_EHl{5U7TI_`tZ
	z2kVopBL%uDtEcUqo!oy-0R$r`23C8Z!f}L!g`wOYbP\|0?Pfu4ZRZ&*H1cbwZkeUXZ
	zx#@agA?UkS(jmMF5pma1^vz~}}1qRK`(8LI+5FnD<5GE5}y~N>c5IuY<DypF`
	z1x-E!PJe#g`v9XFl9P_U&J5XWiGq%fCwq5v5OC-P2#C^+N$^5KfQ=hH{R>-L0w\|On
	z^D;0n$m;0C_w~#9PI9\|>Xj+Kx#ujA^y}Mu{chrPP5}Y+r0X`ZL^+5OH9PP%*tJ;
	zsHwX!AGOyvG-S^<+?e(Ks2s`drMax=TX70@%q7aV^(BTC6KUz_xWkdQ)*Z(o3-JR7
	zX$61kr9Ygl_tK`N_g<e6(hHZGUtZ?Gaez*z>PwX{T9W)pB6Z4iPt#_+BqifRMpIK0
	zA`Jm3qEFJy+&taf#)b<a?Toyv{cFDpz%=Wn04VQ6YbJECD3L%lSzGIFNS?eCvCHC!
	z-CrB0u5_Gr*i+wvc@BoTApkZTS{Cy={-oC5GB~IS{ep{I5u~f}_;KF#m$RdzpQj?9
	zCEajLMWi9#kfGY#F{^Ix+1cJ+HgGv#pz%=lf{NtHx^P2O(QtNk^-ZoM2e?!gR&2H8
	zo6HDla!QKZ?pss8ecj(Ses>hz`3)=N5hkK5H(yiA^+ImR=DG<+T{yHR`XV^^E~`lb
	z5oLe!Emru&<Yd>~nxUbgEUtbS6TgQ<jo(Qn1vi73YiL3c=tIKj*~vk+iCIBJef{nE
	zjjGu<w3AQ<wXa{l*2tE8;OhEmAXAaVhW{Tdo7>+R$R?P`{MWa_Mdp;Rlae?mrlyor
	zUao#(%2&uFgUHNvk1rxJQfKe1eP27?pHZt5=q77+N1*An;=bSCmn4kJDXplZ{Y_ti
	zRU6u4&o%1M3@W=40LP<`(WfYBNNc_1~TV%y>Ixm40hVGU`R_uR>%D2Ix_`K$&3h
	zon25+;~hgTA#g;Dq`HHH!;9#hoi4^T>nAKM+4(i)*SPY5^pU-amkp8-;LTSCK1\|fO
	zaH!t9SMGo2eR}$*\|M8D%=Y->AKBLO^8kc3%k143BAB+_lZtv_2cKf`4_YM;YkBBgA
	z=~2oYG+$^B1ECgz$s`4o_TFFBecxZIm0xDjhP$`%of;wq>X3VM9Tm#`wLS;@;M5n9
	z!^JrDGOO-b+x?@BjSc6yW(*kQTyr26N&rP&)Zej{$D{_Kq7Vf7EjTVt`^BpVc6Jfa
	zjtBzF-lB{-2T1C<)o{RskNJkzFbE)^xxGEBC&0nT$S7ITj~2arSU#aAQ`hl>%s(Bx
	zLgSLS$7XO?7y%S0v5HFX1$s!qw;+m2o0~HMuo=kY^_ZJmnghiEbUeo)q?!Y$l?AcH
	zB4>?x\|2`syRgpzdkQ97`{1DKM~zG2`f{;mCN8{RbhbOEGhQaR0%q%(`_s)a;(2g
	ziDnCn-En0V6+vlfj77!8h0`K}A\|f5&po3)=a>2pDoV0u8MYOqKq$qLM)YNz`CFpPe
	z&P~(nT^smpr\|<jc+YRK\|E2(pu?(S{{{Tr9a$<evW)8YP_Ce<\|5^=Eq<L7<!TPP{MC
	z(?{iN=gPv0z?cqqdj$$dm#O7Cz\|rP_(E#roSPn=`g2U~`OI\|SHd!Fr&528NGn5z`W
	zP9x!c9hn1duYaqN(9+!Ae0Y3p3E{?\|!COS(6+={V@\|Dc<+oNoPgO9J%+;F%8lJ*if
	zwsm%v5et_nkIMS5)W0JVDqaHwlFeJ;M+@NM;U1oo1bj`Pd_N%x;34)us>whUODo4S
	z3_m^``n>)3FS<+6%dIq4YW51k>j(HYT8Sg8tKW6rN%)8w8ymlV`<B4b(J^z4DD{>L
	zZbwJQ%2=^cwnAd)@!t(X1UNiso%KSbl9CbuH2O=(>D6_05B66_M\|Z_;ii@kTCcWV^
	z3W2CK8O>MuKA\|xHa=J1}-6B5a$-x%Mvkxq~d_<~5k^i$><-F8GdGqGYbiiPRGp_;_
	z^NOcS%2y=3DWJ4~R5\|7r7PN\|cHlRbJAjvZe2#`GJjFfSAue99iP<!0LYf?*b>(;H6
	z?^ObT=f)eQXq=r}Tnq*@vY)AcYn^}~aG?g}mM`\|\|X3}Mz+xki9a8ov(AKM\|#aG9^;
	z<E?a3S\|A5wA-Kd>ID2=XrP8(XU%z=1vbVQqYsByC=Z8`~<WzIu0o>tE6%~~>n2&O&
	zdD+utsediNhZF(F#oOJzFnN0oJ1ba9XM_P3qO@sV\|zcA>tJ5?X+v`3}vg-A84X$
	z{Y?JOoewY\|L}UKwc}R{JHaj)H@#_$K$Ei>GT5Xs2vmq;k2^H#OdP7WnJeYyg+SXPM
	zQ`6C>o6Pu)&Uvz<z1<wpM5AzYXt->(4-!WN6(1(D4wgMwabHWTmC)g8<Jn&$nEck!
	zQA%j&MVuo?yf1K(FJ8Qu`1t6RrW<alaSi6&tNiN;3fRnCs}7t?aJ}3-6Q$oDm{r
	zzDG~5JI?$tUv+@DMx7k6l9n;x6qTJa82+7r=epdKdd2r~5\|nYw%*+5<4aUSW_BeTk
	zbmHxFT<hF7fO(>!j)9eT@!\|`xaoKUNUcHJ9F+b?#OFS`;&B)eP+01{c3y<;&0?~r{
	z_4V!Zg#}C1x7TnSo6af+{X!sl5%B00<?Y?}qobqq1q4HssVCzK2e<X3@ZDv59UyuQ
	zK!aR=ObYqEhj7=-)YLRjw~%Ucx=ug8Sz\|UuHg@a4n5dshz?3LKxg%oNY@y-Fa$kzV
	z=;g>)ukeshwxi0G55h?*3+&7RL7qb%_~bat0Mt5ka)clB3\|7_>ayNt+bT^HP?>@GG
	zfB@1Aw6p_G!0k;8Y7dMr?d&XczV+{1{mp\|_TZ*xz-b9R3p@f_Y9qxqdVvV(9WCh+d
	zNi?MYyD<u#&;>&41eFEDw\|wyB$B+6RcX`L@S{xXqjq~jX>(?8Pe!Z`_qC#}~)WwC8
	z&bn3Y@e!nG``Jc%WV=s%Ydh$6TTjmgR>f%S?JjN6H>0b)pbXB=&ggd6Z3zi4nN%SN
	z)p?_~=ABh7nj1\|<)tyivK0r4$dWLJ}l(!y?e#(OVXs+pgouf4DRY#=kMWgN}e+7
	zUaF*b?<~Q@@rj8$3v>(TmX}\|Gw6{T}(TUoldpwj9B-yfevbPu)+KQngdfmUSGH`2+
	zwn2G&dV4PvSIx-6EN=h(?$\|axJ-s5Ot(zLFt)&&zFL^>F{ku%3oJ@B*OwJ7;@;QjH
	zyX^ith;(Q~#Pfs%N\|Y>2N%<BiYUk$6-;COBf~ITT)X<eX53i`K49U!7Mdm<#5+qH(
	zy%WKR-z3Uw_rpX\|Z+o#c=tC&67B4XnEokMO+pYE7VQFn`)u?lS0&=gnwfqx6EGima
	z!!r}`?`&BiB<iv-E+G{!q9JCh+Wo?N*7N7Zq_=OC4vcFy8I_}3haO+o%KIRn$EjGY
	zY=sYNNCViv_j@?E$F;HWsrl1\|c7og9d-#B0U6GfC4Ltu92K+mJJX%1hrLFC}x1#AT
	zdoewb5RvfSGw0Y=N4L!oEb`;blF$gMp+B`ATg2(E$4=HDcSMzym7Lt%v24$dgdyu8
	z&p@9lOncj5RgwQTA$xk1OP6=\|erwks%=nOEV?<C3bjEXOpYLtKD{&zM28V=j*Nzs$
	z^ohBxVoT3xltU6Nrx#9>^b60(U`a\|!x\|=DxSj3tvc25@vi(E@bmsqvkA\|Ie75Hz7B
	zWfp)80!XdY&_(c;SHtA{#*iKN0B\|=CbwRH?OK!EOcqgbFj;Wv)dP3c?&yPL62`Z
	z&RCgv1w!q7xv%eiuvt9ehk3{<7~^sl`)KX+&{`=Ci`)fDspA#atel(-Fv7!y2!Zq6
	zEePe$VHUAoJJx<RixJlOR9X2Zr`x!}TX#^*67uZY9=CIgOO!$zqgufwRWE\|OO1dI~
	zT>ShB($WYvrbj)?(Tj#_nc&JcLq8TN&gZj2Xeq6DoQ2&yJvr\|2~B`NfF`UR%gWv
	z{I@z;nVB)}+_{ry_%Wwt{n#SUjZIis`_0cNMkxlg8zK4w8(jhhR2=&w5paGRNtb&`
	zT*08PAK^^<E;ja(jkEm@L#e<Ghab;MO9fC90d@Ud^\|w?t`6e0UX_06KiEvQ-kvvVg
	zm_L`=ZaIq?SnqF6(`jmI-gI6Fwy&GGtwN-_XxxO2jM$27`RQak1ru-;6yUPM6w0fq
	z5kqp!Voo}KTz}=ZCn;#VoUiX~FntaY(%zqd2>^mJ5MMs^-m?x<H<Xo=i%CoCZ<c?R
	zD(QCt$unz`6zELzbT{zQ)1&IO6)ELddR-YHyY=@m~1-J4`J_jG2$`BFJ}n(egXM
	zDhQaEoF-jC`?b619(-IJ*5~^d@$m2(QX{IWZd\|9mh#G3nc8<$(U)jfxa;ByXK\|w(j
	zO=(\|r725}EB_$<?Fgu^tI?ZDu>3%1Fcis8_(IvrvbSa5cBc)\|zFi>0p4X5f&6zBr^
	zZ~}w^?H3drj8jSE$Kdqq$tW%6z{12F$W>?b^zvf9cI^@bw8Qh0tzHS^;{<)v7Kp*<
	ztslVQo~I7?-izKTzW-Un*qHZ32T$_zBSnqPzE=i0i>AJ@fnhtNakv+0w=GZm97Biy
	z?<@e0^J=~^b2St(L^l{+)I~Z`^R1bNij*}-qA>{xI56Dm>gq4v^zDCD-QLH>B_\|W5
	zyUO%8(G7mc+TM0LJzgsXgI&5X1#gax;1dz)tp8YKcp>6@=;XRFMfvva+lrUrP*jJ&
	z`WW&22EEO}p@CtV;jdnG;W7F?3%N_0b&3#i{boiD)Za^!yohW1!y4g^1xc4REl9
	zdBy`FAt40e;NWOTc@DCM-lHpjplBoMY;2r7gLx&Jj(9y-FS0rgi`sY8@2#bw2!o};
	z!_YNN-6ij9p4;X&k3K{0R541\|@0_ml$fjS1up0I2pmpG~@?oR<#(l61bVvNj_e#D$
	zYmnNqcP)4~7!s6U=oae96zl!0+iGkBtF#s$-)j2D0L1%vtmyLb!Ir?9+uU=$0$UKg
	zJV>n>u*T?abwx#mxt$#$SRg7wN!P3\|0FvU$kUFi7a6$Sbeb5yx@@1p0z}DOn\|Kdw<
	zg`WWI=sw=aoVtoioLjcbEn4E_U(%gJWbr3qLcQGOsizI<l1JEE^?!&V-w62~yQ23E
	zAi+?IjX~}bd_2IkxV+ppJgoh0sM*`ZD}<E$p_SEL!YUxFCgakLiE>tC8k_xTr4KF<
	z4bzj9+Yp_Af-;A?BBP@_rOtOqkmjcIeE}Q!Q2P{>Xu%KMA%S6mz\|=`VyAQu61%Cai
	zT3u5!51o&C4}^xslTC5dW}(%kU0ttB9?oGUy?>AH>+\|#T;}a4-FwekR7\|`*Pvbp8+
	zm-qJV+emy##>~e@>d$Kw7T!QDd)XJo%4pk?DZbIQl;AR2wuRt0bT{tX`x}{{DFz=O
	z-g_&a3T0#P*_QIhj~@_Q@u{h)4HXLO^Gx--OrGv-Y\|pm=slAAcBZnr?\|ImDuoBIMJ
	zmGI=Wo3YxPVioq2*HqIa>4DABy=b5&?RgD$cnt&tY3P6WrI)}hJ+n1d=CVYpce#R?
	z%ppo1Zq{v?TUrK{HXdI9-fV{G_it\|tvS2wB3VIunn3y;;I$8lhmyChIK`>1znOI{K
	zliZoON{gpBQCCYV_EYT<^kdd`J89@eyzH?Ta~kT`_RQt3y!qN3Y@lwcnyuCH{X5-q
	zf7(l^Wx%O&^A=2i$SXkYEtOBclU}(Jxwq$<-#\|f5{v2v$zKujGxS>G;4U_BZ_C&PT
	z@pIKu(EV4I@ej3\|u@CT1Pfrm9UdeZ02iOq`o-da<ICn4`puc$9evNsVs=*Q\|cU#l5
	zp^uBAyV2U+O#m;GR#Q`Z8~tJMaT)xiy0(^uogEiqP*<vi55?QgZ_U9pNv\|!TIA20u
	zg#e4~^LM>vp(CPqPi`zh1$5l>mB4QA_Jm2r<2_;IK>kd%SUVjn0pS4Qb*YB\|p@S
	z<F68bUy^-iwGw~7J!YPvJT+b&Ox9^_j1NExy$FzoLx_}uP\|mJfGxQK%HS%>pOHeRC
	zZymU;jWL5EK}mG\|JDdH-%)})9moMClWT+`Jk_a0c8$s&p>$zQtoIMzw#Z79$G9_(C
	z3)oJ\|QQ$5z2o!$QmkurMxwk_0t1pF6TwEM=p*oMP^RyHKU@WKeQ!n4$ZjQ&$_GpdA
	z$5VjN%\|S0hd%tBF5420t(0$OOVou\|KvT=jgumW59caYxFz5ccF(pNCsEz{HVWMpJ$
	zaS=1z&O5-7E?mVYm$R_3;df?KR^F5<dha1cI78LU`upOY`#Z69vo^3=C+%!_bZ$
	zDK^qyUj8sLENJ3dwEO1\|s^b$A28)Y}(wT$JfURKOPEJl5S@UYOiAhPJgw*^@Y-~6J
	zO{dq4O-!uKJkpEy<w>zSw&;g*?xDAP$e?h3cD?$!KKT)!grp1pns!nLfj1L?f=1k(
	z7X&&hZrZ3\|jsMoMJ5Uz\|1w}I~13f6ufKa>5$by*b(}<`j91Sr{V=nNSYQGav_st(+
	zqlNmcw{Ks8nd2W0DiakIg@oMcv(=FM*km4`+\|pdOf`^N%<?CBvO&uK+{NZo8tv4{G
	zq@?!NC&^!uFm^&s30kybH+Y27BykFei_`u2^-Va><x-ni4c)l!Q%#Ze?^PuK4!fkX
	zaM=+9Lqm(B-6ex+rw?lVckD;Hr!jQ71<B~XoS&ZqXP@`}EF86U{XK*u7edq$OhBG>
	z>(uHtn#f)SoMJ)JiDQsPq#?YNKlv^S4y3!hFRxEx2`~a684WV7vi5#)X-SFMH$}{C
	zucCoZF=^%H&04Fyl\|f3$km@JZTA5{TWJyT&a0{4En8&OiHLP1_`GYQ}Utcc=zkJCm
	zBC=oOgPv{3(r{k<5+n9jx$nPjS$E%>iGt#2o0_792Fn{MN7EZB+>CyEWN0c<S68<g
	zb--oU)jvDlM>l\|;i*X1Iysne!?JRH}eti9KyNzULqiPltp}pY{Y1-h8IzD<oI^#\|R
	zDIHw\|bj0uV<aQ19&FJ(W)*_so_z?SEixKy`W8VL4%NEtw-Pfm}qeBrJ8%uiWQqb$y
	zq-c=xJKk%lu<jMK`a()2&$_)mFGqCwn*9C5BBLsY$20Y}FtM<lp({N-J)41}A&C#!
	zm}jiT@by=G`V_CAw^}^^)#tS-HZCrvboQ7nITm@gV$#Iq<nP6I5S*&(>L9t89D6{;
	zf9dWH1hD4i<J+$oOP$z!U@ohRGcGvz5#nl*K{+N;=K5Rfy2Fp^p)TWUC+4ZjClSHH
	z*!EMOluFZH1%~-wWn-I%_N#XN9XkVD@Lk(yC<>jvS^pD0z(H_rGMEH2\|05ia%^!iU
	zUXiG(s+OU9gD`Eph5aMT5V$fOXB+YH@t@`Ab16h$2{Wm4XXfW82G2%MBdDd`4vXVZ
	zU)Wvhy{oD!FDr`)?eTKlEP$ShiVD3wJn%toXSJ\|&VK7sXHxieZl@$vRP{Gsl=KV_h
	zu=I4MAJxuScq9z%@LfUI6%8wEYm2W*LSjZAzmj5-%QbV\|s-=c2OiH4GbfnA8q~jgj
	z4f2J7fDVm*\|6EaC9+;9sUsPPYUnvxLNY@h6+}<2)1w}+AFE5Yo?\|\|P{@^)RnaU(IL
	zw8XUG{$G)+02d{\|S&$Ypl;YS\|W}BpbOivG1J3lBgsngr>TAsSu8vKb~!kfa(cLxWm
	z+<ko_FyL&>te+2G;z1{o@88Ks$g?{URLsJ{AE)rx!FCiA`Ay0kXC=\|>3XT^V8QC7g
	zswikPbai5C>U_zL4r<T&XXpHKT7Uw0`>*~q5{TqiBz<Z6`uc9VuhS4_V_d?<(9Tu6
	zBQKAAzseyBX!Qe>=}<sbWo2g\|79LC^9(vemW@biATmbPlqq{fjNirni?5c#`D*DW?
	z4fT(~DcpJ$q6lcHpoqwe_wSANH;tbv6AKA4-+D4xf%9L2\|5AH%_HgItV8$Inv^v0z
	ziBt;$fe>0ICod~TUkSWltniYU9(XI_)2HiS)1(-;8c#~p<j9>1#cQZjtR9Ts?C9!x
	zu)Ekj05l^NAjy93-Ck}$mFJEnx`Uylq$Ebi{3tK5`<2vrD6?G19Dw4=NIp3fX&~VA
	z2bj1eNj(tQa_@cHAB}!=B_$<ym6QT=b2%y<rh8g#%th@do}nfA=FJ<_&CXqgw%&=@
	zS^n&dLY~3eL!@eXyhZ?VRvd5w(Ws5kvgW+SwhVfWJY$gX=B!nLj$*-OA62%rWWmJ5
	zOxMca1_tTzmjkyHLz>6O69bhfJ%An21aRX9HOQU}xCn%sos~h>!^6YouV0B88ym$;
	zsAYecs&9(8P8f)&rTP86JTx>k0LTRzu=`?mYbaX<1A$B;X5$nVVbjxa=4IWp3T_fq
	zHRDYP%q}3sJU<mCHlw7SLo@<C@6wGX1o;dJNcgc-QZ2fWr2QxsDg(S8GgitS_n9
	z0-IPF&Lz1(Na*%7O}`+OhEA<}u;F`^BNk$8Y\|QO;g^rF6@pQ1zsX073`EUQwV53QZ
	zzfT>AOB7u{h0MT+2tri7PIjQrpXBLqCrbsGmgAJrB(0bk8(*36UgJZz`G>NU(At~&
	zWP_FNy0RB}SvU(vRO<Zj=W?aBPVCJT-Z{Uhj!VR#_t-PJX?2JpX%O4$WCsS*f6^
	zO2lv0Saf)_w6uirY&}9r@6#X+2qZdkHa4~-nCQPymuod\|-@ktVvEJa*V=`=+X7~)J
	z%^$a@bg;Jf$IU?ZDZw(hho8q^7Ji5z@EdlY_Ot2%_tCA;>gt;fKk%T+8+;BnF_5V$
	zN3;B&q2DiXu(S7wEr@b)5kQ?{YSftc7N{=AvZ{s#5_Dfq;yn6k>*z@G=+UG2`1m<c
	zqS4+6lr&b1T{kxGFz&hf4+virLV7VKV7@8K2G%ZmJ9pw-;D?$Vrt3h#0VzyXxwA
	zh\|Myws9s@dz`v7OPHt}WHhs_asyg)4ijXBXayLqYEg-X9T5dDi{7#RpySpg5Ck-(i
	z4Lwj0;r9X$LG(}ofQkNDTs1Q^x$t3c8A5aTXS;Ds1ZYY#XUh*#J9=Q{@ncRX1h-2`
	zBSnVVx#Mhr)I9nn?ddYl2eOpN(anMT6Hs}Vo=kmeiRaQrLoJYopkTfwdaNrol~`L_
	zyMAv-B\|%Itf{G74=9Zj%<+j(Ze5K2eS~s2x7cR{G`t`R}(_)lQaBzRhOCCDjTv0zc
	z?iNJ3j+sYbxyX5vQNG;e%z{Lus#<`rr9cq=1-nn1m-X>FsLsZzJS!ZZ^YGa<W07
	zhvEjZtXMzY<0am\|&JRwt{pXKQ3DKJuG)c)4K6)G}(sBf<sJ&di9QKCK$a1{Iq(b1`
	zDKA7oG>`!7dG0O}oFDZER5Y&+0z<^4q(s3VkhngomgXB(m3+!xfiU5!rSB@zif-Sc
	zhf$$apTl)6peMdmReeiNsi>)0VYb9QHrweO>oFi%\|F;#*@jW><(`aEOR`khKeOZ+D
	zz63Hx{z_qlUHjh?0t`wW\|vcvHDBp#YoRK9>xOydZvHKm+>a^ILj?}%D%4MVvh
	z0lZ1srOm;ts_`\|I=xLm1Lwxy=T+9v+KyKw=LSDap8`k!cgvZ-qAr2ao?)iP{AXmqK
	z=VzRpoYFAp-u=aU#y_@xeS80<uTQU@{IR8_*6+?kvxLzKQQ8L&9%Pf@z88HW3y47R
	z&);^eC=9ZJbg\|w8pf2?A%ZJf8@LLQd=iYn0lJPL{6-WvB%Gm5^1Ow?s`3s;FJ-~;a
	z;R63gRrbdZWBefW_6&!5>Kve>LA\|HY`o;$8^!eJk3sE;_UQ;n7(rwAq?w@QmVIg9!
	zD@?sR-hbD?EH?7Gf?l1mCiRRzGcR#xp`4_0p9qM2M4{TY^KQ^2+2#^d2G^IXUav
	zwj3_\|@xj@_EV>Ne-ifp&-*P$sy9I#(k_5sj^-YG??%uoW77sqZJDGpUh#&w9{Nro(
	zPo7wS!2reBv`DdWettjv(fV_ddPdXHFFFcJN{fN?{\|@%_HD&^`we<E9(ncw8X#ZUa
	zm~QZ)h6qzuR@Mxy%sqlZ@tsnc?70ftYR\|_lA;<t+H__dCaKJ!v4mI=6$jd8Z#ot{5
	z@5Qm-LyzA0?vLuDD8Dd2(cmzsKauuIqw=f8yDdTdnd{mX?-?^!@k6743LoPwfjC
	z=;@>SrT!UTP`ml=xG6=Y!~zYr#0whDiDv$Wg9rJ#g>SAeYcr}7MxUZRgXMI$p`V
	zCbdJJ`#43?@BUy-HVMOR1i3>c{LtL;c1C8V^U<y~kPLc&X35{LE1DkTROqS^fsKs~
	zlK$m!^ltnpdhXEpeuY(7UsGYg=}$)F85Ew<{eVzcMdMFy(5gdf3`@lv^YioJ=ltPr
	z9aB^HV}2&a$D6}j-V8Xu4I_IA6^S17dpucT{npgc!XohK&oa6t@^~bV3^gS1;2j35
	zMSxo5%K_3kJWQUGlLJWrxXkm#D{W)rNN_1Ui2mpejv3!S_xufs{*zawP39158&y~Z
	z{pB=mdksOs7=0%v!OfWlLKPJi)g-\|WUrRyl>57VqUcY-6esZwI<L(cOfjom4-s5i%
	zV!^P`#{=aqo2d}hbLPEsph+DVb}6NKR\|;M>?{UkAFzJK+Nh_q%Ol{xeu16tK~VK
	zq36DizNz2-=+maLzCL0-Jv~ldUU?mz_(5ED$PKN4mzsroe95=Hv@RU>_KuEHf`$Rg
	zbVBDiE%i\|1vMZ<>SLLuAyp\|eHm%$=pl)MteWDZSCDcM)=^#=_iBPAwu0BVcW`y3nB
	zaoM5jx$j)DG?=7p>TPXl!9XaU+&!aI>(&f8yy^\|nX36`SgRO12!*neMQexIrGI7Lp
	zImzkfryZbP%<V4HmEB9@OPWu`ENpGLk@%B*\|F;fhO9qFVpk0WvhlHlBesUA5`&feM
	z?fBHh_wOU%qjjoFz^qe7DA^PrWM^m37nU\|+BK9-&m#6DIN=J6U>O*aYb7V-dZLa4S
	z_lS>1b1Po4U\|Gi8{qIIXZQVUk>Ke1Ar%TGd2h$#cLP9MN6SLe!6aLL8S`n#w5$v%7
	zxl8\|!W6l<FoH?yI7-4f(CSG>yQOq2?+g8<E$B&J;u8t4@(IzU~;*v3TY3=S-I%njQ
	zoEE0FG-u&gHZ;9RCyI?+<>26Pk6zd#XA=vwtk!>1;k_~S`GQB%5=&#%5B0^4=z32n
	zPclM6!aHM<*R1qQP48G(FoOgEbVewTQkJ{qW3wqHp}SpB_)hNb{Ns7u)L#G24t79E
	z&@C^}#Gr(PguXSAwFnDbc3`6Iy}kDNwwFQ>da-eE5^QW;oSlV!^`%6BonUd&Q\|b=J
	zXpAxo{!e^PuuYGM$eo;;()-;kZ?C~wQ})Eo<zUkUfcJx1iWucoY^~qPUnKthFO)MN
	zPs?U&eSl)CU^Kh3+TGk<CgHV<9TOAtKNS7G1($unX$!*smw@Mdiq#yFOCufEzcsNm
	zdH~D=s96)%;>bLE^-BG%J0DmVKNy}~@oG2?Z@9SJWm^+6@sb6fZlx<0B9KpEfeoW4
	zvsI`e@1bY%4q?RetE&ZnyuTf59oaFzv8l;f3~m2?zon%G9Wzk$VXL4Z7$7A4wvGsD
	z3v?^3>716)\|B%`7?\|*H{HTnTtxyq$TGc#mii-TBXyi3;q=_\|o`ZE7Y#K~e-g%=ZFs
	ziJ8Cs_;BaJoxZKAS^wuu_>YHkF0PIh7aDNrFv>\|7p7*F3TTKlPk^!KU3<$O3R>Y<>
	zA0B!lJ;CGF8wOyS$_F??b7L=\|qgugmz=8nVWdP)@Z<Q!#w?YE+`t$F7t=3x`PGvlH
	zfWW(V?;;3#8usr`vwBZ5WT4bc%J9\|qMn50)44qY$BharuTi$wcbBXQ43qSKk9^G
	z$<V{~G@\|x2uud;PWH0x=;cH70dXVMrqNYZS#!be6Q!)^imkOCO0FPxJTc+rl;nSdV
	z%<*@uxa>MMZ{NN}o{71wt}LFlTjUuU8jAfZdRk)9n#-TfUB@3hL7;29Qt9cxpqF^O
	z8r&1LRO;KF63hLOa`9t\|v<#`0&+aL&^J2=SKqW)EsD)5DHZhzf-8%OtS=rf;__QmV
	zgH2V9%~VTjGtlGoz;\|H3I%D}{QP3m55#ZYWMX1Mpmr1jND87;&o={v!0fkHjvWL
	zghBl=H(^YYBqc`0X9rG\|44$@@)4aP${6g?W5&1o=dcPY*+sCn92~DJ889gSr\|pr
	zoHsg~gVjw^Nv?8>`5M_9NckP>#QY&wZ07t-^}La`kT-yG4I8pkZEM%#fpiQ=tWcA1
	z1s}eMu`aN@RlfeL_xS4ZB$?-(J9oTOS`9QbkaXAhcw^vkpREQCzOoaRD7qV+As6Wi
	zbWO<GI(kMZv$4pX<<Z2&bG<^-tle$F^1%aZzJ6u5IYYD5gLOaC{HNnJE{}jN35_c4
	z14~N<;N$myQ2Yg%Zv{I6@0Ev4?CJ98znx&}_V>k?)K&gPO1\|t2%e0A4dZ$Ux#=-Fu
	zq9LeM{`U5haLG2#Fs@yyoS%~fM1LoeJ?dl`Gt*PkOzHMGi`0U}S{G1@+Y1npXwA
	z_EyLcYsI8f6T@QEfhpPf_=;5{NVu7$q!_)typTl`Z2fGlmaeXs2@C4z!U3~#Cn&$;
	zHzZql%#`ikO\|}`q}{pbkQ8p=6U{<bS+eCKYo9yAB&vrxfOie*A#JT5QID4-eTa\|
	z+1\|R-x#QOanJvvTs7I}hM&J?`mzS\|#Kk8MJbUXT~WChL1Q-2<noy~??AFyn$dRh-{
	z68O<2xSq$;wIUGzC~I(!FCfrqiuO)=?1E&^BcXEIySh{ese0KYB<Q=lyMd\|`-VyI4
	z-k7nQkAKdKTu(<BCnvp!oni!w(<x!oq})X>V^&L6Eyrx~2qBgC2Cfz^KS8tXzDL
	zP0dC#BQ=zM?9q3kr({(\|#3Uq%pPyt}nalp8OG2F`%DzCqlp#4K#cSts5~+~jAcymz
	zn<3S!_`*z%87EgIW7f8zA+0xFN4~4OUD_u-x5KcN72jGtdc?}bl\|R(wJr={Nh#=tH
	zTI;kcJWf_eJOMNqI+DCk#)>WjTW8)?)L6$BwHcDH<Wo%3O{ItaTn+y6<*sp)ze)L^
	zVZbuPr2ihOsX*55Dky~5?_+bCv>Sx&`@;Z{cr\|s6Aey95?bgMi&vyC-_wTcSU7^oP
	z0ccy<eRo<c+HEhJOv(u)qxQ=#Q2eHn?o+$D9cFRI-@j2UpuT;O6zF*\|k)Qk)6(08a
	zgsg6#o9gbLKj`BLSP1&qL`Mlm?jjA\|j*_#r2c}OYE9Z@D@xZ0YK_wz3P?r3vEmdDf
	z5)u+BbNU!NZ$+5dbiKluv^0T@YAaQ@JI2C_n\|MlZ-n?0vuDgLin@hiW5E2}WaGIP1
	z#j{0gn44P~w>Q6GRn03fH_yPUWw5Y>0F\|JO6Qz(jT>PRVw<>`?Rz2YL0~7rJ?wle_
	zY;1QbUBq2iNQZ`p2Vtc<sC@k@=i51`L++I{%ZD-Vqt9hwa84`95iAjODMr#@Kz<T_
	z)W;+wq`5q+54n?=QIZHjpQIoxiw*?_H&Xxl^=sB=s`xw}m^l4UC823%n_RaLLHh\|o
	zq`A@W#Ol_JW78RKy6fHrE)_G@ETvR;T8KZ~G)XIgC0OK;ByFlowFq0!F7I%C?G<SH
	zDqzCC5GUt6KNfz8Zmhoq+sqKm855~L`};jy)Zu1p`^_)=i}i}H7?5WwiTqrD>9R+B
	z_jiMR1RC}(L8#UMnA~bSQCprJ2W@yA7xx?zR!c\|63mk*4{j7>W0;IaOmRn0d^\|n_~
	za4>e#yLa58CMtk62k}>sq?^txynK8pG}\|QBgu_?s#`h\|4z*g@JEF#s&PcGdeFxv?>
	zrkK;iU9?2#XFih(8C`7!6GNUwUAWx6KVs^u%sC$S1$\|fu7q\|7tk1N6tziRB!3JMC9
	zRNS9z&H_BqC>(`Qkm%Q\|v!hh56{zIZyLx)`2Lo9fFHLmY8=r;7Y\|%IK!$Azn%rOW{
	z$;QYLCl3!i#JJv5Gsb&iWhHMyHdh&!J&IPO6{H+NW@cuzIO<t^{ro-*K1Sz$Gc^Ot
	z^5y%$uoyS~%Sjr#Jj3<awH(ocT-@9RBT;oM^ox)`Q\|is0KE38J+lUs;jT<-oe_xAP
	zv$1+fOpl!I1UFQmCu0#b_fX8vKMxFZCT+^?!EM`L9fj~m&x9ZJ$@=q^OP4N@GBT2U
	zz8?h!dbwT1bK~>)07x~6;C$M@)7-vB9!Ez<bStsgsH*e3W7D_RLb(ObtG5`^Ll5rP
	zC?;`ATq4vE6~uT3tO06pDOW9}U>m;#tj=cMF`JP{gDYB4XmeIXEhVQQC@_p6lvQ=n
	z_G-e5n>})U#9a}GCns{5gUyqZm%&qhp}m+kRj9)q91`-z=KT-q8sDR9#Pnj=P-niU
	zJ6&RHp~8Yf_6wDtp7Kg_xnrZJb-y2(R6Aiv\|K7Z=y#D%+y&<1nrY0m}Fe6x\|?fw0Z
	zKrB3pf2nF\|l2MM0N4V0zzfcJca7>p~R^lRtW7KH;upP+@gkmyej1C<(X#ef3ObWU_
	zCWxWz@y6)0E#<SJ?JSljA8xt)LT~@@^Yf#dI)tUfP!dCZ0H*)DJO}pAb@bPgLg}L;
	zs0CK9W=+<42q4x~iN(>2v=&2onyjwt6J)eexKR7W+s?\|$%7Tyjt{}0~6i)wl7N8l5
	zVGgR}P{iC^>r5<YVe1Rpf+sWmDdKq2lk^tcT6)vd)8(E!miR%>K+d^npDN1Bqfw5N
	zi>oE_vhW1K$ODNOR)bFvcn3bnrPbl->uGAnT(`W_U7N9oPmZAXlW$8%phs5G&DQnF
	zkJkPhv1}@H%gcB!E-r`1$4\|$p=m$qR?PICYk+n6;lk5q#w!;FUhZ__W6l!P*D0cu1
	zv9YnGv$ZT1+QUv;t=U2$7GVtFD>C96AeBdFJA3@yD`fI6e=nzdUP$-\|gweo\|BQ(
	z$R^gCt}7bX?I%dX!oqI)9e?6o_BcQFLNr_zbHhV?c=U>zUo*?ShO5)eRG9Bc;HgOa
	zo+9osH$NY^xM+pm%>vrA{xFK=eD#g7_{6;=L78Kd#GjIYNBRGG(6QIz4@=wJsJ)
	zf)P)o3T%VkUw\|OMDlSe3>Akb{1z}7\|%2{HmX\|+#8dZz#f4S*8NFSkVSj<~Ou+g2
	z6H`-$HgZ<`!l%ImLV_QZao87Lg_S5I<&E0bAFmcBY%(RHPuQVK<$rdp6!9%~UZjLW
	zJ(Y-@oE$Z9kF6QLgEaw@+F<M6H%cu^;D4@9FM>)3F*(I6iEtG@eE87w&$k=aCuiZ2
	zk?j!HEFL}#IX^q0Gd8z`h?o{\|ei==?%E}ke2nWOOaW\|FvcPf0m_xm{zHX6C0hIH+P
	z)V+mnDOzG=XO;t)qc=TlrVOpGh`Hh;f}Y#vcXIEnSO$kpU`TmxGXaI;MkzcWE!1xt
	z8>0e+<^Q`m9l@htGB=d1^50Ehw^f~+Vq%v6&d<=3$RNJxCV0ib>b#_umR1m;mMJM~
	z%aa#j5bI^fjR>)tKiLc;2eH6R7t;rFFv>HIHwjmB989xj8wnnePW6j@E+=X_?b}
	z>(d5N78cA*#a9ZNnq=&%NlY8k>4cUXI`;B07Kyqw?mlE`$^W2EAOqx$l(&DDK@WGN
	z<TB&1Bj(oDFXA}VEf>GUeEIgR14Z8{yHaL$_MFybaz@5i1mx_^y}jsJ4D^7bxjED7
	zcxgXo;j*`uhQ@Yl46(Itrou&=J@g<RkKgU`lKS)GwQy5B6C8HSliu-hY77jFm4Odf
	z=>1E`R_NxdEc!g+=4Q0egHH3VX!<WbJ?KMnWLK_y#fjN(2I8UhyQ-geS8T=j=\|wa?
	zJ{{;9YXw<Y8O+23e#qv#x>RXDdF_7>wYI$^S*GR_u6gPBZ&~V}3}`-j8s2SfEaA7v
	zhYufU1kI7yxVZU+1r{8uV\|-O`NT<(_2Qd+dV0Rz9rQt24-b#UU%wV21RBw~{6@+
	z#MX0fNV)&nb{={hZ7;Ndpt@Tjjt%FkCssZYh%l;hn1}Hwg8P;\|>SstwN}2;b=KyZu
	zI?H+Ok3JA{p=hyyhtYQ%W5ibE^z_texi94c<MQ$TT4-qKv+V5bg##B8T=op;Ddy\|f
	zDX0ZZ+v~mlpwDJaeE;6o(t_dO;DGMa^PAR(HaAPxpYHbZ7U^b9%R$KOnNI!5HbCMR
	z3C6J0oA}^xdw!zK0_)+\|B<8jFw{VR=Pqvy~LJWK-Vpm;IgSmLc0uw<Ura-q)&\|}k>
	z*SMM#$VuP_zjJ@8M3RUd6\|B$v;$kqAP=;RdeInHr^<FAO{?46l_pbtthnSGh(fv&H
	z9<R7~-BZS&pdILAq<{nH0n<CBfmaA;^G9uc_XZWwGwr\|n(_TG$hS-0vyof$Q3B@\|t
	z6cBJzTs#wG4t)R\|qys*ZjGjIUok`G1n3UJi<GJdL=+luVb?(;8BI&iUv9UpUd7Or0
	zUFbcl&S?4wxRCi_b*bWQ2Ng>iN%-iFfaQI%q)=d+tQR}of>?3jG`Q>v!4ZvGx@~0a
	z-WjjR#F}#B05nbfd3@XC-3a(`?_8+qBqSu`xbA>VNoCZoWCI!U#jkt}po(`VTRn
	z_TlnNHIhMs78WMn!4<9lKY!3$R_Kj>wD#KCuw-Op#Ehzf1H*R6+9tNQohG9vVE{xl
	zf(Q-{4H}8w`=4@I#C3H=D?$)qf3d`z13p_bbvlK3ultl%<3oQ?\|6UEb}{Y\|N8z0
	z39CY+G<?WForfcuqdotf9h6)5QlYm`(c2y3?!0}e5)n`jA#AugPrg?o&&tXKC!@j0
	zpQ1GgX?=+Q#!^gjawN<Y2J)~kIsZ^Z!`sN>+GaEM96ovGsxj!UuFw^W431-3sEYSD
	z96JFlBh%BFcn!)>#ws1z(bCoyvTVn<!H~($IUz;QsvtLXx0&P`>C^F?!b;#?ksg
	z?xp#\|hqydEJXyK9Duu)2MTX?SogJWh`<2BRVPOQY(A0h+P786ncq9x=JUoQJf^U\|p
	zL4\|Mq0IzjfR*PhmVvq\|V;`(DJCns0#I4g-hW%2%o`Vn0brjhx<${?16_g?d_Z\|\|Mw
	zTXE1Q%t6c1hrX{}yOuuq7=5m8Vsf$tdb7djK%vS13>2+H)@IIa34W!5ei(kBovYSy
	zFdOg+-9}\|*W?q_#_Fw8rK=0;9L`0}DJX^6$ymC$LBJFiVqgEj`_J1Bp`1jFcc}K\|P
	zA7htUT=3msQX>tOb=%o6zk76_@h;jP6x*t3Dyu\|{=@~uI)w!>%X=n4~34vC2wq;><
	zJC)t@5c#XIKV}Ig{L1YJ&b+ZeRAaK%lK+5^V}$WS`BiXTF=u$sZG8PX7S(q041K
	zb9i5nITU=d&41_pCs%`47aL00eN}&UV&gBof~tVMQ>Qt+3BudjO2LH=QlRa\|VET
	zW0q5WqTzkwqyqd!9e#x7=H{xEMNtTt{<su;Kd#%#vOSdS)06LSxU_T7CxbFFGI+HE
	zloR>y0ZF1a+i@;X-2ErOf8)mHY*T4)Sjy}o6}L_(Al4-Y2DP)}{o)~qjj7LGO9}d@
	zOn{p{0t<U1ztAKk;E)_2FAoZyuazAx$FBMnuFGaHql26+vR(3R*Fwv4yyB@%5TgEZ
	zvw&\|qKf5l27Q^(v+OGw}K_8*QB&n=cBm8}fO>y05Fyju!TJg@GM?m-JSYHrQ@3xUh
	zovw{_fcEPY>P5k_4;LHV=zXs4<!SczM8BP@^HVL8U)G}+1kxbGD0;ESg>}bqkW*0X
	zwTmwo8C6Bwjuto{Zd+WS;B1D;<0F&^e?pEP5vb~(fC(XrpyFGAiZ-rw4KoWkO8_Zy
	zUT8<3Xi3blQu6gZCFj$4I}?~^pq{OqfZX&yt=9dX0wE}YNB`H<XY`*ISuG#iGlUcZ
	zzu7T790z8(lB2mE;w3W(HD\|al&iAM<89kv;T~o8u&5<VPe\|q@O_nxdQri9Pm#hC^l
	z$Ur%UviuT^EMa~hJG>3H&4t#%cm@mg1^%v2K97hXJU>6*+nP-S8Wpk`x(b)32=b7p
	znTfk?&b%n;cdSulAT(BFm>HKjE7{GYV-c&iKL5+S`5A_%xAzce?pTRQZ;44A8cIPC
	z*nIx3llVnh&_DvX=DZ-^c=U@70aNIN;cyvOm#Gy+QSur<WMOoesqYqOI+cY+d9o\|X
	z9@ovCaJ5js^cPs-`fO9$xA!-UHV$<*f75)OWgRn3Y=+T8XKPhCn1C\|c3}vB5@H`h;
	z%3x&{M)l2b7}klbzjc)Si#l?V>ej*Ut{zu{bVWcw5MY?g_4%FXlO6yb^acm;9E+&v
	zn}Zpj{!0U=hL)Br=&^YqgvGCK<8TP6vJ4rMcvQY7u(MRECZRj)pX\|n?#XUA(3qMj*
	zh`!QIC{X{bv~-Kr%;oIZ?G2w%CvbbU=MD>q_1?<h^P@k@c0X1b?j<L4s}3o7>nA1c
	zuTREpHT_FfPT(e^r0jqJb\|(rj@)=cHeN7VbJ^q~wZu$E6aPBZ@ayS*Aavb};!(Z<m
	zza-xh2D\|(P1+HIl_2S#Ot7H7Ll`lX?Qv=Su3abh)kayMERCIU&v;2f6?-(CX1drg>
	zFZl{Se;%7$<8#3Ov+GqZIO30{fV9o&y4>z5wgCSC>0yec^2UC9w_@~JN~kIGYj4r)
	z4QyjM+vpc?^q!nU4Haed6kuJQc%fc#hIvbnjel\|0eu-V\|&L#Hw`T0-wld&)>0~vP+
	z0ZO`\|_s>NPF<;+sG{q%hK>r;x&y$TRXBU?TI}07ID+A2aTT2`K)jBW2ZhqfF+iF7l
	z$mX-{=tNV16bQQY)F+!O65jD}t>reuIWN!sqOaUqnflDr7IJZzBH2\|Ly?v0vsu*o`
	zh{zGdMf#<t`XAf)pYA9I1qGoeqtV_6Z%c<sPEutjX1IOV)%7\|8iv26\|m8A0UMqh$p
	z49C5siPf<6FEOlK_djt0cCgfWY~{FbOvQ6*24&odcnT>5(yBbv4J3MAqsmCY?i?G&
	zq*6)}5\|WGfM}$&RQV1wqHB>q)PdcL_+GyT;Op=nRW5q@vK@2!dBd%)as7BI@zkycz
	z^TVZoXMfxbfQb=J^C`S+\|7k9}Prl&MpNmGoM!zRNawtY$0YZz1(V_RQV4W0a>b<x$
	zGq9mIA!}){{rdf-{&U$8t}yG64qn&X#>T~Fh}-sm8D3nVw1hW7sR(N6\|6}g0->QDT
	zFVKUCh$0AxG$<*EG?IdWBCT\|Hh?Iboq@sihNH?gIbhmT~2uL@mlys-W-Q)Z7z0ds<
	zuFt~{o_L*!z1LoAX3rjPUbD_T2zc!^k?a~F`9>\|o)YNgaiQ>%6XMQNz?>pt><T$&y
	z5Rs5Hz_-~a9R_BQ_BJbyUfKqsaLxRr70xNZq4^bU\|6nQ^YbTRNgWR3SWqS`1R}8
	zYwCGdA~\|$^!`Sr!MmAa9(5dJvkh%keKjX5sRo@pPJ@;+W8=6J>^F1l376pvQ;_FYZ
	z{RQcmWPAK?aXwT1bQh=nrmvwdS$4d#8VW4n&SG1W0P6FDxrrSUA{-o@8)Akvmc{Cm
	z4W~LI^*o{@bzk@!wFIKVJHWA7RWdG-vMD?Nd2zw~7YIR&xp46v>d?eQIy8Xv^!2HD
	z@6r-p{M+uV!=+mT8i#acfpP2IY\|Y{xhxWeBxh}0hh3VC&eP2+*1F{>Xa4wCn&fJ)L
	zz64BaIoj!BIY5KB-S(a}2hnw9=2lAswY;J9n3pHpfL@-=HT`^#uaLoKm!OSCvgH#N
	z`D9NEl!=nPeiKZA?qKxx1r4#xC{t?wfPmPkwylJ2~848838mWRhJHKYM!A5_g{q
	zqK#wt8o$j+Jgve~Q~ssvs^3Gnq\|Of)m?QxRJ8tefWPhtk*C=ELs-(~#=vrz$ZU_%4
	zD=R\|>M>A<gL8oW{Zzto>)`!M{AM!LLa;il6^#+(b+&SQi#Cm%EmQ-s%&VI\|}01#@4
	z&DoA<F?V4gb4)jH?)dB0nD;URe^!u?I1Su%7MOOrSgJUkH!<^0wsC6+21GE=y&M4}
	zf>RygH\|c{6<u6eKEo^Y#0dKL}UQhv(c<4DXAdrGiUl@>Iy7uU&IGM9M@yf~yI(g&;
	zgYm~0P5rMZRkCD4m8gf(U>TPl#-{Di($Z>\|J$ngmshFY63jBCeB9{;!-xvZ6{A!4r
	zo_qM={$\|=i6g>k2*0)fWAeGX\|ON-ZG;>+#ln3<V<j{feNm34U@?yc9HZlDkPy}C-c
	z7P;-j^A>IYlb=DK0%M@W-yj63++xf_L_~B)Sy}n2$#a&7kxXM>D?t(T3U3wSp?o
	z(xHi?\|8Enc(}ad9o{NAP@uZC>IC5}_7jx=<Ej!~K&l@ev_vFWwduLvi+DxMOghA@d
	z`_8cnfRnAQ?Jt-RR)VuM{SXE*Uvw%<&b$&;2Kc(BRl@FLki1tqT{`K3o!6>)OF{gI
	zZ%u!kZIjZ1Lb&Yk<h8#6Ipx>i)JB>*AH<eSBIA;i83%Ipx`4}\|l{1i+6dQPv\|IiA=
	zT4Q6Qdd3Y)lvbFklBvq~w9gOFZdi^#jF>qv1s(LXocJnq&wT\|LI\|!R=8U>6%zJA>P
	z;0b(!1Ev`!%W}AY>7KizeSKq`HmOULS%S+MuiTnr;rqD)3PvSO9LhrWvy9*ej4Ui^
	z!!bHL?83s7w@HnD^M!FqvFsGcbe33+qQz_oc5!0vG2koc2)h092!A}INVt%_X@+X{
	zxuKnO_u22!(R}8_AVQ2GK&HotSjw>\|B%BW8vb}_o<oo->kp}xh)%xSdqn~$XyuMBS
	z8Omo^Ymuj=xMOEmz+~{;{I`f3wJdfwU(X;B<zWSHzrF#xP@FU3eQ3GlBnLshd!i
	z_}zL`&q(8~`\|#vkD5wGwnDG6LnHvgDU_#u{vcgi1-`$MNtGkQd03`LM$dCb7yB$P(
	zOR+dSk^jw`H&}$K9b\|vi^7QY3mh~\|pr(nLwhwsgAF@Ql4@WLq<cHpEfO-m0;*yZ
	zj*g?HHfUpGx-GnY<I3%6161#?v{XPXS68k(M!n\|bSVTYeT&Q?y?B(+tqm_WPr-u6F
	zwdvD8y_OQrk31J@*z}f&l2RI-Fk4?=AFFU^XSNq@dhxxN8phVNSLib^(^QY6gT1}I
	zp{BX&7u#&Wr0e_p`>lxuHzr?fFW}U^!a2{=c!=hio}PYfX9t-BC1ykY?IqT`Q_TTV
	z^75d\|geZRV#yXMCkChi*UXM8WYGd8~83%({)9=AiJ86PiC52l!hmUb$AJYgv^FnK@
	zYHDijhGq1D@_3=o4He#1uMFik5PPkTmMWaj6+(sLrk0mGz{M;zO$==yY`!rdSI$tD
	zvNxi6_;+WSRW*woEC<z(qF_FYf9_mCCQfM6an<p`BIbL%$Y4Q#PT^aBe^kz;)_Z\|6
	z_{1=wWM@7tQEXjx8#M6gyoHE*Pt`Pe8VoSgP=hW7U}m}12W&nDYxU<jpTs`1rIe0J
	zCUG56-2+M;!C4HJBeNl~6zS`W8!zHiGA3wz$zm`E=Oge3%F_fp?gB5io?w_265z+3
	z;&uvk%kAEnv`1i}$`0{vF7#cZoA?fk12YhBW#a_9)5RAh>D(n`W${hg!n)-ZH`GT;
	ztYoU)_RF5n_mJE;eoB4@qzLx$P<Qjl@mKymz%ZWaeF\|>F)2J!{xQ+2xnJs1BKTm1F
	zoLXWqC~)1iZaQsaG}56g5a}RR{\|zWv-mBby2#O7Kww}=sn9VxE2_}DC_Zx#}&`b
	zbM$IDscgRfDoV5mWNd6\|dJJS2tSgs<Q(<Y`X%gor=#`?_rjqO%z+XXLsJ~(lZmDuw
	zLHkn>+B}yA?>~4zOhY4=DjN;npDY)ct(vWg$PI\|_0$?ZjPS&aN@rVd>Ma!~l7WqM#
	zGOvBx3mz0d)Eh=^-\|Fn<CMsYv(U&nm@L4`yxGzU1c4$a_!t=yE?c^&;kOsU9yRH_<
	zrjqdlBS<bFAb?h4Kt`YpeG$i{XBA!K6cpy={&XUaS@IRh55XK=e!U@kC@Y)nv^vq)
	z(jqc$76(ddFjp@Pf(<%fz@kH\|1+w~?t*yc0Kz2k1SjKTBk4c;QN=<f$F;6$j%u7{B
	zlvh+#^bw?!l9ED8fM~VF3p95k*rEByw@Qyu7nI)kYrq7eQfaNWS7t+6K;M06kK`0t
	zo\|6Ti0K4)^6%s7)xj==K3w{HtS17MW!LMJ7L97eloZm`TamJfa3}p=i`PMu\|WCkIm
	z&ULj4w-z{dc9ZUmKj`T0d?QI<By^RUwm_IM%3mJUrM3Wai`&h#-FJ3&_E9g}U+B*S
	z^`*%s1G8bM;Vab`eGQ4H^!i42aFYl{Nn3n`ZQ$uJ)hL%O?I_M-AnO-Utm$vT-thW-
	zqevdeP2iIh9NJ~KeF<om*v#W7(b5K$fOX^ecs%s)5sRi`Q%j34swF{2MrPWT&;i^i
	z{<l4a&m9<5zkq-gpcNS$!Ivn+Jw$<*&o1WHF!S+kiJy1?eehZy6yIE5&sRPSq~w3=
	zjY}xJEQGk=Onao+Xo(f@MU=SBB-3cl3a$T+M`DI\|nehnty)XO~!dq!^0<mFX#?cdK
	z&3ZX->L;*8RHULcnwQ1EzySE9@AR~>@3AZ>)qLf-s-vCJn_9\|`cp^YLX\|i$ay3CN4
	zSdTBPC7Oc-KqNm)qi_RaiV;ur^UpK>q@22OAk4LL0?@&u#of(n_rK2^9GJMce$2KE
	zfQ(IWnWZo^G<04mpF>q6l(yZSodp4PQ$baLM\|y+VqcxwAQk&eDtnxAl+7d#H6iAtW
	zN3p49eT%iJ#;a}TtXX<4-U;-1dMMurfLG9gRPF(yD5^QyQZRq&70+2gQ9mErpFjW)
	zbn-XAA@Yu24Ze$~-}S#I=YGYZgX+iJhEcnr&_>e@R>rP$4HSe=Vq&6vUh)vwk6hg=
	z93jUga?Yx)9)=TZpgrV1cW&SI>L\|H%%p2O;h`5+~K0P`wGdVfQ$\|eVLq;a!LTmh8Q
	z*$WrY5&-DdAi$o5t1ks_A!^Mg+Zcm3LNe5HJ8f!?9)KQ(Id^#5<#4cN-tJfg%2Ny-
	zBN&$d?6Nt_u2&r=8_lymY?jy!Jl=QoEjQ3t(3F96;_^VMHA=1H2aGOe;_9LNR\|t7?
	z6IHH7R-*$2RTT`wr8aaBwV8y3q7geM({p>wqNa#wb426c5GI)@VTT3r<5?KOh&N?m
	ztudx85w~0&Z(5B=fKUM(CB8t(_j4*pyqOE%cVP<5qWWOrdV>3oMuu{FJ@lO$-y1j-
	zI_-{<){kbTd_F?ZeEh~=-BmPOtCT=bPY=ZZ{6IF9zrR1hQ8Y0zF<P_-U`c_#Y3jA$
	zIsEzY64*`%FcA>1cfg~\|pU;Qfqy7sqz<FobY=5P4^;^UZl=&wcnid(tT{Ec$pL_HO
	zRee2;gM${EeetUA-n(ZGT#B2U`}FD4Yak~6B)?Sw;WJopYa5g<TGx8~_%Q}4R$vt*
	zbaV=UT;@H=QZckzFvWQ1&of-P;uRG\|4v\|Xo_U&4u)uqq`5T)O~JWjf%`&AGO$Pk<l
	zae81R1axBGfw~l1<r!Z?Ar82F@vZGXr7WGw2zHGEbVBEqw>ORO)!mwtqad)u4-Aq7
	zmpQb*l&{EVz=Qy)doxyUzX>C&nDpSnO`8eJ!4\|jq9wxNv0VKUOm;qO-#PSm`58-G-
	z-e?{ZL!e0LbZ`R~TJeRUodvXVbRWx9%Vp-``havjkRP<{!_s4@;(g\|VAw(o-Eh;Ss
	z{KS6S2&vrkdIf;?zGXt+Udh6uhQC=jU4mCf)8ey(PsXAeaTBS`sS;YzpKul2mWW
	zIOY2@R1gl$b;dJ*-2jTe2O^gb8m29hGxrV)MIbTryz?e@1{cv{hEf^<0Ad~B9FY0m
	za(lDizkgG&rP+i?7Cm0z>f2u_Ok)$`5d~~NGV\|b9Wd}A{C2tB%(<5@Uv4drMjKp
	zq*7!6a8@Zrn$+W9o(1~Ru(Le6zPmdpbt%@~-rne7YaTrf270YuP498Fn@a?zp0!g8
	zB^_N??Mv)=prsJ>&=M!0N(jG&YW&0e3UK>E_rHz+E=?dwgq&8WnM2X>cT~)DW40sK
	z<7LFV^SM<!l)i*?snA1AmU{jx`1E6F25>Ve2?>c9S\|wmOxCGSt5SM^syn$f+xYE%I
	z;N~t!vxI~Mut!ux6^JZKmIQtkbtcAG+b0<%K~i}=E`F-w;DZfXHW-T>cy>\|y)M$ap
	zyI;S48DJjFw1o%Q&vgpPPRhsdwPNsV(aAXeAw^b&1kp44V7GlMLE8}Xnm=5<hYw)`
	zn`>jH-3(QMY=-{y9t~NKl^LKz20pFEJeVY4oz3&TY5cWujTH`y__b@hyH0*nx9q0<
	z9%pOvw>z0Ym=Az2jyB~3rKSMe;K4LBH8qiQ8@\|@jZU_<9Dzz>iQyMD#_U)n3$?;J$
	zAeCuki__kkK@#Bf12A*;K~DWJR;6a={h3H~XsuE3#nzYL4<GcycPriY3-W<XO@X54
	ze-KD4$\|k_w;29Ky$LF=0<$h_7`-M`$d8DMDie!ygCmgEX(XU61i3)t+Qv(B9#n7
	zNkmI44}Pa!V2pP\|vnX%WNM2Uf_\|K0\|=p;DWj6Ygz+ud-ka9RbAarzd`n>J3D3DmMT
	zRW1p93>i}>ivkZ&1=Eh0CO;yEvjhYsvSzZ^@$m3ozkbaHWV1K#tK\|RX0(}1b88{YN
	zUjw3+yr1v4eCdW}vZkVCt5nc8d&PKzpr48R<{L!edZ>+Hq+JZ7u#8E9V8wN&-tU
	z_mG\|IN;KR0(~as6HE?~472uSKU`K~\|v1NN?0cBX#^FEH#>H)N>msnDuWrE=X6NDL{
	z3s5C3c=Rzb%OzIDMQBx7Z+s`L\|xER;8WPOqoat}fkXNE`~L!m01g79IsNfC}=;6
	z51c1x%x)NH1wi^E;N*u#N8mCo<KsHm4<$&McZ>#ebk699ap-8qe>z7JTkgF6`Ek_?
	zhjx<JWV+6EW$u4VbZE_v4z@4U!YDN3(z$)S6H&*+$Vd)G$qx=<K~b~6IVXTt!kI~x
	zpzS<B)GaSvdsMq\|OnP0F4_IAFD1+n7;r`}>-Iehh;Tm43vX&9pH7Y@1b$pCVNXu8@
	zxcs!Nyj&wgTGws;J_8$@G>arD^9K3nq@(~)aO9\|@8~R#9d;20C=@r(a#Ms!_$6uXo
	zlOS9)%Wzg1!_1MR5`IAD`q$}$T8+sGN?O801w9T0fkh?*Lq$HZa1pn+%+?5^f=0Pr
	ziivzi6{>fJRwF@XfmGh?Q&Qlz9uq`mu;0lXa2Oerp8=yYTKiciasU3W<z=~t56?m{
	z9lS#Fv(B1tbGE\|>zKE(?JLmO3jTd%6+82>Q?Q%O+IdBkjs3aALYGa`_M0szvvLh
	z&n7axzE\|Ofr6^kTr7NM9q`cq<Tu0CZF&0%_2l{CezAFqfn5mkLK%QF6ZD?astLO<j
	z==()AJ4W6wbhyNd3JVKMIY&Dh_+G\|6%OwDDq~;6Fy6pBhOu%&g-oE_}fq$&hDX6SW
	zkjJc37GlBr&Q5bf1GaKg5C7DmmqnY-jSs_um8Tpp^J7&q2?c^xFU7IYiE>g`fL9
	zPI`cb-dAuIyr;X;$p(6ieH+jjtu~@$<eZ!wa}QCJ7y<Exo}C@vi<19o9^l;#c4k6{
	zlVf*PP}DGPpenAgvbJv6R99E`<?1B@Pf+@F7pE=ah735t`r4Yav1@mCcbu>TS_HaC
	zOWO&!Cgi;KQ?FzyM>(DNo)7+2K\|ytaxZhkHdevxc9JvcH\|KdX@Kt49L99e*cFF?CU
	z*_1!3=NnFU#O?;yVEGt4TmO9@t!;xN4FUCmsL05})3YJ4va(WSGnoJ}K&jl$Bp$;g
	zD<Kj0mYA8I;vvW<uyB*Zy>(O&$qOPb_p_h30W(dD(}GS+K_)}gdIJ+\|NPb3FSNA>b
	zt(ZD*-0RoEThPiHsI?}vmjxZ56Ot5h-C3IMjHf~cr-?~O${iLjgQFBE2OaA86Eh)`
	zsjI64>2W9i20{DYN%mbe_<D)eC_3dwSUF=4EZJt_E2t5Do@fvixG+d#6%Ow}3yN*=
	zgAhQA45x8%d#l}DebpJH6eaOUh+4mdaS^q8fg){sPr-\|diU7~4^~Pz\|EP8SWg0^}0
	zXB;rA!jZpVwQoTr6vBkHe>SzYwuVRX+WwZP)cq8q;>c1Dc9W<lhuhT#F0Qr)8<3
	z8X6g$Y!;&}765F(`ZJ!Mo-pUh`Pbx8v6R<7KEyD4!3>h%NY^4cbPi-x`WwK-qKTQL
	zAAvvyzWxx<F<qx}r$+Ue\|K{U2?-uH7=4~Ruu`<ZewkezLN@O4o`HCHMJaSqyrRF
	zq?I$2{nHXXC>0dCPAqwag<}B8!G?((S0_4va2_jOPJp=nVt1tj!r?W\|qA&8Vh9oR4
	z*@J_FBgU~qLPC(@0Q~~W0CA%h$}alO?_Bus)#mNR!E&cn+ESazGqt_Fy>{8tZQ(K&
	zyMAB\|AqK1l^z^mfY##v8)@CC0(2l2_-G=yaGXN_f+lfhMCHzZq6JcXR)%%X79Dti4
	znvSL=RgS8?#2Gl2;R(!1@Ox>Po_${+t`{jO+Y)ZM3cBraNe0o*0CNjEda<dDpc)l)
	zM^L@7q1f`)&rk3Q3=U(GVnB-D;k_K~a+D}TBm6w?uoQR^at7d4{%_ybbK!fO964!g
	zYp<=ZUxj``AJA5Z$_KxH{~DBFplMOX9uN{?H?&ma\|6Nx>FW+@v=ik*A@NYv6C\|j_v
	zw6rwJBZt61X=7u9lKNYXKN~doEKvWuEW`H2zfX+-0>QwcZHC@7g<b$IvE#id-<4Mk
	z@TAU6u*0hdmos3\|<Mwd%*wwM3v`zQvCh=K0?^!d-4P01w=xYIaF9uLV^(+FaY`O
	z!dar$XUZ_-geqC;+yK^iXU}5L-VBhBU;!IlhroZmL9$6=Iv7RVqz3^Q<k=AQRMY;w
	z`4AKb{8\|sR?gmrYr%#_Erv3jLgu;J=U=G13;)ITpGK0qM-%TKl4Uf?4tpJS9c^>Gn
	zdTXM1jqv?{Z}OZKPBGOvJJa;PCH~4nJdZ<_0c&2k-wL>-UWgHTi#oC?Fm6znA?E
	z1Hgp-_s<iM_5VITdF}rnAAd->I9kdnCML$NUG@kWgkjoP9}fC}`E`(#Fy=%gBuSkg
	zJV}8^gN<VS87a;bh5@^f4g)69NYJ0I<O{?ELKdlm4@p}XD+vZv-2(o;8UWSv#eo0-
	zp>$pzKfo)+9Bm<h{j\|=DQf8=8N)!Ut)L^@2>%W^8@NJ&}$wnJjjV&#iym235N4@Fw
	z(7>+(Y66?o+k?M83i^3j@E}_@aB6D7XUKpYd<5^`c85sg;M184T}sA=Z#A-dU%XXJ
	zDw)PgMKN{A%2$=3(Z{$g8}$_MX8a1bw853GnYky%_o5ixODHe=4Qnh2sbC3y(jr
	z8u}{VNZGs&V=*s-Ub#pQue\|&K-wUaP7k6a-``BkM%`F`!G^8h0s$_nCuVh>QAV;h\|
	zId%mSDrslO10R;x9Y{-!9nUMceB<k(=85A$a!C`f72-ZHY^-A3ku{`tulgR0~MW
	zlVD?eTU&Hh$k)wI5g-XH9YGy&T#q-p%4;&8dw@\|c?d@vnT=^}!GFj6FgdVL$ASuSf
	z69P0G)u057-ap!%<i?-k%xz7$B?1!+sQ2jOZLGt?!?n%LBm~`TD(A?^T4Ku6t\|-x>
	zR)WVHLCA}k9s!2l0e=Cpu~cdD@${miaS-bYtVVC5b)HnYSW^l;bBagT_vhl2?=b!k
	z+HCbBIrU7T8B4>3zQA2konTP*Sp(IPkz^p\|Q-N^vSq!{CbAj>$!1Ui^MWqj{Cn!rt
	z^yF\|8rE__G{CK7LJ;gl`e#aY5h&DrO(E8?Zp_%>0^uIc!zP`TA1%J@k8NZ&iaCqrw
	zghxn-D5~XHSupUR<0L~yAX5Nu5kQ9!qYD=I^Z->P3B&~uW=\|$BGA`~rbO+_73D`^k
	z7YOn5I}6i?*djMK_v<%rh%R4l21B%Uazg8RsCkGe0GN&FoP4R5I1Vr%N0tqE^ZVDY
	zy3hCDfr#+<GkF;}I)p`3haBzgLkxfL>>1bMKz4&MPm0Fv?EIy;rI\|`LZth^4>U\|$H
	zM92GPh!Q~LfdOisoJ7l@!Avrj<GF~4T0fvc#h{vb0GhyXQK\|KIPbUY56wnoY*;<hx
	z=MY;5<!l(fD=RIHirJ$2z)K^=??9PF01@0+E}cYwNbqQuT6cWB<NZY~H{r-FeLg+=
	z@EuU14IrdHS5`WGE>Jxg$Qt&nMk@z$u{TkviR!}*8D_bdMxY(N>>mfz9p&faxuigE
	z9Utz?#@-BoA2^<xY^bkCxo\|k=F6mEy3q}cu<{{TE5fSCHfRhj9Z_ah`T8;2szM+Yd
	zY_Zk=<xScnik\|krtyOnH`i$uy6foRP@FaYBU?)VBcCYN5yNiaR3J-aF%XW3;=`@
	z^zuOf<^9;3Ry`*&a(E;zukZO1phX@Gi1c0cR^mb!3shsXCsU2HIgmyMKIwcgpT^s$
	zUJZi_+7\|R;TB2@#sKflP\|KBvxXh\|ml65B1JAM+nfsU?t?ESUxVgKV_h*p8)G~t^
	zk^9tveQH!Xq6D2^{c3t9VBhQ-1&kf3$$*\|iO~`#4j}Lc7Z4d\|i@Zn;6FREbIQ);94
	z%G<jYNKgf}8qhpc%MJY@QipbH3%kUSfJU4j9G=&t?GnssxV5{Pf\|4DC+ou1x?-ejd
	zl=C4S&h~3{RbjlsVY}#Nzy)$HufMyiB$qBp<my%>>}}t2-7$vuEQj)5e!Ayd0D2>h
	zwjHR9DX{(T3AbVw2XjxRCdoK;-$N94SR6nrFJYW\|y537t0nvX1{<4Q;=M)YN(iv
	z+}zMbB=E?_@$n;0&p\|*RX4$CQz~IsP(e^?=BA?(szZVuVNUqV-Q+QvccVyt^?v4_&
	zPYvcZlgH-5{L^JllkR4vE!3o>CSSJ)w0zRi(y+)mI5?Vre7YA<R#x_0D4\|RIWDN5!
	zIYTSaa<ru5Nl&srNS!55BpuPJ)t$r#1KC<;m<RBmfc8kvw6b_`RRP0)#fpGA*es
	zW8iDpT(ez?iLzfmoJ-wI`8AreFq+~wK6`6?iAqmJa#jxe~s5{-pS+S5bJOrIjqr
	zVrlGUye#$nddzz;t(0L`+FLLBzQv1_Vv)lT@pI^Y-BZsUEi?-P-DibqF0-9_zR@!T
	zcELXQ`A^)tha){I*9=(z-_3x?)NWvFWNY#p0j(ggKSbvUgJ^HDx9F8vYM^qA<{s2~
	zZtHKb$S+XxJ>1+43=F)f>--Bxh7MTqFshHWKA>eo0o~$GRYh({DkT1PLBH#qR3l
	zAdbEfh+sa9QQw!x>DHNgH6Ca5pRbG!r?yaEx@3%L9xJ!+Ey@+!pC)PO@9)RFhhR*J
	zel0jEYVSwQE%$?>?hKXd*j&J~(2<1;B`rm!9hBHy5X>W)SDkiObWkujqrdm}FO}2E
	zn9JwESQ1eX0`nW=IX^Y(3OmdFl5ut3&^zicj}%9wIRO\|8072JhWMUGUHbbQc0#4za
	zBlkk%1haTUZgNsv>gVceV(Kat1%-JSyG9S@J;)^ra9MtO1_ru=QeXznBCB7G@T5nJ
	zEzCf9FW$`yrt{dV!@LLQA\|K4vQ*dzgC7>x_Y\|QGONP+>O@<O>F$r^guFk?I%u3LZB
	z)$cecDu!@7uj$L+psjZPKeP>zdLHJO2hh&m=_7P>44dm5DVs6cYQAsv{Lc?~zL@*L
	zpVMs4m*ee&@$2q~hDh`b;?lX@e)Q-fG^#ICEeKlKovSCVtxdhTfsc<rz4oht&vNJk
	zFzr=c$nUZ<KP+qguQGQq8$F$8Qr8=_;L8O&9voFR`nyeez7a<?0AQ3<M6<+SV5G
	zOSiQ;+zN6_V_-QLn7C+BmyP6#s<))q6#>>DLZZ^&z3*p?S^~S1Bnd&Lpk(w!w+%c{
	zmM8ndAa21$ngKCnK+D{EvGwDl>#NP!%NBh\|D{B;*8t_E#?M($KePud?#$tgi9=<nN
	zjA;5z0N~^#B8CTOQzs-e)MdM04e!E*lqcPv2~Hr&wjrH~mfnG}Jzt#\|pFMA!s`eo\|
	zE>0GrzM$>z(;glk5KI>H$*L~k;~UR@kH);G779^Hlb`>bSJ2of0owk8{_t`urSS7V
	zm\|D=safa+H%*;K\|kKa>M=HnIo0Cpaq@B7O!lc1f5;R2JX7CKL35YUuvCs%Kj1\|$gC
	zGq<+3qHB{NLL`^P!?-GDs@?zqYyl0O9SRU5uYgAq{G7+Uhmlz!0Wi#Pq{#ex41asN
	zBQ46VyL$C1MB\|PEUMUdCF*sMviwnO2It-WFv%v46q8y^zzyr1ps@?x?jM;Y)0h5L3
	z?qHxkJW=He!iioXL6pyWZ0PAS3>~o-M5$5BtP~TR`uaELg`WMyl-tjlqJ_GQXYH{9
	zobCr(So+WcO1B^v536`C\|G>Z!WsM6IJdFLz(Igy\|j>\|n#5dG59Ui&{3M$42C?3ppV
	zrr-10<g#=;>dMM45);?Mbhg6}&5smcx3#sECwh&t=n)KPoN5G}ocx7mQyqO7T>!*!
	z@%q7RtPKX$<5M9C0lCfsj@sDRxCX#IIz7~zaq6m&&@c~^<@YG=X~4-Qs\|(bE7eiYc
	z0X?C40~ojWt87{<jYuqk4MF%#x#N8%-MVYc2MK}@B9IFq%_#18VPSLOdzVhUcn2R4
	z+MeqGK95Q$0j-$^=R#KlnG?TGzF$9`6eNc7FG2YKfKYR(6pVuA=\|GkgI1akUgoF6{
	z!SUZ!EQIMQqx{jbKx1*ej{fe7Y^hIxKcZv^kk3GhQ!;LVNJXi};La(lGu@K`=C&R+
	ze^*2>F#<N$;X4pd&(s3y_y+\|I`lFFeg^{JK@H`PiyI9Z$-~gK\|m8+(HUGdk\|I1myd
	zTF?^BYi7BlYrfsL12G&O4fcZQDAxUgkdTC&{Oq6f>\|#_d%nKBWR@E}##No^>Y6te%
	z(B~-l_4e}iFQ=dS)!LbxO~O38sh^!}01Of+VG9@jjYGEoStZ}rdJA2l=ZOb$rnE$l
	zn1w5&!F)CoaS=DP>_CzL7qKYZmC8&jaot@(8XqKp=4Fh^2Xj4CO%YuS_wL<!1@WVz
	z{!vb~9BOpynbV(q%beQ}I}AU1sur5c)jIk!ngy%kg#wYnegqLEvp5=L@W17%#(7ql
	zxd*`Zk(9y!fls>q@)Si5A-da07JSb0SZFXu$NtZiMrz}mRwI2I2?J+&x)Q~6i\|Mj}
	ztTABFGB#T{iKklfLm~_Wy+3(I`@fssfeQK{WN!)$HVeP$?(R-1EACUI{!thu_qm6}
	z6q_G&fC<)mJH){!<D$We%#lU>hAH1z^o4-^9KsrkrzF=)20w>JRjGgzsC?HlNRr
	zACGEZn5+P9HI0sHy-X#IzE0g1$!Qb1bDos#^lf8fMjr#gX>~ED73wwp<=`xhLd_I8
	z6\|#`@6o2gdvnA<l-2$TwNTrOtW!h*pVNtI$HV;R38}(NROY(g&=_m=Y\|bqZiaIN
	z1ZVOz>KU_Bx#MoRUfwgJIgb;wGY6=GlO;m>%V6&M)vGT@OKn7^)vN7h&aFwR`0)dS
	z#=R{fc7zKi`St5pKY#!H_bL{=EREm$A0aVq44hmF8<&6@UB&=#^CMj;4S$>r_\|O^J
	zC3eGiG?#mRx2748N3h;M$G03Qv~JvCzh$OTV4SavH^gILw>ohvc00KIR9%dF@`88E
	zYMN&8Q!G!}^}?I>hJ#&Q3N#$xj;9c8zq~+oQ#}L+?7r)V`{S}_20)cjMtDmgO`*nz
	z=no(C3wd@yR1?$D1+^L%EL335@nyHi^%cwt9f)jhyUlgdWR~ir%2HqmXoQUmrvy09
	zYQj^%c;ey?f1YW$UrK(GqLQhK`5q^PF1E@n_54\|jg^>=s_NntS5s?(ucn371%60eD
	zk1\|^$hcl1T6`6hp-51Jc^lZ_ZjT563OZ`J8-kE14Ee57JD5(t1j+m>%&Tx;SiVn
	zb\|jXTZdpc8XK0mjFo*glNd}Er+I9ea!$9OSExsAf<>H1i%>jE+&LB\|d%#!%1sBd6F
	zFU5&@{\|)wY0R}@Ohz^Gk-Y^jxi\|;$Nk3AO$Ze*4&FDyvM3p-$j%I(wSyk#vS%dh_^
	z$\|)-o{8`sWp~cNoYWcV$48Q<b^?gvb_OsvfTi5Bt+{m5tLO&E=Ti@L)Fzsm5vZ=zU
	zwaBe96`~tJR~Y2z)yTg*g%g%V1_N+)JpA3z5a_68bj4(5W@d-u;xj(9>te\|pfb}!l
	zECEY@Wvo1c@pTn$^vBo!#nFSu&-z~DiK;VFq6)eZ+Yho#Cac\|%E8Wn#nQ6tEWqUY%
	zhJgBErfPPX>n;b%Tmmktx<5\|AV\|;e)3egl$>cIaS`=O}vu!)wI7RBnsZkHD?PF<v;
	zvIyOQ!1pHh!BhbUD{Fl;x9_(S(7wu4#3lsQBJ%Z0RySEG+aRRgMZ}5`bNz{jCLI
	zvd!5JYc(3YtV<QIHCP1GssW-&ujyAepBK=^Z!glIRm)KwS$B!SQgA{e%xS65%
	zB_tFdI`Puqbew9w@bivK)mr3huk3_2Gq3=I1\|O`ojdo5ghxSfzYxy\|Ammu}6Mv82\|
	z{1i#z7FQ{4GK?{I=ma1_mAywtW8qU3j?2<_@7~QAJp#x^5iTbu2WdvtTc%9M3EF_M
	z!}&(IAV8Ufg<}98iOI>o0e&ZbiH{d?Lgxkus0C3~b(u&GmCw2o5{#tJ)i@0QRmOI9
	zaY^Ux;o?TexMKLs(W!GheEgy;kq}BC=1HC>$C#~!{&xT=!rC>)jGZ62UgC<xv1^s!
	zJ2^R_6p`Dvy-a@n3KM+(=b}!<^ExhkbhW_KzAv9_EpZFXx;i1MM1wd2cQ%0W1U~MK
	z#GC!BtbBs#{tw1Y7;cnwb3>~n*><WKnf2W_=g`@uc6k~4bc0M^Dth\|B+h{aR7oVP!
	z47-dKo\|$<afi#m$#58acr0Sv7X=PQfU!O+XVt5bGWs9-nVQfE&dI-l(c9U)l<V!71
	z-)@h%F$`f8;DLpYFKlC`9cgTtyF0cw^s3`Pvm=TM;n+OXHtV%in@L-kKWI_Ay)^?6
	z%5N$wMGOoKzV3`zpyhi\|!~nnwAnnq1tAs(u*Fs?C(5c8X?`783(V-B0b_H#JE2k?i
	zJaRDvwt\|g0O23!8{S7(p4i&fwYR@RNt-ZLUtKm)-BMv037+PoWDve-Zv#fRk2j6
	z-S*F(Kc576r(N\|T+_WR6J53>x#Y5P0XGsGwYtY!Vw6tgoAGq6SmL6Ytop4-AePb4k
	z<l$DY0;nu65vP?k&>KpCV?Ov4^`J0!zoiQ!r3>5\|k#}e{y73F0Jr$UAGumcj{SiiO
	zfl_FJBtj5~px`w{M;!``ThV2GNR1;buYHNFU2ca1K7kg#qPUF^_vJO~WRwh~UXXC1
	z$HT*8SI_hMeE(ffg@c9I@t#p2wGgUS;Du`uh;~pqVg-2hYcW6~BoK49pM5W^AQ2bC
	zT=I4(icPjh;M;c~j-Nh#`no?G3rr*u&@O^q<1VO<J9q8?T{sMG4FZ1bpCS`k@a)&!
	z-@kvaZET<mHExc6R#KRy;WPtXnm=eB27d\|#>?K8iI#KJ`Pn%1ImXD=6iT}h%!>v
	zVjQ#{_TVA!SOT1!2\|%>=d7Z=QYGn3+mDG!~M<85sTb)_zMmTYixQ)CgijdXL4tX
	zTF4Hui&(~L#wp\|hXorDO9GzqV290<2?8j%n>ZdzmBViJr?QfXuERVJTBa~8CCr6u<
	z&{o+5(P%^~8SYEqkr27q&3?Rt7rJ%+3&c@$CJa0ZUC}i=YExs<^p+GA!W9q@K<$3~
	z`L#)WG(f~=J7*0lj4gvUHW9;5HCZ{whk8#t_uZJMyU<JlZR`WLQU`N^;5Q3~A17%0
	ziiAb}aEc#@ahk<o4m!RAy%g!+jt_3O@BVzBRkP@e@V%^AczUu{DN4Y81Qvvri2xQ(
	zY>#F;<EbFtFAQY2f4F+@EFqy8&\|J&$its_vvTd1{x286HGn}fkjrL5lgnkS)P<A
	z?K9$`rvF-=oybrWsDSC6k3g<+8CQf)5p$lK_`PY{UJJyf8>Pbp8lbO>dS4Z!BG6
	zDv!E&ZP9jdWI`(zC_L~0fT~6=e4t?8(2B0-u_%atbf#pwD=`t+<*%u!P}7zaTlU}N
	z_4W1WoGV!6>C>n444dAzBy_5j+nIoRsegrY9^FxeP6YcH<UQ%8cgXS+Bn4_@DXU~h
	zOY<mYkmL^pU>=7BWt2nOpQ$F~vcZV9QM0fBAqapCOQtKP^lX_&Cw$iu\|AZ;Y=Hf23
	zlJ88O+m-!Q\|Atk&>{-QbW!09ypXdmn54x1j<jyAAL;e$UG<kCD3)l=0#=^+>8bbMI
	zj\|^wJ_x(n5q%h9B{GJ$kdPDNI386oho}M0BYa7ZlsGxgC%sen7TRAOAtP<rnR0A}f
	zn3VKBI2Lr{aRxD3d^T+hV?\|c{tHHN7M@Iy{+TTk5n\|e2N;S^B\|;mD;&Lby1S12ga6
	zRX?SE_wXsSAZUAWaB6n;!NZ4VS5{Wit?k!<8vsT`MUlhQXUbnDn)9FO!=W!pIY)w{
	ze6G6Jw~r?V^K>&5#<t``k$sbHApP`o4c89=r{mNF1wnP^WFMkIiIEau_Y}+yi
	zkLnrSudTBf)_~weh`gqML}anCyNi+l7#SJWC+<l!cFz+iG!BqOr%qq{rdSJUW-K
	zzv1C7&U^mA`_ocxCr7(u<@UZPaVSNaG_!OPqBo-VjV^{l4ln(z((5I#!Vj3@J$_oo
	zWgXgA3Y$^3&<9?jr$6Nd+Gr&CTo%xrT5la^pyDqbTZwGfKFVQ*Z~jm\|vsmEp#-Es(
	zvc;T<n>!c=q\|l(@jK\|To8ZimU`sOCeZUe~t`Rmsw`H&WrG=SNd>q1og(ltyifKlHt
	z{qIXadGondqC\|y%D1S)z$Y)}b<qM3j3#1X*gXwMoV?EiJ1Y7Nbwm2_lm!h>`K(z(-
	zeFbnY>?<-6>^IFPdwWT\|fSx&&_zB`5c5^_l^yc3HRy?Ygm>TNt02T^C!S-Ow9DKS3
	zq{(oe0e0+7E5rKNct}!!W21Cklu_sqb;ttdgUQjYdK$XZLCQWWO+rK@nRbqZhzdP5
	zqa`IBf53!RPde%ewa90X?;C)2SfEq&P=Wi%$jF&V5VacUc1bXW_SbkMXw5SrAwfFs
	zTMZ8jk7aSQU%8H!+&*xz&A(D;4p<E~{@hl&lX}n;@tu@eb4vx<jMmu!@UXZXm((wF
	zXzxWD`)j1iMx#sb5a40Zu\|GgN72Gz4{l9;Wc>b07w^TIQ*dElwMhBArKcmqb7AJW\|
	z`NgU1+r1GzhFS)^0VV-P7XASNGjGUruYiI\|xaGRBGiq}(XMy%$(3S57<XbD_v6W7%
	z84NR@&~b<WO8$rP@}@@z+p1Q7n**p&sXniPY^}_~`;9{XXG+uEFH=ut`0l=YWwZE$
	z5=<lT$?rygbesoeIhb\|EwRnt!R!7GG$T)S47y8l{9=aq05z}mraUoK-KqH0N6z~Wj
	z4-fwH2WR?{>Tk*h8{hsnL}6Urf{uLM-Q5xM{Jm)kEEWS<K}VW\|goMCMPS=7q@Cyp+
	zT03%?X(R1S6hBEkDeOP>WoMy@OfUIK_h)EK9gnHvB1kMG+nqo75fRy5hB0q!rcSSC
	z1WOTbV6x05aU_^^rfVw>Gi7JE^%l_L9a<JUeq7H`3Nigl$@SqHzi`\|AEWI#Pz@*
	zuffOOrt&@i^W!D`{kQ1m10d@6A~\|$;EcGaT>L6;M+oro}ws&?+A#75l+Ki2lqhJf)
	zogH_YOpy}D{^7v^@URB@_hpMLIeK2!Cj0hQpKy9c}OvbpBy_0qCe~qF8)1ubCY%
	zMakoFAT?-z8^X_f3SQ=>(KBoxUu<0vd&1^j`~?u?&w;#4O?2W9LRwM5`;*ul92_W9
	ztvgAQ7t\|JhJQsJgEPU?)_9Bt6!$Kq2LX?m_GelH_)(\|G>%`gAaa_4n=tI?7f2=mBY
	z6vU5\|<FC_qlD4Oxm$3Bg-I>!Lnm~0_(VI>aF1`>wLpb%sfWWpu+cZk8X{ZFOjq6_F
	zAe4mwModQ5Qvc>WD{v=Ndg*q`?Oy8?m3oP}#oVwxnP~Va+u83FNR&Q%_U!E_zyKl2
	zNFB`4L3OKXt_Sf!h#4s\|Z$PVDL-`CgU)Rr\|<>jTpT)mov7=8=1>oB#rp3!TViAn
	zy!BH;DFOk*_Vva9_9zv5dfHezlA~j9eG0<NI0JUAd2i}^1EDyVVdGiH<&h?c)`+QW
	z&UK-bwwI})r+<Q)0i^yVe$qKUP6HrOxvan>%d-R4hzekRw4dt)1(aMC4^ypFXex*H
	zXwj-zSHdk`V^2z-J156SC&f>D*uhW~ifVIuPh(kIgJAGMi>S~cbc6yeFr6W!mGvc{
	zxu%lQC$39EL(`Ee7aJww#4+i4ati~h+60{N5}WcvvI0NBNv9Ox!6i!$(w#7e<YI1u
	z7<3>8{Gz2}xu%8~T&w{sIa<Jm7HzQrm1SgRE_gn#h@&ij@riKnS5N4{ilCze7!S@B
	z_}6d6\|Fq8!oka$-G#z^F-)d}le7H}k9<+W-$fWHOCI8dLwO<Wr&m2{_ae+So`=m#o
	z?oPKy1`Q3V(=#v#+5Udb^l4>g1\|4K}nF<h444)<;%18V1$#rtELKlnEs5X(nBb2s-
	zjvh2xp)}G<oVszSkbp^h1Y-X(rygLbw1tv-((=yp>&BZ*cxv7_$gs8a1aOQKaSBvQ
	zlMiN9Vy3)l8MUy3S_LyXT<u;dtVSyX0tQIsPcQ;AV1wwy0Lok2SsL~{w0d)n6x~LG
	zeFi_TlI@;Z`iDzIf6+-qKFK\|UqSAB!YIoq1-&RyacRENtE@;fU\|L*elMDfIlDp%eY
	zTTg_a\|G5prNcw~gQ+hswt5tn!C>T2hOcv\|s>Z$_#hSGRKO^rA@MFA!@!-KmpOSP
	zew!yQj<xmk)rolEX<#Wdh\|2-Kl)u<!o0yombnTHBIEG^KL!wGikLCA_^f&jdmC5{)
	z?84\|CxMp%i-UZ4L_~CnRk5v;oeguH94#IUV$1!75qg9`lxYYc1Afn`Bo<f@JLh?
	zhq?qEw{Fk>tn<bIFX>`i2AQw;)!8<XPP{X><~ZZEzi7VYZ~;0#<ST57ey`*s3<A64
	zJ`BQZe<3Lzh-NIBU$!S@WBB~h2EAd^Ie6(#f~d=-C&EuKE3%u%Dh468&G\|{V(jXTw
	zAK`JT7KIOk(Us3}&_nY_Z~gp\|KM*s6B2`ebL&p?=)3wI%U+)q>`Px5{t(;B_6mc#s
	z(c^b!ZuMuiT-\|egq+TLN#c7)<9{CZWEDEO{rOHxd7SGSk;X><-$ww%pBrNaXk#rL#
	z1q>^_X)T@fI4`R1$_O+-)v6M7JrZ-4qa\|{9p~~;gx8H3e_)8uPqn5l7_BkmDC4Do8
	z`h%L(%GTKwCXtSM_~27~utei!pdm+GBT=_hq5xoMo%8Ceio-eeXuZypaa{W$d;fzu
	z?P$mg>8RwOt(cIhFE2yNE0Xo=UOBtCXk_cy*H7D4qqU4_qWm~;#vOqTVC_A<=<3C9
	ziQ+Z=qa2SuVlWU06hB74{i$_icnhAis;*iingGNDOWoZ-)qaDCgF`-^ot{4AZbd9n
	z{`P%SNmAw#$L5BB@-OwpcQfGOcVTW&@Dx?Y0p^XGhCDkUVxg\|g8+SkF;N`ar>
	zLusRbaTrF%zx>=Zux(YFQSB<lJpDU3%IRl$PDD)^!^NMSh*v8cgp?GW9\|$dX\|9eya
	z=(W`B_h>ALnrbX)t#ivmQRj-G)=n4~@Nq5-sD%6%qmn_iNA0dK78+~W9{IF#tx}Wu
	zSspH;CGt@~M8EvMOF0m#m!3$=zq@<`GgM+l<+M6c{B%^$W1k5Fs_WbrMIz%2y(~$P
	zZZz!+kuAs%Y7g*8Kx5tpSw\|GC+++uwd-T9w<HZZLXyq@D5OJ{GUD2uD`+YvMn2MIR
	z^CdR!e}{V>VX2&Za)D$~CiAs_YJ#X6d!`<3kdT342aO$OY>d\|O^%s7WfuktzG=rLT
	zeCcqcp(svG*9FJxanb{g?6&Cufr(l!{EFxEcfqP@MSdt7{!DcLe7pBxFd;jm^7~+6
	z^ZH4#)9M\|~2nV{_nzFp#b{\|N4NDXeAT)q0{gEtcn@vBefsig7?Q7Kce)0VCbe4&{L
	zD`IVlE0Qg=wTxlEPeJ%{whRl;FJ{WGz)u1@=i1qJueayFdS1Fdc2NC!rSLDin;35(
	zzOV22r2Dw`;ObxP!K1R8{__~e-tA=K+vefD1fh)4!VXUfZf*U@(k?F$65Z#ruG$^\|
	z`FcG(Jbb^7&\|\|HdQm(F6B$hcqsoj=Q67wUW*<6Tv^fboNlpmX^#OT^1g7d%I+S<mP
	zrvlQyeEGKOv0JHa-@#9}SA2XhSc9^FWJ0tZ`c;IcKiuO}ru)Dklwu))!)(PHf%Cbt
	z?BeyLIc+S=8y8Kyj}Dg`no`Sd(6}z;?+<r*L`;jfn1jwcsO~DCeAaM5=+\|qKjR7s2
	znfJV%-%6{uZv>d0=bNPLh+yC{AI;C=ShWef)-Q;I5o;99KK)2@rli5R5<pCFP}kLp
	zjg4(1Q}2lFo)3O&ywkf!n+-`G4?%yZq;?^F4iiVTD~{BIxFGpNuy#vJU3r0bgvh
	zIBwJhQ)8~_(S&0()68Ys%zRrNCy#eZd7amO#@TlYrRU~$MOJU6EY+MG?~l!iMS}QC
	zwVA92%3!3Lqa6*=hJ)9v^ZR+uuOFtx6aPHxS5cdJb)MtLqhc?b79Ses<s>5h!2T4b
	zxw9\|vFky5r@xs0SGb0)H>O+BvpGH1-)TFIJ7`qBaIh\|)i8$HZRZ~%!`Oe$JzPyU
	zIwpqlLO64wrBF!kP0@zwBU?sXOj~5_X-#wPuSN`yturz*HjY+3#d}lb(318>EjFR?
	z{>F?3sO^}T7)2$eP>-X7nJA;c8CRQo+LefYjN_B\|O>pGdq0p%UoDq8w^}8iLaLi
	zk$U95`3rsG1+8#F<@#oh+dSptmr{$0k-IHufTqyw6}25b4D^wf<NKVWAwzuZo@cx8
	zkN^\|*3nt@-@Vj3$RCvF<9w^C4=k\|%np2lvrlj$Tn<$$@?@b9}zT-{He@{Ia02sIbj
	zp2N72tMWcti2Y7La-pB&B7JeqgFeBV5n6VE7r$WNrs(XI#-#Ko&>oCv^2I#up*+pp
	zY(r7hbN2q=r(80<ke%xD0wf1xzdbbAQNwxh}6_iBi%I^YQ&)D15Q>7GHjYMAE*l
	zT&fZNavDs)$w>uyJD6f&!)Z*LQ-bQLyern3KGI3)%qfgq=2VVRQFIvn(&)5sjC2<P
	zNkD2$k=RTBe9O2~7&@PR{G#T7SsIB8{jSd#)1L3fCt!7ciDC7PZtG{~a7jS7IT%
	z=r!(oEBAN7miU+`1+HVDIXKMTj>N&hqW9&($I)z1m$i2&a(qJo^(^ib}Z`W@#YH
	z^dk+Y-y7_w^(P&{)J84}v}rn(j&dQEV`ceGHM7gPsGv7`a?F1%cqm^;bC2OdzeucX
	z3wc`&(TzZp!SCuEEw&Z6zN727wGNA^sHmI{M4%_jQ(>qlp-wlIC^MXFs^2`Ene@Bd
	zQea`q?)l}7y8o$dnuhnwl20`2-;!Q002@(ORZaCgIp(;6soX`==\|R@G+#SgO<B@sw
	z=%)KzOuCFvP%p5+G^3V4Da{@AP7(#tU`C<CwT9Tl&{LSoW#o\|1`>%!3J&(+JWI6~!
	zOK931KNKGcE<?x;N&fWdQ<LuIdJCOG2tL)#?@ieHrDox{*\|tf;1{;B<(n;mKT@6q4
	z0{#RV4GVhgg0EYNi&ML;)k%c_nJXT$m~a@>kqWV$YA$!iEFEta5#OGNZ+0>(-Amc$
	z;D0GK8ffxMZ#1ZPWMqV~6+C^EK6kf~L;+<rq-SKbNwLIF\|HjH2Eo}2vy~5>U#+%aJ
	z=T<uRppRcE^0Jm+_%q+uU`g8O>1886x&f=w@d!qt^+pm@sELfwYupno=E>yw-#a6+
	z=3g9PCfct%=qoM^3Pf}e(hdCSP6}m&ICS)5>Nz?Wwm%yi$_T)aa~`)gfm`7^R?#Ys
	ztez`\|Gm)RiPg%5g$2ge3Wvo@uDFg-Zh4+0GDKeksDg?`}<J>L?N&O!fj3Q!(W7(
	z%~UqV^{?@SW}}R>1u;AC5v0!xg>05^=v44\|_RWAgx)69WGQqw~e(iB}z>^I}{Q}2j
	z&8CT$wbSk#jnd>xD$2^!ds9IQA!8nYm+AH#OuG`\|N3APw&<H>Orr@zbLUzIHmf8RH
	zF7=)-0cD4ifv*(mUr&wa38R#\|yZcR>iL9T^b{d_8W{K{OA=7~(D\|@$3W~+g43r)S}
	zEpSIhy%$+!T&Vu-I>}1Uesgxhj~T}`Du%zr8XgG4&FX~!c%p9(oUKt3ZI<o%HP!
	zPmrf!EQxN4bte\|CQ#Pf_F7JC`dS\|BSPMj&JsO$kqt8&FFt;Z\|kp7%((fLh?S9LhU9
	zoD+Ad!we;<N8h`CF=}b)Pg0QlMj\|dzfqf_\|mw6ptPUGsB)1M!oT-e3eYO&89>jeY^
	zNKJ?pNPulD-)RLaiWIV+UFu2H0(r$O8};GMc{0<Jqus8=<E=E5w}gYO-xUKuFmm#$
	ztZI0\|SZwd7H)_4>)}K%0H;n&^?2eXLT_3J;8Zl2}lJfXFI+>cDF4Y~%4pSlph?_)i
	z!Xr-YG-fNb`JJ~Aj5p40qjhzkyMa(_Pv3`tCI+-XN@^;zCwx;;OKZ^(D{rm?!5xI2
	zPG*IKIOwqnjF`(-w<IZJYk^672qP}_GcUuU4>Uoq!xqXK=EP6-`}+EfXWGK\|8\|aSn
	zS_a+bds18u=F^k_Yq*V?$zQJ;#YG%UrGuz#rgrFijO=Q2UcplssEY\|DC1s4KJIMa>
	z)#\|@?^>{4C5Q\|X60MQsHN$bK05!Ch*W{3e#_9MSFpNOnu50LjbkAr!s-?E3E9Z}p2
	zQf}I2c$D3WH<RLp9ohtH_B$9`QzCUMT0A#;2\|f237+V\|tNtPqn3im%j%qcYOX!B=D
	zh#J)Myd{3n9n@3lw7Ru8$O#&>UF`2tD2cq_)!lI?y`2$@T(>!q$=1*J-)(dUdGy^s
	zrQa3*A0~%7Rs8w<t\|wh7ZOnDGs{G{m@9rN>QGg$mYruB>x_yrn3kCHJ<Cfawu#P`X
	zWO{LR-neO>K3yf#epW}TwTiS9*zLpn_wRcgPSH_$RaRWIXu4emnzbBUbtAIokSXzS
	znxz-wdzN}W{dLu>Zv)v{_CH_ZnvN8iqfpI1s67?Ugo%O%Y1-Uj=W-eSc*onWl_`=@
	z3MfpBnx4BuPwvt_C\|n>8-tYH@&26a%00Z5%HOJ8ffC?qTY!x8n5Nj$pmC=uG-mj
	zo`>shGuQQ6ORPrie!U?x9m+E}^ONIgHiMAJK\|NXZ2Si~yV)!+HfM4d&jw-eoH0{q&
	zDL+`qv\|p>kt>nU7e2G`\|c3DK0x^;M%R82b=@Q+=uS~M-rP8$67tEBr07{P<;!x>Jq
	z))1!o$r?\|NnnOG9&!+>PSnwqoHNS7&9@I-@+@IL39z2}7RhOkv$m4Oi2d;LNgjx0*
	zblPaGD)Egv747g+car3TK<a2Bh6j7f3>fE96xX+?TV0$~R8*o-RhG<5B{j83#A#e0
	zAnp3C9u*JjwkJ!4@>mRHJzpN--yO3LG7~Gx8^D(hnFik24ptL`4hDaI$I)gIsWXsK
	zc}7!9Nl6JBxgnb%DnxbD@*CKaJ=g~dJ!dBWYWTS{lVZYFA>ioW8H+e`fig^F^(!wl
	zp?r73mDju{dHmS9bFAE+KKdDufIQ~qC$9g($h0g@b_8oPZGO2Jug~lQWXtKrjj;
	z7~Gog<%J#}!t{(RKh=T`1T#p^dLGYt79j5h5{UYSb~}GY154QbA4>>5nKTpIj7B^f
	zkbD2{<Vgb94yyi8Ilf!&xICim{Ob*ch@)i$r(OaU_L=0I9FD\|;zBK$-#N$p@-S6dN
	zZ{7fukgRZ8O{l1-z^4)BLo{~6ZL`BsueXKHQxw3_t~rn<HZ9==+b!3f@4#xKCl6-@
	z(zCMo{)l;%IQ!sX@+?j>\|DY6zak@C!+bu~Kk1B+G`*2mG_^ArBTufN5`?7`0d`jfV
	z(eA\|P}F>HT3SiT%^I)<giLPRnR?e3S!Yg?n_1-$JRsd6C6j(T^7>Q>;QaF*82X6
	zQ%x*(p-d=bt{$4Y2FBdx)RsRIaqawD8(Ze*=QeKqKOa4hwD`Zg$P}DJk&(_)dt)
	zbM5>es^w6KIzL0!yV)f!E@iivU26KX_GS6+x7Q0^Y%e(O9`y\|lnt_we59aD\|R4x@{
	z=~Uiq@VU^=5F{F+WmDC^{zmmj#Oeecuz~c<%=T5!lfN)$EbS3D+6QZnw-J;eT#Mk)
	z(JXNot#Gh_2y3_AM3x3TU1%muiN\|$k>G?tt698YJ$sb^cX0O`QgH}J39tshNnm{
	z*CxfRV+jbPSJoN`yLh`qLw)Hy1gBbp)IR8Nc^)5XgO4MW2}wprosYJ9?RSRF=13Cv
	zB!)f4FI>0)i2LApuSGmHCnraUk&4IoA?gIEYLhhIU`0*fbREqBRE3tq1vihr^vT8E
	zoJozfZUe8Y>E)FR6khle_hKO(Rl+0?KU}++4ep(}@#7xh%qL&kHdLizqn%UWM00hb
	z%6>q@Y-Y^9ORmP_2tVuc)>2`YDa`eJf2JB*bI18bqnfK5k4+$W#a}>I+x}xQ05~bK
	zD+TeR=P2;wkuYET#xYW2rL\|K1cSYNEx!7eXza_@=7=ErJj8%!pWn=n1?X3zqY`@gh
	z)bEMnHRY{t=o6EyIiUN@#QzSxvrE89q&y!ySI7Z8Yh=D`#Y6w6M6yt6%GN^W+7H
	z4!c1er<syb>-MGL!rs2VBBg8Gj!Q%DDf!tLBm=(_Nm2(xfGge`Tmw5Y0j+\|d^>@>\|
	z!e_tgMR$gbR-FZxfvQ9TzvKqPe+pJS-D@K~4Jh4i;7b#6v@^;HVDk7PUsu`eqX%I9
	z=X@?uMR=>CPwpHs0QBJQODUw`E`-8))lP0rrE8+cBQil0me{86O1E#siF*?XCS{
	z`s+Ng9N+{5=kg8Bu>H-sIS5kUV5%mMC5!L*!axWk6qOfQE~0+^;\|_-\|RYp!uC&G6y
	zb2G4DlhP~jt0!@PS1LJ!#18(*Pd%yhCJ?^neddDn$?;KdnnEIkX>=6;VxSYQtMMSB
	zpU?L&k&=?mPgJ=A%P9ovJ$qtvVteo2z0Dz=YPWs)I~\|VjzR<=u23~{u*RoMuR{^A@
	z(&XduKNDxdSk=D7E`-2sI$q&$?$s>CAoXeHJTnS0H\|GT48KOW\|qWR22Ub&qGt<hGs
	zI}r;L#zF\|<ztZEht(=@3!b^lk3W;JuK#+PN7K0s$%>!V9StmYU8p_`v\|68>)vZxdL
	zo!??$8e*v\|j1ejk(M$A(#(kQBu61vH3N;R~9DtOd^D4~X$l>VI@Q4nWCe;$XxmcU(
	zXmr;Y@}0}<>i>uq7&p`3zksDN5T_6kZ15%QdMrs34l%_!N1h5GlZ*#U>G\|To4Ipm+
	zb+FCvsQAY@(XHYckWMCTVXWX<(k0g8h)J1r#tEU\|h*Ipy^xU\|?AI+aU`IZzUHuBrk
	z6ZMyXI_l~@AHLP66nsw}ZStpnEs6}X90wA?Ydu!>o=PBRe+~kDB$G^pF$72#zzuX*
	z;}Gy1ojF0;Xm+yDYP1AJM0no6ff{$3j6crI$&v3$xMlzCs&6uYYH@M#{CH()-D76a
	zEz<u)`peqn=K;;%f*BA_&L&z\|T3TB3L~`iF`1tr_X_xbGLL>%{LA!taC)KD_=TtLV
	zVHrxVTLSxlaN3(B83g#2yC1&?0~R8xbgJV\|<vfbR0hHm7lOB\|RsLbCXUg&n*8MTo!
	z3%`cJVDq9}fEsr7yxUiIu7rn&C%E96+\|@soeOtfh1&TE=(#DN`L~mc3h839k;;oje
	zuMXL!37i=^+WyncP-xbrdiI(xME2TO<YTV-?@#@=aI>\|<^\|Hjk7q9smX6=qp2zK^I
	z09RCnu&3PKtjSCDc`X*Mac<R)bW32WNL%j?4KuLhc3?H4w<$4genF&XFi#l3Z>4f\|
	zt3nuI96LnhF<vEeHv}+V\|If@WE%l!6Gv6*&kzoPP%\|s>!28MtK3)cfF23BD4%)rpV
	z)W`{>92yU>0I3BI31B4(28=TLtq9-p$LZ$h~i>V8`U<djU;VN\|5>2#JarU_@V$3
	N^>p=fS?83{1OW1_)CT\|n

	diff --git a/thys/Closest_Pair_Points/Closest_Pair.thy b/thys/Closest_Pair_Points/Closest_Pair.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Closest_Pair_Points/Closest_Pair.thy
	@@ -0,0 +1,1582 @@
	+section "Closest Pair Algorithm"
	+
	+theory Closest_Pair
	+ imports Common
	+begin
	+
	+text\<open>
	+ Formalization of a divide-and-conquer algorithm solving the Closest Pair Problem based
	+ on the presentation of Cormen \emph{et al.} \cite{Introduction-to-Algorithms:2009}.
	+\<close>
	+
	+subsection "Functional Correctness Proof"
	+
	+subsubsection "Combine Step"
	+
	+fun find_closest :: "point \<Rightarrow> real \<Rightarrow> point list \<Rightarrow> point" where
	+ "find_closest _ _ [] = undefined"
	+\| "find_closest _ _ [p] = p"
	+\| "find_closest p \<delta> (p\<^sub>0 # ps) = (
	+ if \<delta> \<le> snd p\<^sub>0 - snd p then
	+ p\<^sub>0
	+ else
	+ let p\<^sub>1 = find_closest p (min \<delta> (dist p p\<^sub>0)) ps in
	+ if dist p p\<^sub>0 \<le> dist p p\<^sub>1 then
	+ p\<^sub>0
	+ else
	+ p\<^sub>1
	+ )"
	+
	+lemma find_closest_set:
	+ "0 < length ps \<Longrightarrow> find_closest p \<delta> ps \<in> set ps"
	+ by (induction p \<delta> ps rule: find_closest.induct)
	+ (auto simp: Let_def)
	+
	+lemma find_closest_dist:
	+ assumes "sorted_snd (p # ps)" "\<exists>q \<in> set ps. dist p q < \<delta>"
	+ shows "\<forall>q \<in> set ps. dist p (find_closest p \<delta> ps) \<le> dist p q"
	+ using assms
	+proof (induction p \<delta> ps rule: find_closest.induct)
	+ case (3 p \<delta> p\<^sub>0 p\<^sub>2 ps)
	+ let ?ps = "p\<^sub>0 # p\<^sub>2 # ps"
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest p (min \<delta> (dist p p\<^sub>0)) (p\<^sub>2 # ps)"
	+ have A: "\<not> \<delta> \<le> snd p\<^sub>0 - snd p"
	+ proof (rule ccontr)
	+ assume B: "\<not> \<not> \<delta> \<le> snd p\<^sub>0 - snd p"
	+ have "\<forall>q \<in> set ?ps. snd p \<le> snd q"
	+ using sorted_snd_def "3.prems"(1) by simp
	+ moreover have "\<forall>q \<in> set ?ps. \<delta> \<le> snd q - snd p"
	+ using sorted_snd_def "3.prems"(1) B by auto
	+ ultimately have "\<forall>q \<in> set ?ps. \<delta> \<le> dist (snd p) (snd q)"
	+ using dist_real_def by simp
	+ hence "\<forall>q \<in> set ?ps. \<delta> \<le> dist p q"
	+ using dist_snd_le order_trans
	+ apply (auto split: prod.splits) by fastforce+
	+ thus False
	+ using "3.prems"(2) by fastforce
	+ qed
	+ show ?case
	+ proof cases
	+ assume "\<exists>q \<in> set (p\<^sub>2 # ps). dist p q < min \<delta> (dist p p\<^sub>0)"
	+ hence "\<forall>q \<in> set (p\<^sub>2 # ps). dist p p\<^sub>1 \<le> dist p q"
	+ using "3.IH" "3.prems"(1) A p\<^sub>1_def sorted_snd_def by simp
	+ thus ?thesis
	+ using p\<^sub>1_def A by (auto split: prod.splits)
	+ next
	+ assume B: "\<not> (\<exists>q \<in> set (p\<^sub>2 # ps). dist p q < min \<delta> (dist p p\<^sub>0))"
	+ hence "dist p p\<^sub>0 < \<delta>"
	+ using "3.prems"(2) p\<^sub>1_def by auto
	+ hence C: "\<forall>q \<in> set ?ps. dist p p\<^sub>0 \<le> dist p q"
	+ using p\<^sub>1_def B by auto
	+ have "p\<^sub>1 \<in> set (p\<^sub>2 # ps)"
	+ using p\<^sub>1_def find_closest_set by blast
	+ hence "dist p p\<^sub>0 \<le> dist p p\<^sub>1"
	+ using p\<^sub>1_def C by auto
	+ thus ?thesis
	+ using p\<^sub>1_def A C by (auto split: prod.splits)
	+ qed
	+qed auto
	+
	+declare find_closest.simps [simp del]
	+
	+fun find_closest_pair :: "(point * point) \<Rightarrow> point list \<Rightarrow> (point * point)" where
	+ "find_closest_pair (c\<^sub>0, c\<^sub>1) [] = (c\<^sub>0, c\<^sub>1)"
	+\| "find_closest_pair (c\<^sub>0, c\<^sub>1) [_] = (c\<^sub>0, c\<^sub>1)"
	+\| "find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>0 # ps) = (
	+ let p\<^sub>1 = find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) ps in
	+ if dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1 then
	+ find_closest_pair (c\<^sub>0, c\<^sub>1) ps
	+ else
	+ find_closest_pair (p\<^sub>0, p\<^sub>1) ps
	+ )"
	+
	+lemma find_closest_pair_set:
	+ assumes "(C\<^sub>0, C\<^sub>1) = find_closest_pair (c\<^sub>0, c\<^sub>1) ps"
	+ shows "(C\<^sub>0 \<in> set ps \<and> C\<^sub>1 \<in> set ps) \<or> (C\<^sub>0 = c\<^sub>0 \<and> C\<^sub>1 = c\<^sub>1)"
	+ using assms
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: c\<^sub>0 c\<^sub>1 C\<^sub>0 C\<^sub>1 rule: find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) (p\<^sub>2 # ps)"
	+ hence A: "p\<^sub>1 \<in> set (p\<^sub>2 # ps)"
	+ using find_closest_set by blast
	+ show ?case
	+ proof (cases "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1")
	+ case True
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "(C\<^sub>0' \<in> set (p\<^sub>2 # ps) \<and> C\<^sub>1' \<in> set (p\<^sub>2 # ps)) \<or> (C\<^sub>0' = c\<^sub>0 \<and> C\<^sub>1' = c\<^sub>1)"
	+ using "3.hyps"(1) True p\<^sub>1_def by blast
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs True "3.prems" apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by auto
	+ next
	+ case False
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "(C\<^sub>0' \<in> set (p\<^sub>2 # ps) \<and> C\<^sub>1' \<in> set (p\<^sub>2 # ps)) \<or> (C\<^sub>0' = p\<^sub>0 \<and> C\<^sub>1' = p\<^sub>1)"
	+ using "3.hyps"(2) p\<^sub>1_def False by blast
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs False "3.prems" apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ using A by auto
	+ qed
	+qed auto
	+
	+lemma find_closest_pair_c0_ne_c1:
	+ "c\<^sub>0 \<noteq> c\<^sub>1 \<Longrightarrow> distinct ps \<Longrightarrow> (C\<^sub>0, C\<^sub>1) = find_closest_pair (c\<^sub>0, c\<^sub>1) ps \<Longrightarrow> C\<^sub>0 \<noteq> C\<^sub>1"
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: c\<^sub>0 c\<^sub>1 C\<^sub>0 C\<^sub>1 rule: find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) (p\<^sub>2 # ps)"
	+ hence A: "p\<^sub>0 \<noteq> p\<^sub>1"
	+ using "3.prems"(1,2)
	+ by (metis distinct.simps(2) find_closest_set length_pos_if_in_set list.set_intros(1))
	+ show ?case
	+ proof (cases "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1")
	+ case True
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "C\<^sub>0' \<noteq> C\<^sub>1'"
	+ using "3.hyps"(1) "3.prems"(1,2) True p\<^sub>1_def by simp
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs True "3.prems"(3) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ next
	+ case False
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "C\<^sub>0' \<noteq> C\<^sub>1'"
	+ using "3.hyps"(2) "3.prems"(2) A False p\<^sub>1_def by simp
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs False "3.prems"(3) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+qed auto
	+
	+lemma find_closest_pair_dist_mono:
	+ assumes "(C\<^sub>0, C\<^sub>1) = find_closest_pair (c\<^sub>0, c\<^sub>1) ps"
	+ shows "dist C\<^sub>0 C\<^sub>1 \<le> dist c\<^sub>0 c\<^sub>1"
	+ using assms
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: c\<^sub>0 c\<^sub>1 C\<^sub>0 C\<^sub>1 rule: find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) (p\<^sub>2 # ps)"
	+ show ?case
	+ proof (cases "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1")
	+ case True
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "dist C\<^sub>0' C\<^sub>1' \<le> dist c\<^sub>0 c\<^sub>1"
	+ using "3.hyps"(1) True p\<^sub>1_def by simp
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs True "3.prems" apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ next
	+ case False
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "dist C\<^sub>0' C\<^sub>1' \<le> dist p\<^sub>0 p\<^sub>1"
	+ using "3.hyps"(2) False p\<^sub>1_def by blast
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs False "3.prems"(1) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ using False by simp
	+ qed
	+qed auto
	+
	+lemma find_closest_pair_dist:
	+ assumes "sorted_snd ps" "(C\<^sub>0, C\<^sub>1) = find_closest_pair (c\<^sub>0, c\<^sub>1) ps"
	+ shows "sparse (dist C\<^sub>0 C\<^sub>1) (set ps)"
	+ using assms
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: c\<^sub>0 c\<^sub>1 C\<^sub>0 C\<^sub>1 rule: find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) (p\<^sub>2 # ps)"
	+ show ?case
	+ proof cases
	+ assume "\<exists>p \<in> set (p\<^sub>2 # ps). dist p\<^sub>0 p < dist c\<^sub>0 c\<^sub>1"
	+ hence A: "\<forall>p \<in> set (p\<^sub>2 # ps). dist p\<^sub>0 p\<^sub>1 \<le> dist p\<^sub>0 p" "dist p\<^sub>0 p\<^sub>1 < dist c\<^sub>0 c\<^sub>1"
	+ using p\<^sub>1_def find_closest_dist "3.prems"(1) le_less_trans by blast+
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ hence B: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>0 # p\<^sub>2 # ps)"
	+ using A(2) p\<^sub>1_def by simp
	+ have "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>2 # ps))"
	+ using "3.hyps"(2)[of p\<^sub>1 C\<^sub>0' C\<^sub>1'] p\<^sub>1_def C'_def "3.prems"(1) A(2) sorted_snd_def by fastforce
	+ moreover have "dist C\<^sub>0' C\<^sub>1' \<le> dist p\<^sub>0 p\<^sub>1"
	+ using C'_def find_closest_pair_dist_mono by blast
	+ ultimately have "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>0 # p\<^sub>2 # ps))"
	+ using A sparse_identity order_trans by blast
	+ thus ?thesis
	+ using B by (metis "3.prems"(2) Pair_inject)
	+ next
	+ assume A: "\<not> (\<exists>p \<in> set (p\<^sub>2 # ps). dist p\<^sub>0 p < dist c\<^sub>0 c\<^sub>1)"
	+ hence B: "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1"
	+ using find_closest_set[of "p\<^sub>2 # ps" p\<^sub>0 "dist c\<^sub>0 c\<^sub>1"] p\<^sub>1_def by auto
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ hence C: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>0 # p\<^sub>2 # ps)"
	+ using B p\<^sub>1_def by simp
	+ have "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>2 # ps))"
	+ using "3.hyps"(1)[of p\<^sub>1 C\<^sub>0' C\<^sub>1'] p\<^sub>1_def C'_def B "3.prems" sorted_snd_def by simp
	+ moreover have "dist C\<^sub>0' C\<^sub>1' \<le> dist c\<^sub>0 c\<^sub>1"
	+ using C'_def find_closest_pair_dist_mono by blast
	+ ultimately have "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>0 # p\<^sub>2 # ps))"
	+ using A sparse_identity[of "dist C\<^sub>0' C\<^sub>1'" "p\<^sub>2 # ps" p\<^sub>0] order_trans by force
	+ thus ?thesis
	+ using C by (metis "3.prems"(2) Pair_inject)
	+ qed
	+qed (auto simp: sparse_def)
	+
	+declare find_closest_pair.simps [simp del]
	+
	+fun combine :: "(point * point) \<Rightarrow> (point * point) \<Rightarrow> int \<Rightarrow> point list \<Rightarrow> (point * point)" where
	+ "combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps = (
	+ let (c\<^sub>0, c\<^sub>1) = if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) in
	+ let ps' = filter (\<lambda>p. dist p (l, snd p) < dist c\<^sub>0 c\<^sub>1) ps in
	+ find_closest_pair (c\<^sub>0, c\<^sub>1) ps'
	+ )"
	+
	+lemma combine_set:
	+ assumes "(c\<^sub>0, c\<^sub>1) = combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ shows "(c\<^sub>0 \<in> set ps \<and> c\<^sub>1 \<in> set ps) \<or> (c\<^sub>0 = p\<^sub>0\<^sub>L \<and> c\<^sub>1 = p\<^sub>1\<^sub>L) \<or> (c\<^sub>0 = p\<^sub>0\<^sub>R \<and> c\<^sub>1 = p\<^sub>1\<^sub>R)"
	+proof -
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = (if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))"
	+ by metis
	+ define ps' where ps'_def: "ps' = filter (\<lambda>p. dist p (l, snd p) < dist C\<^sub>0' C\<^sub>1') ps"
	+ obtain C\<^sub>0 C\<^sub>1 where C_def: "(C\<^sub>0, C\<^sub>1) = find_closest_pair (C\<^sub>0', C\<^sub>1') ps'"
	+ using prod.collapse by blast
	+ note defs = C'_def ps'_def C_def
	+ have "(C\<^sub>0 \<in> set ps' \<and> C\<^sub>1 \<in> set ps') \<or> (C\<^sub>0 = C\<^sub>0' \<and> C\<^sub>1 = C\<^sub>1')"
	+ using C_def find_closest_pair_set by blast+
	+ hence "(C\<^sub>0 \<in> set ps \<and> C\<^sub>1 \<in> set ps)\<or> (C\<^sub>0 = C\<^sub>0' \<and> C\<^sub>1 = C\<^sub>1')"
	+ using ps'_def by auto
	+ moreover have "C\<^sub>0 = c\<^sub>0" "C\<^sub>1 = c\<^sub>1"
	+ using assms defs apply (auto split: if_splits prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ using C'_def by (auto split: if_splits)
	+qed
	+
	+lemma combine_c0_ne_c1:
	+ assumes "p\<^sub>0\<^sub>L \<noteq> p\<^sub>1\<^sub>L" "p\<^sub>0\<^sub>R \<noteq> p\<^sub>1\<^sub>R" "distinct ps"
	+ assumes "(c\<^sub>0, c\<^sub>1) = combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ shows "c\<^sub>0 \<noteq> c\<^sub>1"
	+proof -
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = (if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))"
	+ by metis
	+ define ps' where ps'_def: "ps' = filter (\<lambda>p. dist p (l, snd p) < dist C\<^sub>0' C\<^sub>1') ps"
	+ obtain C\<^sub>0 C\<^sub>1 where C_def: "(C\<^sub>0, C\<^sub>1) = find_closest_pair (C\<^sub>0', C\<^sub>1') ps'"
	+ using prod.collapse by blast
	+ note defs = C'_def ps'_def C_def
	+ have "C\<^sub>0 \<noteq> C\<^sub>1"
	+ using defs find_closest_pair_c0_ne_c1[of C\<^sub>0' C\<^sub>1' ps'] assms by (auto split: if_splits)
	+ moreover have "C\<^sub>0 = c\<^sub>0" "C\<^sub>1 = c\<^sub>1"
	+ using assms(4) defs apply (auto split: if_splits prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by blast
	+qed
	+
	+lemma combine_dist:
	+ assumes "sorted_snd ps" "set ps = ps\<^sub>L \<union> ps\<^sub>R"
	+ assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
	+ assumes "sparse (dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L) ps\<^sub>L" "sparse (dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R) ps\<^sub>R"
	+ assumes "(c\<^sub>0, c\<^sub>1) = combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ shows "sparse (dist c\<^sub>0 c\<^sub>1) (set ps)"
	+proof -
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = (if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))"
	+ by metis
	+ define ps' where ps'_def: "ps' = filter (\<lambda>p. dist p (l, snd p) < dist C\<^sub>0' C\<^sub>1') ps"
	+ obtain C\<^sub>0 C\<^sub>1 where C_def: "(C\<^sub>0, C\<^sub>1) = find_closest_pair (C\<^sub>0', C\<^sub>1') ps'"
	+ using prod.collapse by blast
	+ note defs = C'_def ps'_def C_def
	+ have EQ: "C\<^sub>0 = c\<^sub>0" "C\<^sub>1 = c\<^sub>1"
	+ using defs assms(7) apply (auto split: if_splits prod.splits) by (metis Pair_inject)+
	+ have ps': "ps' = filter (\<lambda>p. l - dist C\<^sub>0' C\<^sub>1' < fst p \<and> fst p < l + dist C\<^sub>0' C\<^sub>1') ps"
	+ using ps'_def dist_transform by simp
	+ have ps\<^sub>L: "sparse (dist C\<^sub>0' C\<^sub>1') ps\<^sub>L"
	+ using assms(3,5) C'_def sparse_def apply (auto split: if_splits) by force+
	+ have ps\<^sub>R: "sparse (dist C\<^sub>0' C\<^sub>1') ps\<^sub>R"
	+ using assms(4,6) C'_def sparse_def apply (auto split: if_splits) by force+
	+ have "sorted_snd ps'"
	+ using ps'_def assms(1) sorted_snd_def sorted_wrt_filter by blast
	+ hence *: "sparse (dist C\<^sub>0 C\<^sub>1) (set ps')"
	+ using find_closest_pair_dist C_def by simp
	+ have "\<forall>p\<^sub>0 \<in> set ps. \<forall>p\<^sub>1 \<in> set ps. p\<^sub>0 \<noteq> p\<^sub>1 \<and> dist p\<^sub>0 p\<^sub>1 < dist C\<^sub>0' C\<^sub>1' \<longrightarrow> p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<in> set ps'"
	+ using set_band_filter ps' ps\<^sub>L ps\<^sub>R assms(2,3,4) by blast
	+ moreover have "dist C\<^sub>0 C\<^sub>1 \<le> dist C\<^sub>0' C\<^sub>1'"
	+ using C_def find_closest_pair_dist_mono by blast
	+ ultimately have "\<forall>p\<^sub>0 \<in> set ps. \<forall>p\<^sub>1 \<in> set ps. p\<^sub>0 \<noteq> p\<^sub>1 \<and> dist p\<^sub>0 p\<^sub>1 < dist C\<^sub>0 C\<^sub>1 \<longrightarrow> p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<in> set ps'"
	+ by simp
	+ hence "sparse (dist C\<^sub>0 C\<^sub>1) (set ps)"
	+ using sparse_def * by (meson not_less)
	+ thus ?thesis
	+ using EQ by blast
	+qed
	+
	+subsubsection "Divide and Conquer Algorithm"
	+
	+function closest_pair_rec :: "point list \<Rightarrow> (point list * point * point)" where
	+ "closest_pair_rec xs = (
	+ let n = length xs in
	+ if n \<le> 3 then
	+ (mergesort snd xs, closest_pair_bf xs)
	+ else
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ let l = fst (hd xs\<^sub>R) in
	+
	+ let (ys\<^sub>L, p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) = closest_pair_rec xs\<^sub>L in
	+ let (ys\<^sub>R, p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) = closest_pair_rec xs\<^sub>R in
	+
	+ let ys = merge snd ys\<^sub>L ys\<^sub>R in
	+ (ys, combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ys)
	+ )"
	+ by pat_completeness auto
	+termination closest_pair_rec
	+ apply (relation "Wellfounded.measure (\<lambda>xs. length xs)")
	+ apply (auto simp: split_at_take_drop_conv Let_def)
	+ done
	+
	+lemma closest_pair_rec_simps:
	+ assumes "n = length xs" "\<not> (n \<le> 3)"
	+ shows "closest_pair_rec xs = (
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ let l = fst (hd xs\<^sub>R) in
	+ let (ys\<^sub>L, p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) = closest_pair_rec xs\<^sub>L in
	+ let (ys\<^sub>R, p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) = closest_pair_rec xs\<^sub>R in
	+ let ys = merge snd ys\<^sub>L ys\<^sub>R in
	+ (ys, combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ys)
	+ )"
	+ using assms by (auto simp: Let_def)
	+
	+declare combine.simps closest_pair_rec.simps [simp del]
	+
	+lemma closest_pair_rec_set_length_sorted_snd:
	+ assumes "(ys, p) = closest_pair_rec xs"
	+ shows "set ys = set xs \<and> length ys = length xs \<and> sorted_snd ys"
	+ using assms
	+proof (induction xs arbitrary: ys p rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ thus ?thesis using "1.prems" sorted_snd_def
	+ by (auto simp: mergesort closest_pair_rec.simps)
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+ obtain YS\<^sub>L P\<^sub>L where YSP\<^sub>L_def: "(YS\<^sub>L, P\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ using prod.collapse by blast
	+ obtain YS\<^sub>R P\<^sub>R where YSP\<^sub>R_def: "(YS\<^sub>R, P\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ using prod.collapse by blast
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ define P where "P = combine P\<^sub>L P\<^sub>R L YS"
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSP\<^sub>L_def YSP\<^sub>R_def YS_def P_def
	+
	+ have "length XS\<^sub>L < length xs" "length XS\<^sub>R < length xs"
	+ using False defs by (auto simp: split_at_take_drop_conv)
	+ hence IH: "set XS\<^sub>L = set YS\<^sub>L" "set XS\<^sub>R = set YS\<^sub>R"
	+ "length XS\<^sub>L = length YS\<^sub>L" "length XS\<^sub>R = length YS\<^sub>R"
	+ "sorted_snd YS\<^sub>L" "sorted_snd YS\<^sub>R"
	+ using "1.IH" defs by metis+
	+
	+ have "set xs = set XS\<^sub>L \<union> set XS\<^sub>R"
	+ using defs by (auto simp: set_take_drop split_at_take_drop_conv)
	+ hence SET: "set xs = set YS"
	+ using set_merge IH(1,2) defs by fast
	+
	+ have "length xs = length XS\<^sub>L + length XS\<^sub>R"
	+ using defs by (auto simp: split_at_take_drop_conv)
	+ hence LENGTH: "length xs = length YS"
	+ using IH(3,4) length_merge defs by metis
	+
	+ have SORTED: "sorted_snd YS"
	+ using IH(5,6) by (simp add: defs sorted_snd_def sorted_merge)
	+
	+ have "(YS, P) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs by (auto simp: Let_def split: prod.split)
	+ hence "(ys, p) = (YS, P)"
	+ using "1.prems" by argo
	+ thus ?thesis
	+ using SET LENGTH SORTED by simp
	+ qed
	+qed
	+
	+lemma closest_pair_rec_distinct:
	+ assumes "distinct xs" "(ys, p) = closest_pair_rec xs"
	+ shows "distinct ys"
	+ using assms
	+proof (induction xs arbitrary: ys p rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ thus ?thesis using "1.prems"
	+ by (auto simp: mergesort closest_pair_rec.simps)
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+ obtain YS\<^sub>L P\<^sub>L where YSP\<^sub>L_def: "(YS\<^sub>L, P\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ using prod.collapse by blast
	+ obtain YS\<^sub>R P\<^sub>R where YSP\<^sub>R_def: "(YS\<^sub>R, P\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ using prod.collapse by blast
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ define P where "P = combine P\<^sub>L P\<^sub>R L YS"
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSP\<^sub>L_def YSP\<^sub>R_def YS_def P_def
	+
	+ have "length XS\<^sub>L < length xs" "length XS\<^sub>R < length xs"
	+ using False defs by (auto simp: split_at_take_drop_conv)
	+ moreover have "distinct XS\<^sub>L" "distinct XS\<^sub>R"
	+ using "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ ultimately have IH: "distinct YS\<^sub>L" "distinct YS\<^sub>R"
	+ using "1.IH" defs by blast+
	+
	+ have "set XS\<^sub>L \<inter> set XS\<^sub>R = {}"
	+ using "1.prems"(1) defs by (auto simp: split_at_take_drop_conv set_take_disj_set_drop_if_distinct)
	+ moreover have "set XS\<^sub>L = set YS\<^sub>L" "set XS\<^sub>R = set YS\<^sub>R"
	+ using closest_pair_rec_set_length_sorted_snd defs by blast+
	+ ultimately have "set YS\<^sub>L \<inter> set YS\<^sub>R = {}"
	+ by blast
	+ hence DISTINCT: "distinct YS"
	+ using distinct_merge IH defs by blast
	+
	+ have "(YS, P) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs by (auto simp: Let_def split: prod.split)
	+ hence "(ys, p) = (YS, P)"
	+ using "1.prems" by argo
	+ thus ?thesis
	+ using DISTINCT by blast
	+ qed
	+qed
	+
	+lemma closest_pair_rec_c0_c1:
	+ assumes "1 < length xs" "distinct xs" "(ys, c\<^sub>0, c\<^sub>1) = closest_pair_rec xs"
	+ shows "c\<^sub>0 \<in> set xs \<and> c\<^sub>1 \<in> set xs \<and> c\<^sub>0 \<noteq> c\<^sub>1"
	+ using assms
	+proof (induction xs arbitrary: ys c\<^sub>0 c\<^sub>1 rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "(c\<^sub>0, c\<^sub>1) = closest_pair_bf xs"
	+ using "1.prems"(3) closest_pair_rec.simps by simp
	+ thus ?thesis
	+ using "1.prems"(1,2) closest_pair_bf_c0_c1 by simp
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L where YSC\<^sub>0\<^sub>1\<^sub>L_def: "(YS\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ using prod.collapse by metis
	+ obtain YS\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R where YSC\<^sub>0\<^sub>1\<^sub>R_def: "(YS\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ using prod.collapse by metis
	+
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ obtain C\<^sub>0 C\<^sub>1 where C\<^sub>0\<^sub>1_def: "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ using prod.collapse by metis
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSC\<^sub>0\<^sub>1\<^sub>L_def YSC\<^sub>0\<^sub>1\<^sub>R_def YS_def C\<^sub>0\<^sub>1_def
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length xs" "distinct XS\<^sub>L"
	+ using False "1.prems"(2) defs by (auto simp: split_at_take_drop_conv)
	+ hence "C\<^sub>0\<^sub>L \<in> set XS\<^sub>L" "C\<^sub>1\<^sub>L \<in> set XS\<^sub>L" and IHL1: "C\<^sub>0\<^sub>L \<noteq> C\<^sub>1\<^sub>L"
	+ using "1.IH" defs by metis+
	+ hence IHL2: "C\<^sub>0\<^sub>L \<in> set xs" "C\<^sub>1\<^sub>L \<in> set xs"
	+ using split_at_take_drop_conv in_set_takeD fst_conv defs by metis+
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length xs" "distinct XS\<^sub>R"
	+ using False "1.prems"(2) defs by (auto simp: split_at_take_drop_conv)
	+ hence "C\<^sub>0\<^sub>R \<in> set XS\<^sub>R" "C\<^sub>1\<^sub>R \<in> set XS\<^sub>R" and IHR1: "C\<^sub>0\<^sub>R \<noteq> C\<^sub>1\<^sub>R"
	+ using "1.IH" defs by metis+
	+ hence IHR2: "C\<^sub>0\<^sub>R \<in> set xs" "C\<^sub>1\<^sub>R \<in> set xs"
	+ using split_at_take_drop_conv in_set_dropD snd_conv defs by metis+
	+
	+ have *: "(YS, C\<^sub>0, C\<^sub>1) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs by (auto simp: Let_def split: prod.split)
	+ have YS: "set xs = set YS" "distinct YS"
	+ using "1.prems"(2) closest_pair_rec_set_length_sorted_snd closest_pair_rec_distinct * by blast+
	+
	+ have "C\<^sub>0 \<in> set xs" "C\<^sub>1 \<in> set xs"
	+ using combine_set IHL2 IHR2 YS defs by blast+
	+ moreover have "C\<^sub>0 \<noteq> C\<^sub>1"
	+ using combine_c0_ne_c1 IHL1(1) IHR1(1) YS defs by blast
	+ ultimately show ?thesis
	+ using "1.prems"(3) * by (metis Pair_inject)
	+ qed
	+qed
	+
	+lemma closest_pair_rec_dist:
	+ assumes "1 < length xs" "sorted_fst xs" "(ys, c\<^sub>0, c\<^sub>1) = closest_pair_rec xs"
	+ shows "sparse (dist c\<^sub>0 c\<^sub>1) (set xs)"
	+ using assms
	+proof (induction xs arbitrary: ys c\<^sub>0 c\<^sub>1 rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "(c\<^sub>0, c\<^sub>1) = closest_pair_bf xs"
	+ using "1.prems"(3) closest_pair_rec.simps by simp
	+ thus ?thesis
	+ using "1.prems"(1,3) closest_pair_bf_dist by metis
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L where YSC\<^sub>0\<^sub>1\<^sub>L_def: "(YS\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ using prod.collapse by metis
	+ obtain YS\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R where YSC\<^sub>0\<^sub>1\<^sub>R_def: "(YS\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ using prod.collapse by metis
	+
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ obtain C\<^sub>0 C\<^sub>1 where C\<^sub>0\<^sub>1_def: "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ using prod.collapse by metis
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSC\<^sub>0\<^sub>1\<^sub>L_def YSC\<^sub>0\<^sub>1\<^sub>R_def YS_def C\<^sub>0\<^sub>1_def
	+
	+ have XSLR: "XS\<^sub>L = take (?n div 2) xs" "XS\<^sub>R = drop (?n div 2) xs"
	+ using defs by (auto simp: split_at_take_drop_conv)
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length xs"
	+ using False XSLR by simp_all
	+ moreover have "sorted_fst XS\<^sub>L"
	+ using "1.prems"(2) XSLR by (auto simp: sorted_fst_def sorted_wrt_take)
	+ ultimately have L: "sparse (dist C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L) (set XS\<^sub>L)"
	+ "set XS\<^sub>L = set YS\<^sub>L"
	+ using 1 closest_pair_rec_set_length_sorted_snd closest_pair_rec_c0_c1
	+ YSC\<^sub>0\<^sub>1\<^sub>L_def by blast+
	+ hence IHL: "sparse (dist C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L) (set YS\<^sub>L)"
	+ by argo
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length xs"
	+ using False XSLR by simp_all
	+ moreover have "sorted_fst XS\<^sub>R"
	+ using "1.prems"(2) XSLR by (auto simp: sorted_fst_def sorted_wrt_drop)
	+ ultimately have R: "sparse (dist C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R) (set XS\<^sub>R)"
	+ "set XS\<^sub>R = set YS\<^sub>R"
	+ using 1 closest_pair_rec_set_length_sorted_snd closest_pair_rec_c0_c1
	+ YSC\<^sub>0\<^sub>1\<^sub>R_def by blast+
	+ hence IHR: "sparse (dist C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R) (set YS\<^sub>R)"
	+ by argo
	+
	+ have *: "(YS, C\<^sub>0, C\<^sub>1) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs by (auto simp: Let_def split: prod.split)
	+
	+ have "set xs = set YS" "sorted_snd YS"
	+ using "1.prems"(2) closest_pair_rec_set_length_sorted_snd closest_pair_rec_distinct * by blast+
	+ moreover have "\<forall>p \<in> set YS\<^sub>L. fst p \<le> L"
	+ using False "1.prems"(2) XSLR L_def L(2) sorted_fst_take_less_hd_drop by simp
	+ moreover have "\<forall>p \<in> set YS\<^sub>R. L \<le> fst p"
	+ using False "1.prems"(2) XSLR L_def R(2) sorted_fst_hd_drop_less_drop by simp
	+ moreover have "set YS = set YS\<^sub>L \<union> set YS\<^sub>R"
	+ using set_merge defs by fast
	+ moreover have "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ by (auto simp add: defs)
	+ ultimately have "sparse (dist C\<^sub>0 C\<^sub>1) (set xs)"
	+ using combine_dist IHL IHR by auto
	+ moreover have "(YS, C\<^sub>0, C\<^sub>1) = (ys, c\<^sub>0, c\<^sub>1)"
	+ using "1.prems"(3) * by simp
	+ ultimately show ?thesis
	+ by blast
	+ qed
	+qed
	+
	+fun closest_pair :: "point list \<Rightarrow> (point * point)" where
	+ "closest_pair [] = undefined"
	+\| "closest_pair [_] = undefined"
	+\| "closest_pair ps = (let (_, c\<^sub>0, c\<^sub>1) = closest_pair_rec (mergesort fst ps) in (c\<^sub>0, c\<^sub>1))"
	+
	+lemma closest_pair_simps:
	+ "1 < length ps \<Longrightarrow> closest_pair ps = (let (_, c\<^sub>0, c\<^sub>1) = closest_pair_rec (mergesort fst ps) in (c\<^sub>0, c\<^sub>1))"
	+ by (induction ps rule: induct_list012) auto
	+
	+declare closest_pair.simps [simp del]
	+
	+theorem closest_pair_c0_c1:
	+ assumes "1 < length ps" "distinct ps" "(c\<^sub>0, c\<^sub>1) = closest_pair ps"
	+ shows "c\<^sub>0 \<in> set ps" "c\<^sub>1 \<in> set ps" "c\<^sub>0 \<noteq> c\<^sub>1"
	+ using assms closest_pair_rec_c0_c1[of "mergesort fst ps"]
	+ by (auto simp: closest_pair_simps mergesort split: prod.splits)
	+
	+theorem closest_pair_dist:
	+ assumes "1 < length ps" "(c\<^sub>0, c\<^sub>1) = closest_pair ps"
	+ shows "sparse (dist c\<^sub>0 c\<^sub>1) (set ps)"
	+ using assms sorted_fst_def closest_pair_rec_dist[of "mergesort fst ps"] closest_pair_rec_c0_c1[of "mergesort fst ps"]
	+ by (auto simp: closest_pair_simps mergesort split: prod.splits)
	+
	+
	+subsection "Time Complexity Proof"
	+
	+subsubsection "Core Argument"
	+
	+lemma core_argument:
	+ fixes \<delta> :: real and p :: point and ps :: "point list"
	+ assumes "distinct (p # ps)" "sorted_snd (p # ps)" "0 \<le> \<delta>" "set (p # ps) = ps\<^sub>L \<union> ps\<^sub>R"
	+ assumes "\<forall>q \<in> set (p # ps). l - \<delta> < fst q \<and> fst q < l + \<delta>"
	+ assumes "\<forall>q \<in> ps\<^sub>L. fst q \<le> l" "\<forall>q \<in> ps\<^sub>R. l \<le> fst q"
	+ assumes "sparse \<delta> ps\<^sub>L" "sparse \<delta> ps\<^sub>R"
	+ shows "length (filter (\<lambda>q. snd q - snd p \<le> \<delta>) ps) \<le> 7"
	+proof -
	+ define PS where "PS = p # ps"
	+ define R where "R = cbox (l - \<delta>, snd p) (l + \<delta>, snd p + \<delta>)"
	+ define RPS where "RPS = { p \<in> set PS. p \<in> R }"
	+ define LSQ where "LSQ = cbox (l - \<delta>, snd p) (l, snd p + \<delta>)"
	+ define LSQPS where "LSQPS = { p \<in> ps\<^sub>L. p \<in> LSQ }"
	+ define RSQ where "RSQ = cbox (l, snd p) (l + \<delta>, snd p + \<delta>)"
	+ define RSQPS where "RSQPS = { p \<in> ps\<^sub>R. p \<in> RSQ }"
	+ note defs = PS_def R_def RPS_def LSQ_def LSQPS_def RSQ_def RSQPS_def
	+
	+ have "R = LSQ \<union> RSQ"
	+ using defs cbox_right_un by auto
	+ moreover have "\<forall>p \<in> ps\<^sub>L. p \<in> RSQ \<longrightarrow> p \<in> LSQ"
	+ using RSQ_def LSQ_def assms(6) by auto
	+ moreover have "\<forall>p \<in> ps\<^sub>R. p \<in> LSQ \<longrightarrow> p \<in> RSQ"
	+ using RSQ_def LSQ_def assms(7) by auto
	+ ultimately have "RPS = LSQPS \<union> RSQPS"
	+ using LSQPS_def RSQPS_def PS_def RPS_def assms(4) by blast
	+
	+ have "sparse \<delta> LSQPS"
	+ using assms(8) LSQPS_def sparse_def by simp
	+ hence CLSQPS: "card LSQPS \<le> 4"
	+ using max_points_square[of LSQPS "l - \<delta>" "snd p" \<delta>] assms(3) LSQ_def LSQPS_def by auto
	+
	+ have "sparse \<delta> RSQPS"
	+ using assms(9) RSQPS_def sparse_def by simp
	+ hence CRSQPS: "card RSQPS \<le> 4"
	+ using max_points_square[of RSQPS l "snd p" \<delta>] assms(3) RSQ_def RSQPS_def by auto
	+
	+ have CRPS: "card RPS \<le> 8"
	+ using CLSQPS CRSQPS card_Un_le[of LSQPS RSQPS] \<open>RPS = LSQPS \<union> RSQPS\<close> by auto
	+
	+ have "set (p # filter (\<lambda>q. snd q - snd p \<le> \<delta>) ps) \<subseteq> RPS"
	+ proof standard
	+ fix q
	+ assume *: "q \<in> set (p # filter (\<lambda>q. snd q - snd p \<le> \<delta>) ps)"
	+ hence CPS: "q \<in> set PS"
	+ using PS_def by auto
	+ hence "snd p \<le> snd q" "snd q \<le> snd p + \<delta>"
	+ using assms(2,3) PS_def sorted_snd_def * by (auto split: if_splits)
	+ moreover have "l - \<delta> < fst q" "fst q < l + \<delta>"
	+ using CPS assms(5) PS_def by blast+
	+ ultimately have "q \<in> R"
	+ using R_def mem_cbox_2D[of "l - \<delta>" "fst q" "l + \<delta>" "snd p" "snd q" "snd p + \<delta>"]
	+ by (simp add: prod.case_eq_if)
	+ thus "q \<in> RPS"
	+ using CPS RPS_def by simp
	+ qed
	+ moreover have "finite RPS"
	+ by (simp add: RPS_def)
	+ ultimately have "card (set (p # filter (\<lambda>q. snd q - snd p \<le> \<delta>) ps)) \<le> 8"
	+ using CRPS card_mono[of RPS "set (p # filter (\<lambda>q. snd q - snd p \<le> \<delta>) ps)"] by simp
	+ moreover have "distinct (p # filter (\<lambda>q. snd q - snd p \<le> \<delta>) ps)"
	+ using assms(1) by simp
	+ ultimately have "length (p # filter (\<lambda>q. snd q - snd p \<le> \<delta>) ps) \<le> 8"
	+ using assms(1) PS_def distinct_card by metis
	+ thus ?thesis
	+ by simp
	+qed
	+
	+subsubsection "Combine Step"
	+
	+fun t_find_closest :: "point \<Rightarrow> real \<Rightarrow> point list \<Rightarrow> nat" where
	+ "t_find_closest _ _ [] = 0"
	+\| "t_find_closest _ _ [_] = 1"
	+\| "t_find_closest p \<delta> (p\<^sub>0 # ps) = 1 + (
	+ if \<delta> \<le> snd p\<^sub>0 - snd p then
	+ 0
	+ else
	+ let p\<^sub>1 = find_closest p (min \<delta> (dist p p\<^sub>0)) ps in
	+ t_find_closest p (min \<delta> (dist p p\<^sub>0)) ps + (
	+ if dist p p\<^sub>0 \<le> dist p p\<^sub>1 then 0 else 0
	+ )
	+ )"
	+
	+lemma t_find_closest_mono:
	+ "\<delta>' \<le> \<delta> \<Longrightarrow> t_find_closest p \<delta>' ps \<le> t_find_closest p \<delta> ps"
	+ apply (induction rule: t_find_closest.induct)
	+ apply (auto simp: Let_def min_def)
	+ apply (metis surj_pair)+
	+ done
	+
	+lemma t_find_closest_cnt:
	+ "t_find_closest p \<delta> ps \<le> 1 + length (filter (\<lambda>q. snd q - snd p \<le> \<delta>) ps)"
	+proof (induction p \<delta> ps rule: t_find_closest.induct)
	+ case (3 p \<delta> p\<^sub>0 p\<^sub>2 ps)
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest p (min \<delta> (dist p p\<^sub>0)) (p\<^sub>2 # ps)"
	+ show ?case
	+ proof (cases "\<delta> \<le> snd p\<^sub>0 - snd p")
	+ case True
	+ thus ?thesis
	+ by simp
	+ next
	+ case False
	+ hence *: "snd p\<^sub>0 - snd p \<le> \<delta>"
	+ by simp
	+ have "t_find_closest p \<delta> (p\<^sub>0 # p\<^sub>2 # ps) = 1 + t_find_closest p (min \<delta> (dist p p\<^sub>0)) (p\<^sub>2 # ps)"
	+ using False p\<^sub>1_def by simp
	+ also have "... \<le> 1 + 1 + length (filter (\<lambda>q. snd q - snd p \<le> min \<delta> (dist p p\<^sub>0)) (p\<^sub>2 # ps))"
	+ using False 3 p\<^sub>1_def by simp
	+ also have "... \<le> 1 + 1 + length (filter (\<lambda>q. snd q - snd p \<le> \<delta>) (p\<^sub>2 # ps))"
	+ using * by (meson add_le_cancel_left length_filter_P_impl_Q min.bounded_iff)
	+ also have "... \<le> 1 + length (filter (\<lambda>q. snd q - snd p \<le> \<delta>) (p\<^sub>0 # p\<^sub>2 # ps))"
	+ using False by simp
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+qed auto
	+
	+corollary t_find_closest:
	+ fixes \<delta> :: real and p :: point and ps :: "point list" and l :: int
	+ assumes "distinct (p # ps)" "sorted_snd (p # ps)" "0 \<le> \<delta>" "set (p # ps) = ps\<^sub>L \<union> ps\<^sub>R"
	+ assumes "\<forall>p' \<in> set (p # ps). l - \<delta> < fst p' \<and> fst p' < l + \<delta>"
	+ assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
	+ assumes "sparse \<delta> ps\<^sub>L" "sparse \<delta> ps\<^sub>R"
	+ shows "t_find_closest p \<delta> ps \<le> 8"
	+ using assms core_argument[of p ps \<delta> ps\<^sub>L ps\<^sub>R l] t_find_closest_cnt[of p \<delta> ps] by linarith
	+
	+fun t_find_closest_pair :: "(point * point) \<Rightarrow> point list \<Rightarrow> nat" where
	+ "t_find_closest_pair _ [] = 0"
	+\| "t_find_closest_pair _ [_] = 1"
	+\| "t_find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>0 # ps) = 1 + (
	+ let p\<^sub>1 = find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) ps in
	+ t_find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) ps + (
	+ if dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1 then
	+ t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps
	+ else
	+ t_find_closest_pair (p\<^sub>0, p\<^sub>1) ps
	+ ))"
	+
	+lemma t_find_closest_pair:
	+ assumes "distinct ps" "sorted_snd ps" "\<delta> = dist c\<^sub>0 c\<^sub>1" "set ps = ps\<^sub>L \<union> ps\<^sub>R"
	+ assumes "\<forall>p \<in> set ps. l - \<Delta> < fst p \<and> fst p < l + \<Delta>"
	+ assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
	+ assumes "sparse \<Delta> ps\<^sub>L" "sparse \<Delta> ps\<^sub>R" "\<delta> \<le> \<Delta>"
	+ shows "t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps \<le> 9 * length ps"
	+ using assms
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: \<delta> c\<^sub>0 c\<^sub>1 ps\<^sub>L ps\<^sub>R rule: t_find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ let ?ps = "p\<^sub>2 # ps"
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) ?ps"
	+ define PS\<^sub>L where PS\<^sub>L_def: "PS\<^sub>L = ps\<^sub>L - { p\<^sub>0 }"
	+ define PS\<^sub>R where PS\<^sub>R_def: "PS\<^sub>R = ps\<^sub>R - { p\<^sub>0 }"
	+ note defs = p\<^sub>1_def PS\<^sub>L_def PS\<^sub>R_def
	+ have *: "0 \<le> \<Delta>"
	+ using "3.prems"(3,10) zero_le_dist[of c\<^sub>0 c\<^sub>1] by argo
	+ hence "t_find_closest p\<^sub>0 \<Delta> ?ps \<le> 8"
	+ using t_find_closest[of p\<^sub>0 ?ps \<Delta> ps\<^sub>L ps\<^sub>R] "3.prems" by blast
	+ hence A: "t_find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) ?ps \<le> 8"
	+ by (metis "3.prems"(3,10) order_trans t_find_closest_mono)
	+ have B: "distinct ?ps" "sorted_snd ?ps"
	+ using "3.prems"(1,2) sorted_snd_def by simp_all
	+ have C: "set ?ps = PS\<^sub>L \<union> PS\<^sub>R"
	+ using defs "3.prems"(1,4) by auto
	+ have D: "\<forall>p \<in> set ?ps. l - \<Delta> < fst p \<and> fst p < l + \<Delta>"
	+ using "3.prems"(5) by simp
	+ have E: "\<forall>p \<in> PS\<^sub>L. fst p \<le> l" "\<forall>p \<in> PS\<^sub>R. l \<le> fst p"
	+ using defs "3.prems"(6,7) by simp_all
	+ have F: "sparse \<Delta> PS\<^sub>L" "sparse \<Delta> PS\<^sub>R"
	+ using defs "3.prems"(8,9) sparse_def by simp_all
	+ show ?case
	+ proof (cases "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1")
	+ case True
	+ hence "t_find_closest_pair (c\<^sub>0, c\<^sub>1) ?ps \<le> 9 * length ?ps"
	+ using "3.hyps"(1) "3.prems"(3,10) defs(1) B C D E F by blast
	+ moreover have "t_find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>0 # ?ps) =
	+ 1 + t_find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) ?ps + t_find_closest_pair (c\<^sub>0, c\<^sub>1) ?ps"
	+ using defs True by (auto split: prod.splits)
	+ ultimately show ?thesis
	+ using A by auto
	+ next
	+ case False
	+ moreover have "0 \<le> dist p\<^sub>0 p\<^sub>1"
	+ by auto
	+ ultimately have "t_find_closest_pair (p\<^sub>0, p\<^sub>1) ?ps \<le> 9 * length ?ps"
	+ using "3.hyps"(2) "3.prems"(3,10) defs(1) B C D E F by auto
	+ moreover have "t_find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>0 # ?ps) =
	+ 1 + t_find_closest p\<^sub>0 (dist c\<^sub>0 c\<^sub>1) ?ps + t_find_closest_pair (p\<^sub>0, p\<^sub>1) ?ps"
	+ using defs False by (auto split: prod.splits)
	+ ultimately show ?thesis
	+ using A by simp
	+ qed
	+qed auto
	+
	+fun t_combine :: "(point * point) \<Rightarrow> (point * point) \<Rightarrow> int \<Rightarrow> point list \<Rightarrow> nat" where
	+ "t_combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps = (
	+ let (c\<^sub>0, c\<^sub>1) = if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) in
	+ let ps' = filter (\<lambda>p. dist p (l, snd p) < dist c\<^sub>0 c\<^sub>1) ps in
	+ t_filter (\<lambda>p. dist p (l, snd p) < dist c\<^sub>0 c\<^sub>1) ps + t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps'
	+ )"
	+
	+lemma t_combine:
	+ fixes ps :: "point list"
	+ assumes "distinct ps" "sorted_snd ps" "set ps = ps\<^sub>L \<union> ps\<^sub>R"
	+ assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
	+ assumes "sparse (dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L) ps\<^sub>L" "sparse (dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R) ps\<^sub>R"
	+ shows "t_combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps \<le> 10 * length ps"
	+proof -
	+ obtain c\<^sub>0 c\<^sub>1 where c_def:
	+ "(c\<^sub>0, c\<^sub>1) = (if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))" by metis
	+ let ?P = "(\<lambda>p. dist p (l, snd p) < dist c\<^sub>0 c\<^sub>1)"
	+ define ps' where ps'_def: "ps' = filter ?P ps"
	+ define ps\<^sub>L' where ps\<^sub>L'_def: "ps\<^sub>L' = { p \<in> ps\<^sub>L. ?P p }"
	+ define ps\<^sub>R' where ps\<^sub>R'_def: "ps\<^sub>R' = { p \<in> ps\<^sub>R. ?P p }"
	+ note defs = c_def ps'_def ps\<^sub>L'_def ps\<^sub>R'_def
	+ have "sparse (dist c\<^sub>0 c\<^sub>1) ps\<^sub>L" "sparse (dist c\<^sub>0 c\<^sub>1) ps\<^sub>R"
	+ using assms(6,7) sparse_mono c_def by (auto split: if_splits)
	+ hence "sparse (dist c\<^sub>0 c\<^sub>1) ps\<^sub>L'" "sparse (dist c\<^sub>0 c\<^sub>1) ps\<^sub>R'"
	+ using ps\<^sub>L'_def ps\<^sub>R'_def sparse_def by auto
	+ moreover have "distinct ps'"
	+ using ps'_def assms(1) by simp
	+ moreover have "sorted_snd ps'"
	+ using ps'_def assms(2) sorted_snd_def sorted_wrt_filter by blast
	+ moreover have "0 \<le> dist c\<^sub>0 c\<^sub>1"
	+ by simp
	+ moreover have "set ps' = ps\<^sub>L' \<union> ps\<^sub>R'"
	+ using assms(3) defs(2,3,4) filter_Un by auto
	+ moreover have "\<forall>p \<in> set ps'. l - dist c\<^sub>0 c\<^sub>1 < fst p \<and> fst p < l + dist c\<^sub>0 c\<^sub>1"
	+ using ps'_def dist_transform by force
	+ moreover have "\<forall>p \<in> ps\<^sub>L'. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R'. l \<le> fst p"
	+ using assms(4,5) ps\<^sub>L'_def ps\<^sub>R'_def by blast+
	+ ultimately have "t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps' \<le> 9 * length ps'"
	+ using t_find_closest_pair by blast
	+ moreover have "length ps' \<le> length ps"
	+ using ps'_def by simp
	+ ultimately have : "t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps' \<le> 9 length ps"
	+ by simp
	+ have "t_combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps =
	+ t_filter ?P ps + t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps'"
	+ using defs by (auto split: prod.splits)
	+ also have "... = length ps + t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps'"
	+ using t_filter by auto
	+ finally show ?thesis
	+ using * by simp
	+qed
	+
	+declare t_combine.simps [simp del]
	+
	+subsubsection "Divide and Conquer Algorithm"
	+
	+function t_closest_pair_rec :: "point list \<Rightarrow> nat" where
	+ "t_closest_pair_rec xs = (
	+ let n = length xs in
	+ t_length xs + (
	+ if n \<le> 3 then
	+ t_mergesort snd xs + t_closest_pair_bf xs
	+ else
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ t_split_at (n div 2) xs + (
	+
	+ let (ys\<^sub>L, p\<^sub>L) = closest_pair_rec xs\<^sub>L in
	+ t_closest_pair_rec xs\<^sub>L + (
	+ let (ys\<^sub>R, p\<^sub>R) = closest_pair_rec xs\<^sub>R in
	+ t_closest_pair_rec xs\<^sub>R + (
	+
	+ let ys = merge (\<lambda>p. snd p) ys\<^sub>L ys\<^sub>R in
	+ t_merge (\<lambda>p. snd p) (ys\<^sub>L, ys\<^sub>R) + t_combine p\<^sub>L p\<^sub>R (fst (hd xs\<^sub>R)) ys
	+ ))))
	+ )"
	+ by pat_completeness auto
	+termination t_closest_pair_rec
	+ apply (relation "Wellfounded.measure (\<lambda>xs. length xs)")
	+ apply (auto simp: split_at_take_drop_conv Let_def)
	+ done
	+
	+lemma t_closest_pair_rec_simps_1:
	+ assumes "n = length xs" "n \<le> 3"
	+ shows "t_closest_pair_rec xs = t_length xs + t_mergesort snd xs + t_closest_pair_bf xs"
	+ using assms by simp
	+
	+lemma t_closest_pair_rec_simps_2:
	+ assumes "n = length xs" "\<not> (n \<le> 3)"
	+ shows "t_closest_pair_rec xs = (
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ let t_s = t_split_at (n div 2) xs in
	+ let l = fst (hd xs\<^sub>R) in
	+ let (ys\<^sub>L, p\<^sub>L) = closest_pair_rec xs\<^sub>L in
	+ let (ys\<^sub>R, p\<^sub>R) = closest_pair_rec xs\<^sub>R in
	+ let t_cl = t_closest_pair_rec xs\<^sub>L in
	+ let t_cr = t_closest_pair_rec xs\<^sub>R in
	+ let ys = merge (\<lambda>p. snd p) ys\<^sub>L ys\<^sub>R in
	+ let t_m = t_merge (\<lambda>p. snd p) (ys\<^sub>L, ys\<^sub>R) in
	+ let t_c = t_combine p\<^sub>L p\<^sub>R l ys in
	+ t_length xs + t_s + t_cl + t_cr + t_m + t_c
	+ )"
	+ using assms by (auto simp add: Let_def split!: if_splits prod.splits)
	+
	+declare t_closest_pair_rec.simps [simp del]
	+
	+function closest_pair_recurrence :: "nat \<Rightarrow> real" where
	+ "n \<le> 3 \<Longrightarrow> closest_pair_recurrence n = n + mergesort_recurrence n + n * n"
	+\| "3 < n \<Longrightarrow> closest_pair_recurrence n = 13 * n +
	+ closest_pair_recurrence (nat \<lfloor>real n / 2\<rfloor>) + closest_pair_recurrence (nat \<lceil>real n / 2\<rceil>)"
	+ by force simp_all
	+termination by akra_bazzi_termination simp_all
	+
	+lemma closest_pair_recurrence_nonneg[simp]:
	+ "0 \<le> closest_pair_recurrence n"
	+ by (induction n rule: closest_pair_recurrence.induct) auto
	+
	+lemma t_closest_pair_rec_conv_closest_pair_recurrence:
	+ assumes "distinct ps" "sorted_fst ps"
	+ shows "t_closest_pair_rec ps \<le> closest_pair_recurrence (length ps)"
	+ using assms
	+proof (induction ps rule: length_induct)
	+ case (1 ps)
	+ let ?n = "length ps"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "t_closest_pair_rec ps = t_length ps + t_mergesort snd ps + t_closest_pair_bf ps"
	+ using t_closest_pair_rec_simps_1 by simp
	+ moreover have "closest_pair_recurrence ?n = ?n + mergesort_recurrence ?n + ?n * ?n"
	+ using True by simp
	+ moreover have "t_length ps \<le> ?n" "t_mergesort snd ps \<le> mergesort_recurrence ?n" "t_closest_pair_bf ps \<le> ?n * ?n"
	+ using t_length[of ps] t_mergesort_conv_mergesort_recurrence[of snd ps] t_closest_pair_bf[of ps] by auto
	+ ultimately show ?thesis
	+ by linarith
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) ps"
	+ using prod.collapse by blast
	+ define TS where "TS = t_split_at (?n div 2) ps"
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L where CP\<^sub>L_def: "(YS\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ using prod.collapse by metis
	+ define TL where "TL = t_closest_pair_rec XS\<^sub>L"
	+ obtain YS\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R where CP\<^sub>R_def: "(YS\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ using prod.collapse by metis
	+ define TR where "TR = t_closest_pair_rec XS\<^sub>R"
	+
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ define TM where "TM = t_merge (\<lambda>p. snd p) (YS\<^sub>L, YS\<^sub>R)"
	+ define TC where "TC = t_combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ obtain C\<^sub>0 C\<^sub>1 where C\<^sub>0\<^sub>1_def: "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ using prod.collapse by metis
	+ note defs = XS_def TS_def L_def CP\<^sub>L_def TL_def CP\<^sub>R_def TR_def YS_def TM_def TC_def
	+
	+ have FL: "t_closest_pair_rec ps = t_length ps + TS + TL + TR + TM + TC"
	+ using False t_closest_pair_rec_simps_2 defs by (auto simp: Let_def split!: if_splits prod.splits)
	+ have FR: "closest_pair_recurrence (length ps) = closest_pair_recurrence (nat \<lfloor>real ?n / 2\<rfloor>) +
	+ closest_pair_recurrence (nat \<lceil>real ?n / 2\<rceil>) + 13 * ?n"
	+ using False by simp
	+
	+ have XSLR: "XS\<^sub>L = take (?n div 2) ps" "XS\<^sub>R = drop (?n div 2) ps"
	+ using defs by (auto simp: split_at_take_drop_conv)
	+ hence "length XS\<^sub>L = ?n div 2" "length XS\<^sub>R = ?n - ?n div 2"
	+ by simp_all
	+ hence *: "(nat \<lfloor>real ?n / 2\<rfloor>) = length XS\<^sub>L" "(nat \<lceil>real ?n / 2\<rceil>) = length XS\<^sub>R"
	+ by linarith+
	+ have "length XS\<^sub>L = length YS\<^sub>L" "length XS\<^sub>R = length YS\<^sub>R"
	+ using defs closest_pair_rec_set_length_sorted_snd by metis+
	+ hence L: "?n = length YS\<^sub>L + length YS\<^sub>R"
	+ using defs XSLR by fastforce
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length ps"
	+ using False XSLR by simp_all
	+ moreover have "distinct XS\<^sub>L" "sorted_fst XS\<^sub>L"
	+ using XSLR "1.prems"(1,2) sorted_fst_def sorted_wrt_take by simp_all
	+ ultimately have "t_closest_pair_rec XS\<^sub>L \<le> closest_pair_recurrence (length XS\<^sub>L)"
	+ using "1.IH" by simp
	+ hence IHL: "t_closest_pair_rec XS\<^sub>L \<le> closest_pair_recurrence (nat \<lfloor>real ?n / 2\<rfloor>)"
	+ using * by simp
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length ps"
	+ using False XSLR by simp_all
	+ moreover have "distinct XS\<^sub>R" "sorted_fst XS\<^sub>R"
	+ using XSLR "1.prems"(1,2) sorted_fst_def sorted_wrt_drop by simp_all
	+ ultimately have "t_closest_pair_rec XS\<^sub>R \<le> closest_pair_recurrence (length XS\<^sub>R)"
	+ using "1.IH" by simp
	+ hence IHR: "t_closest_pair_rec XS\<^sub>R \<le> closest_pair_recurrence (nat \<lceil>real ?n / 2\<rceil>)"
	+ using * by simp
	+
	+ have "(YS, C\<^sub>0, C\<^sub>1) = closest_pair_rec ps"
	+ using False closest_pair_rec_simps defs C\<^sub>0\<^sub>1_def by (auto simp: Let_def split: prod.split)
	+ hence "set ps = set YS" "length ps = length YS" "distinct YS" "sorted_snd YS"
	+ using "1.prems" closest_pair_rec_set_length_sorted_snd closest_pair_rec_distinct by auto
	+ moreover have "\<forall>p \<in> set YS\<^sub>L. fst p \<le> L"
	+ using False "1.prems"(2) XSLR \<open>length XS\<^sub>L < length ps\<close> \<open>length XS\<^sub>L = length ps div 2\<close>
	+ L_def CP\<^sub>L_def sorted_fst_take_less_hd_drop closest_pair_rec_set_length_sorted_snd by metis
	+ moreover have "\<forall>p \<in> set YS\<^sub>R. L \<le> fst p"
	+ using False "1.prems"(2) XSLR L_def CP\<^sub>R_def
	+ sorted_fst_hd_drop_less_drop closest_pair_rec_set_length_sorted_snd by blast
	+ moreover have "set YS = set YS\<^sub>L \<union> set YS\<^sub>R"
	+ using set_merge defs by fast
	+ moreover have "sparse (dist C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L) (set YS\<^sub>L)"
	+ using CP\<^sub>L_def \<open>1 < length XS\<^sub>L\<close> \<open>distinct XS\<^sub>L\<close> \<open>sorted_fst XS\<^sub>L\<close>
	+ closest_pair_rec_dist closest_pair_rec_set_length_sorted_snd by auto
	+ moreover have "sparse (dist C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R) (set YS\<^sub>R)"
	+ using CP\<^sub>R_def \<open>1 < length XS\<^sub>R\<close> \<open>distinct XS\<^sub>R\<close> \<open>sorted_fst XS\<^sub>R\<close>
	+ closest_pair_rec_dist closest_pair_rec_set_length_sorted_snd by auto
	+ ultimately have "TC \<le> 10 * ?n"
	+ using t_combine TC_def by presburger
	+ moreover have "t_length ps = ?n"
	+ using t_length by blast
	+ moreover have "TS \<le> ?n"
	+ using t_split_at TS_def by blast
	+ moreover have "TL \<le> closest_pair_recurrence (nat \<lfloor>real ?n / 2\<rfloor>)"
	+ using IHL TL_def by blast
	+ moreover have "TR \<le> closest_pair_recurrence (nat \<lceil>real ?n / 2\<rceil>)"
	+ using IHR TR_def by blast
	+ moreover have "TM \<le> ?n"
	+ using L t_merge TM_def by auto
	+ ultimately show ?thesis
	+ using FL FR by linarith
	+ qed
	+qed
	+
	+theorem closest_pair_recurrence:
	+ "closest_pair_recurrence \<in> \<Theta>(\<lambda>n. n * ln n)"
	+ by (master_theorem) auto
	+
	+theorem t_closest_pair_rec_bigo:
	+ "t_closest_pair_rec \<in> O[length going_to at_top within { ps. distinct ps \<and> sorted_fst ps }]((\<lambda>n. n * ln n) o length)"
	+proof -
	+ have 0: "\<And>ps. ps \<in> { ps. distinct ps \<and> sorted_fst ps } \<Longrightarrow>
	+ t_closest_pair_rec ps \<le> (closest_pair_recurrence o length) ps"
	+ unfolding comp_def using t_closest_pair_rec_conv_closest_pair_recurrence by auto
	+ show ?thesis
	+ using bigo_measure_trans[OF 0] bigthetaD1[OF closest_pair_recurrence] of_nat_0_le_iff by blast
	+qed
	+
	+definition t_closest_pair :: "point list \<Rightarrow> nat" where
	+ "t_closest_pair ps = t_mergesort fst ps + t_closest_pair_rec (mergesort fst ps)"
	+
	+definition closest_pair_time :: "nat \<Rightarrow> real" where
	+ "closest_pair_time n = mergesort_recurrence n + closest_pair_recurrence n"
	+
	+lemma t_closest_pair_conv_closest_pair_recurrence:
	+ assumes "distinct ps"
	+ shows "t_closest_pair ps \<le> closest_pair_time (length ps)"
	+ unfolding t_closest_pair_def closest_pair_time_def
	+ using t_closest_pair_rec_conv_closest_pair_recurrence[of "mergesort fst ps"] t_mergesort_conv_mergesort_recurrence[of fst ps]
	+ by (simp add: mergesort sorted_fst_def assms)
	+
	+corollary closest_pair_time:
	+ "closest_pair_time \<in> O(\<lambda>n. n * ln n)"
	+ unfolding closest_pair_time_def
	+ using mergesort_recurrence closest_pair_recurrence sum_in_bigo(1) by blast
	+
	+corollary t_closest_pair_bigo:
	+ "t_closest_pair \<in> O[length going_to at_top within { ps. distinct ps }]((\<lambda>n. n * ln n) o length)"
	+proof -
	+ have 0: "\<And>ps. ps \<in> { ps. distinct ps } \<Longrightarrow>
	+ t_closest_pair ps \<le> (closest_pair_time o length) ps"
	+ unfolding comp_def using t_closest_pair_conv_closest_pair_recurrence by auto
	+ show ?thesis
	+ using bigo_measure_trans[OF 0] closest_pair_time by fastforce
	+qed
	+
	+
	+subsection "Code Export"
	+
	+subsubsection "Combine Step"
	+
	+fun find_closest_code :: "point \<Rightarrow> int \<Rightarrow> point list \<Rightarrow> (int * point)" where
	+ "find_closest_code _ _ [] = undefined"
	+\| "find_closest_code p _ [p\<^sub>0] = (dist_code p p\<^sub>0, p\<^sub>0)"
	+\| "find_closest_code p \<delta> (p\<^sub>0 # ps) = (
	+ let \<delta>\<^sub>0 = dist_code p p\<^sub>0 in
	+ if \<delta> \<le> (snd p\<^sub>0 - snd p)\<^sup>2 then
	+ (\<delta>\<^sub>0, p\<^sub>0)
	+ else
	+ let (\<delta>\<^sub>1, p\<^sub>1) = find_closest_code p (min \<delta> \<delta>\<^sub>0) ps in
	+ if \<delta>\<^sub>0 \<le> \<delta>\<^sub>1 then
	+ (\<delta>\<^sub>0, p\<^sub>0)
	+ else
	+ (\<delta>\<^sub>1, p\<^sub>1)
	+ )"
	+
	+lemma find_closest_code_dist_eq:
	+ "0 < length ps \<Longrightarrow> (\<delta>\<^sub>c, c) = find_closest_code p \<delta> ps \<Longrightarrow> \<delta>\<^sub>c = dist_code p c"
	+proof (induction p \<delta> ps arbitrary: \<delta>\<^sub>c c rule: find_closest_code.induct)
	+ case (3 p \<delta> p\<^sub>0 p\<^sub>2 ps)
	+ show ?case
	+ proof cases
	+ assume "\<delta> \<le> (snd p\<^sub>0 - snd p)\<^sup>2"
	+ thus ?thesis
	+ using "3.prems"(2) by simp
	+ next
	+ assume A: "\<not> \<delta> \<le> (snd p\<^sub>0 - snd p)\<^sup>2"
	+ define \<delta>\<^sub>0 where \<delta>\<^sub>0_def: "\<delta>\<^sub>0 = dist_code p p\<^sub>0"
	+ obtain \<delta>\<^sub>1 p\<^sub>1 where \<delta>\<^sub>1_def: "(\<delta>\<^sub>1, p\<^sub>1) = find_closest_code p (min \<delta> \<delta>\<^sub>0) (p\<^sub>2 # ps)"
	+ by (metis surj_pair)
	+ note defs = \<delta>\<^sub>0_def \<delta>\<^sub>1_def
	+ have "\<delta>\<^sub>1 = dist_code p p\<^sub>1"
	+ using "3.IH"[of \<delta>\<^sub>0 \<delta>\<^sub>1 p\<^sub>1] A defs by simp
	+ thus ?thesis
	+ using defs "3.prems" by (auto simp: Let_def split: if_splits prod.splits)
	+ qed
	+qed simp_all
	+
	+declare find_closest.simps [simp add]
	+
	+lemma find_closest_code_eq:
	+ assumes "0 < length ps" "\<delta> = dist c\<^sub>0 c\<^sub>1" "\<delta>' = dist_code c\<^sub>0 c\<^sub>1" "sorted_snd (p # ps)"
	+ assumes "c = find_closest p \<delta> ps" "(\<delta>\<^sub>c', c') = find_closest_code p \<delta>' ps"
	+ shows "c = c'"
	+ using assms
	+proof (induction p \<delta> ps arbitrary: \<delta>' c\<^sub>0 c\<^sub>1 c \<delta>\<^sub>c' c' rule: find_closest.induct)
	+ case (3 p \<delta> p\<^sub>0 p\<^sub>2 ps)
	+ define \<delta>\<^sub>0 \<delta>\<^sub>0' where \<delta>\<^sub>0_def: "\<delta>\<^sub>0 = dist p p\<^sub>0" "\<delta>\<^sub>0' = dist_code p p\<^sub>0"
	+ obtain p\<^sub>1 \<delta>\<^sub>1' p\<^sub>1' where \<delta>\<^sub>1_def: "p\<^sub>1 = find_closest p (min \<delta> \<delta>\<^sub>0) (p\<^sub>2 # ps)"
	+ "(\<delta>\<^sub>1', p\<^sub>1') = find_closest_code p (min \<delta>' \<delta>\<^sub>0') (p\<^sub>2 # ps)"
	+ by (metis surj_pair)
	+ note defs = \<delta>\<^sub>0_def \<delta>\<^sub>1_def
	+ show ?case
	+ proof cases
	+ assume *: "\<delta> \<le> snd p\<^sub>0 - snd p"
	+ hence "\<delta>' \<le> (snd p\<^sub>0 - snd p)\<^sup>2"
	+ using "3.prems"(2,3) dist_eq_dist_code_abs_le by fastforce
	+ thus ?thesis
	+ using * "3.prems"(5,6) by simp
	+ next
	+ assume *: "\<not> \<delta> \<le> snd p\<^sub>0 - snd p"
	+ moreover have "0 \<le> snd p\<^sub>0 - snd p"
	+ using "3.prems"(4) sorted_snd_def by simp
	+ ultimately have A: "\<not> \<delta>' \<le> (snd p\<^sub>0 - snd p)\<^sup>2"
	+ using "3.prems"(2,3) dist_eq_dist_code_abs_le[of c\<^sub>0 c\<^sub>1 "snd p\<^sub>0 - snd p"] by simp
	+ have "min \<delta> \<delta>\<^sub>0 = \<delta> \<longleftrightarrow> min \<delta>' \<delta>\<^sub>0' = \<delta>'" "min \<delta> \<delta>\<^sub>0 = \<delta>\<^sub>0 \<longleftrightarrow> min \<delta>' \<delta>\<^sub>0' = \<delta>\<^sub>0'"
	+ by (metis "3.prems"(2,3) defs(1,2) dist_eq_dist_code_le min.commute min_def)+
	+ moreover have "sorted_snd (p # p\<^sub>2 # ps)"
	+ using "3.prems"(4) sorted_snd_def by simp
	+ ultimately have B: "p\<^sub>1 = p\<^sub>1'"
	+ using "3.IH"[of c\<^sub>0 c\<^sub>1 \<delta>' p\<^sub>1 \<delta>\<^sub>1' p\<^sub>1'] "3.IH"[of p p\<^sub>0 \<delta>\<^sub>0' p\<^sub>1 \<delta>\<^sub>1' p\<^sub>1'] "3.prems"(2,3) defs * by auto
	+ have "\<delta>\<^sub>1' = dist_code p p\<^sub>1'"
	+ using find_closest_code_dist_eq defs by blast
	+ hence "\<delta>\<^sub>0 \<le> dist p p\<^sub>1 \<longleftrightarrow> \<delta>\<^sub>0' \<le> \<delta>\<^sub>1'"
	+ using defs(1,2) dist_eq_dist_code_le by (simp add: B)
	+ thus ?thesis
	+ using "3.prems"(5,6) * A B defs by (auto simp: Let_def split: prod.splits)
	+ qed
	+qed auto
	+
	+fun find_closest_pair_code :: "(int * point * point) \<Rightarrow> point list \<Rightarrow> (int * point * point)" where
	+ "find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) [] = (\<delta>, c\<^sub>0, c\<^sub>1)"
	+\| "find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) [p] = (\<delta>, c\<^sub>0, c\<^sub>1)"
	+\| "find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) (p\<^sub>0 # ps) = (
	+ let (\<delta>', p\<^sub>1) = find_closest_code p\<^sub>0 \<delta> ps in
	+ if \<delta> \<le> \<delta>' then
	+ find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) ps
	+ else
	+ find_closest_pair_code (\<delta>', p\<^sub>0, p\<^sub>1) ps
	+ )"
	+
	+lemma find_closest_pair_code_dist_eq:
	+ assumes "\<delta> = dist_code c\<^sub>0 c\<^sub>1" "(\<Delta>, C\<^sub>0, C\<^sub>1) = find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) ps"
	+ shows "\<Delta> = dist_code C\<^sub>0 C\<^sub>1"
	+ using assms
	+proof (induction "(\<delta>, c\<^sub>0, c\<^sub>1)" ps arbitrary: \<delta> c\<^sub>0 c\<^sub>1 \<Delta> C\<^sub>0 C\<^sub>1 rule: find_closest_pair_code.induct)
	+ case (3 \<delta> c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ obtain \<delta>' p\<^sub>1 where \<delta>'_def: "(\<delta>', p\<^sub>1) = find_closest_code p\<^sub>0 \<delta> (p\<^sub>2 # ps)"
	+ by (metis surj_pair)
	+ hence A: "\<delta>' = dist_code p\<^sub>0 p\<^sub>1"
	+ using find_closest_code_dist_eq by blast
	+ show ?case
	+ proof (cases "\<delta> \<le> \<delta>'")
	+ case True
	+ obtain \<Delta>' C\<^sub>0' C\<^sub>1' where \<Delta>'_def: "(\<Delta>', C\<^sub>0', C\<^sub>1') = find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ by (metis prod_cases4)
	+ note defs = \<delta>'_def \<Delta>'_def
	+ hence "\<Delta>' = dist_code C\<^sub>0' C\<^sub>1'"
	+ using "3.hyps"(1)[of "(\<delta>', p\<^sub>1)" \<delta>' p\<^sub>1] "3.prems"(1) True \<delta>'_def by blast
	+ moreover have "\<Delta> = \<Delta>'" "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs True "3.prems"(2) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ next
	+ case False
	+ obtain \<Delta>' C\<^sub>0' C\<^sub>1' where \<Delta>'_def: "(\<Delta>', C\<^sub>0', C\<^sub>1') = find_closest_pair_code (\<delta>', p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ by (metis prod_cases4)
	+ note defs = \<delta>'_def \<Delta>'_def
	+ hence "\<Delta>' = dist_code C\<^sub>0' C\<^sub>1'"
	+ using "3.hyps"(2)[of "(\<delta>', p\<^sub>1)" \<delta>' p\<^sub>1] A False \<delta>'_def by blast
	+ moreover have "\<Delta> = \<Delta>'" "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs False "3.prems"(2) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+qed auto
	+
	+declare find_closest_pair.simps [simp add]
	+
	+lemma find_closest_pair_code_eq:
	+ assumes "\<delta> = dist c\<^sub>0 c\<^sub>1" "\<delta>' = dist_code c\<^sub>0 c\<^sub>1" "sorted_snd ps"
	+ assumes "(C\<^sub>0, C\<^sub>1) = find_closest_pair (c\<^sub>0, c\<^sub>1) ps"
	+ assumes "(\<Delta>', C\<^sub>0', C\<^sub>1') = find_closest_pair_code (\<delta>', c\<^sub>0, c\<^sub>1) ps"
	+ shows "C\<^sub>0 = C\<^sub>0' \<and> C\<^sub>1 = C\<^sub>1'"
	+ using assms
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: \<delta> \<delta>' c\<^sub>0 c\<^sub>1 C\<^sub>0 C\<^sub>1 \<Delta>' C\<^sub>0' C\<^sub>1' rule: find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ obtain p\<^sub>1 \<delta>\<^sub>p' p\<^sub>1' where \<delta>\<^sub>p_def: "p\<^sub>1 = find_closest p\<^sub>0 \<delta> (p\<^sub>2 # ps)"
	+ "(\<delta>\<^sub>p', p\<^sub>1') = find_closest_code p\<^sub>0 \<delta>' (p\<^sub>2 # ps)"
	+ by (metis surj_pair)
	+ hence A: "\<delta>\<^sub>p' = dist_code p\<^sub>0 p\<^sub>1'"
	+ using find_closest_code_dist_eq by blast
	+ have B: "p\<^sub>1 = p\<^sub>1'"
	+ using "3.prems"(1,2,3) \<delta>\<^sub>p_def find_closest_code_eq by blast
	+ show ?case
	+ proof (cases "\<delta> \<le> dist p\<^sub>0 p\<^sub>1")
	+ case True
	+ hence C: "\<delta>' \<le> \<delta>\<^sub>p'"
	+ by (simp add: "3.prems"(1,2) A B dist_eq_dist_code_le)
	+ obtain C\<^sub>0\<^sub>i C\<^sub>1\<^sub>i \<Delta>\<^sub>i' C\<^sub>0\<^sub>i' C\<^sub>1\<^sub>i' where \<Delta>\<^sub>i_def:
	+ "(C\<^sub>0\<^sub>i, C\<^sub>1\<^sub>i) = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ "(\<Delta>\<^sub>i', C\<^sub>0\<^sub>i', C\<^sub>1\<^sub>i') = find_closest_pair_code (\<delta>', c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ by (metis prod_cases3)
	+ note defs = \<delta>\<^sub>p_def \<Delta>\<^sub>i_def
	+ have "sorted_snd (p\<^sub>2 # ps)"
	+ using "3.prems"(3) sorted_snd_def by simp
	+ hence "C\<^sub>0\<^sub>i = C\<^sub>0\<^sub>i' \<and> C\<^sub>1\<^sub>i = C\<^sub>1\<^sub>i'"
	+ using "3.hyps"(1) "3.prems"(1,2) True defs by blast
	+ moreover have "C\<^sub>0 = C\<^sub>0\<^sub>i" "C\<^sub>1 = C\<^sub>1\<^sub>i"
	+ using defs(1,3) True "3.prems"(1,4) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ moreover have "\<Delta>' = \<Delta>\<^sub>i'" "C\<^sub>0' = C\<^sub>0\<^sub>i'" "C\<^sub>1' = C\<^sub>1\<^sub>i'"
	+ using defs(2,4) C "3.prems"(5) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ next
	+ case False
	+ hence C: "\<not> \<delta>' \<le> \<delta>\<^sub>p'"
	+ by (simp add: "3.prems"(1,2) A B dist_eq_dist_code_le)
	+ obtain C\<^sub>0\<^sub>i C\<^sub>1\<^sub>i \<Delta>\<^sub>i' C\<^sub>0\<^sub>i' C\<^sub>1\<^sub>i' where \<Delta>\<^sub>i_def:
	+ "(C\<^sub>0\<^sub>i, C\<^sub>1\<^sub>i) = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ "(\<Delta>\<^sub>i', C\<^sub>0\<^sub>i', C\<^sub>1\<^sub>i') = find_closest_pair_code (\<delta>\<^sub>p', p\<^sub>0, p\<^sub>1') (p\<^sub>2 # ps)"
	+ by (metis prod_cases3)
	+ note defs = \<delta>\<^sub>p_def \<Delta>\<^sub>i_def
	+ have "sorted_snd (p\<^sub>2 # ps)"
	+ using "3.prems"(3) sorted_snd_def by simp
	+ hence "C\<^sub>0\<^sub>i = C\<^sub>0\<^sub>i' \<and> C\<^sub>1\<^sub>i = C\<^sub>1\<^sub>i'"
	+ using "3.prems"(1) "3.hyps"(2) A B False defs by blast
	+ moreover have "C\<^sub>0 = C\<^sub>0\<^sub>i" "C\<^sub>1 = C\<^sub>1\<^sub>i"
	+ using defs(1,3) False "3.prems"(1,4) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ moreover have "\<Delta>' = \<Delta>\<^sub>i'" "C\<^sub>0' = C\<^sub>0\<^sub>i'" "C\<^sub>1' = C\<^sub>1\<^sub>i'"
	+ using defs(2,4) C "3.prems"(5) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+qed auto
	+
	+fun combine_code :: "(int * point * point) \<Rightarrow> (int * point * point) \<Rightarrow> int \<Rightarrow> point list \<Rightarrow> (int * point * point)" where
	+ "combine_code (\<delta>\<^sub>L, p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (\<delta>\<^sub>R, p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps = (
	+ let (\<delta>, c\<^sub>0, c\<^sub>1) = if \<delta>\<^sub>L < \<delta>\<^sub>R then (\<delta>\<^sub>L, p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (\<delta>\<^sub>R, p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) in
	+ let ps' = filter (\<lambda>p. (fst p - l)\<^sup>2 < \<delta>) ps in
	+ find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) ps'
	+ )"
	+
	+lemma combine_code_dist_eq:
	+ assumes "\<delta>\<^sub>L = dist_code p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L" "\<delta>\<^sub>R = dist_code p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R"
	+ assumes "(\<delta>, c\<^sub>0, c\<^sub>1) = combine_code (\<delta>\<^sub>L, p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (\<delta>\<^sub>R, p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ shows "\<delta> = dist_code c\<^sub>0 c\<^sub>1"
	+ using assms by (auto simp: find_closest_pair_code_dist_eq split: if_splits)
	+
	+lemma combine_code_eq:
	+ assumes "\<delta>\<^sub>L' = dist_code p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L" "\<delta>\<^sub>R' = dist_code p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R" "sorted_snd ps"
	+ assumes "(c\<^sub>0, c\<^sub>1) = combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ assumes "(\<delta>', c\<^sub>0', c\<^sub>1') = combine_code (\<delta>\<^sub>L', p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (\<delta>\<^sub>R', p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ shows "c\<^sub>0 = c\<^sub>0' \<and> c\<^sub>1 = c\<^sub>1'"
	+proof -
	+ obtain C\<^sub>0\<^sub>i C\<^sub>1\<^sub>i \<Delta>\<^sub>i' C\<^sub>0\<^sub>i' C\<^sub>1\<^sub>i' where \<Delta>\<^sub>i_def:
	+ "(C\<^sub>0\<^sub>i, C\<^sub>1\<^sub>i) = (if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))"
	+ "(\<Delta>\<^sub>i', C\<^sub>0\<^sub>i', C\<^sub>1\<^sub>i') = (if \<delta>\<^sub>L' < \<delta>\<^sub>R' then (\<delta>\<^sub>L', p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (\<delta>\<^sub>R', p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))"
	+ by metis
	+ define ps' ps'' where ps'_def:
	+ "ps' = filter (\<lambda>p. dist p (l, snd p) < dist C\<^sub>0\<^sub>i C\<^sub>1\<^sub>i) ps"
	+ "ps'' = filter (\<lambda>p. (fst p - l)\<^sup>2 < \<Delta>\<^sub>i') ps"
	+ obtain C\<^sub>0 C\<^sub>1 \<Delta>' C\<^sub>0' C\<^sub>1' where \<Delta>_def:
	+ "(C\<^sub>0, C\<^sub>1) = find_closest_pair (C\<^sub>0\<^sub>i, C\<^sub>1\<^sub>i) ps'"
	+ "(\<Delta>', C\<^sub>0', C\<^sub>1') = find_closest_pair_code (\<Delta>\<^sub>i', C\<^sub>0\<^sub>i', C\<^sub>1\<^sub>i') ps''"
	+ by (metis prod_cases3)
	+ note defs = \<Delta>\<^sub>i_def ps'_def \<Delta>_def
	+ have *: "C\<^sub>0\<^sub>i = C\<^sub>0\<^sub>i'" "C\<^sub>1\<^sub>i = C\<^sub>1\<^sub>i'" "\<Delta>\<^sub>i' = dist_code C\<^sub>0\<^sub>i' C\<^sub>1\<^sub>i'"
	+ using \<Delta>\<^sub>i_def assms(1,2,3,4) dist_eq_dist_code_lt by (auto split: if_splits)
	+ hence "\<And>p. \<bar>fst p - l\<bar> < dist C\<^sub>0\<^sub>i C\<^sub>1\<^sub>i \<longleftrightarrow> (fst p - l)\<^sup>2 < \<Delta>\<^sub>i'"
	+ using dist_eq_dist_code_abs_lt by (metis (mono_tags) of_int_abs)
	+ hence "ps' = ps''"
	+ using ps'_def dist_fst_abs by auto
	+ moreover have "sorted_snd ps'"
	+ using assms(3) ps'_def sorted_snd_def sorted_wrt_filter by blast
	+ ultimately have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using * find_closest_pair_code_eq \<Delta>_def by blast+
	+ moreover have "C\<^sub>0 = c\<^sub>0" "C\<^sub>1 = c\<^sub>1"
	+ using assms(4) defs(1,3,5) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ moreover have "C\<^sub>0' = c\<^sub>0'" "C\<^sub>1' = c\<^sub>1'"
	+ using assms(5) defs(2,4,6) apply (auto split: prod.splits) by (metis prod.inject)+
	+ ultimately show ?thesis
	+ by blast
	+qed
	+
	+subsubsection "Divide and Conquer Algorithm"
	+
	+function closest_pair_rec_code :: "point list \<Rightarrow> (point list * int * point * point)" where
	+ "closest_pair_rec_code xs = (
	+ let n = length xs in
	+ if n \<le> 3 then
	+ (mergesort snd xs, closest_pair_bf_code xs)
	+ else
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ let l = fst (hd xs\<^sub>R) in
	+
	+ let (ys\<^sub>L, p\<^sub>L) = closest_pair_rec_code xs\<^sub>L in
	+ let (ys\<^sub>R, p\<^sub>R) = closest_pair_rec_code xs\<^sub>R in
	+
	+ let ys = merge snd ys\<^sub>L ys\<^sub>R in
	+ (ys, combine_code p\<^sub>L p\<^sub>R l ys)
	+ )"
	+ by pat_completeness auto
	+termination closest_pair_rec_code
	+ apply (relation "Wellfounded.measure (\<lambda>xs. length xs)")
	+ apply (auto simp: split_at_take_drop_conv Let_def)
	+ done
	+
	+lemma closest_pair_rec_code_simps:
	+ assumes "n = length xs" "\<not> (n \<le> 3)"
	+ shows "closest_pair_rec_code xs = (
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ let l = fst (hd xs\<^sub>R) in
	+ let (ys\<^sub>L, p\<^sub>L) = closest_pair_rec_code xs\<^sub>L in
	+ let (ys\<^sub>R, p\<^sub>R) = closest_pair_rec_code xs\<^sub>R in
	+ let ys = merge snd ys\<^sub>L ys\<^sub>R in
	+ (ys, combine_code p\<^sub>L p\<^sub>R l ys)
	+ )"
	+ using assms by (auto simp: Let_def)
	+
	+declare combine.simps combine_code.simps closest_pair_rec_code.simps [simp del]
	+
	+lemma closest_pair_rec_code_dist_eq:
	+ assumes "1 < length xs" "(ys, \<delta>, c\<^sub>0, c\<^sub>1) = closest_pair_rec_code xs"
	+ shows "\<delta> = dist_code c\<^sub>0 c\<^sub>1"
	+ using assms
	+proof (induction xs arbitrary: ys \<delta> c\<^sub>0 c\<^sub>1 rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "(\<delta>, c\<^sub>0, c\<^sub>1) = closest_pair_bf_code xs"
	+ using "1.prems"(2) closest_pair_rec_code.simps by simp
	+ thus ?thesis
	+ using "1.prems"(1) closest_pair_bf_code_dist_eq by simp
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L \<Delta>\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L where YSC\<^sub>0\<^sub>1\<^sub>L_def: "(YS\<^sub>L, \<Delta>\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec_code XS\<^sub>L"
	+ using prod.collapse by metis
	+ obtain YS\<^sub>R \<Delta>\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R where YSC\<^sub>0\<^sub>1\<^sub>R_def: "(YS\<^sub>R, \<Delta>\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec_code XS\<^sub>R"
	+ using prod.collapse by metis
	+
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ obtain \<Delta> C\<^sub>0 C\<^sub>1 where C\<^sub>0\<^sub>1_def: "(\<Delta>, C\<^sub>0, C\<^sub>1) = combine_code (\<Delta>\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (\<Delta>\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ using prod.collapse by metis
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSC\<^sub>0\<^sub>1\<^sub>L_def YSC\<^sub>0\<^sub>1\<^sub>R_def YS_def C\<^sub>0\<^sub>1_def
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHL: "\<Delta>\<^sub>L = dist_code C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L"
	+ using "1.IH" defs by metis+
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHR: "\<Delta>\<^sub>R = dist_code C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R"
	+ using "1.IH" defs by metis+
	+
	+ have *: "(YS, \<Delta>, C\<^sub>0, C\<^sub>1) = closest_pair_rec_code xs"
	+ using False closest_pair_rec_code_simps defs by (auto simp: Let_def split: prod.split)
	+ moreover have "\<Delta> = dist_code C\<^sub>0 C\<^sub>1"
	+ using combine_code_dist_eq IHL IHR C\<^sub>0\<^sub>1_def by blast
	+ ultimately show ?thesis
	+ using "1.prems"(2) * by (metis Pair_inject)
	+ qed
	+qed
	+
	+lemma closest_pair_rec_ys_eq:
	+ assumes "1 < length xs"
	+ assumes "(ys, c\<^sub>0, c\<^sub>1) = closest_pair_rec xs"
	+ assumes "(ys', \<delta>', c\<^sub>0', c\<^sub>1') = closest_pair_rec_code xs"
	+ shows "ys = ys'"
	+ using assms
	+proof (induction xs arbitrary: ys c\<^sub>0 c\<^sub>1 ys' \<delta>' c\<^sub>0' c\<^sub>1' rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "ys = mergesort snd xs"
	+ using "1.prems"(2) closest_pair_rec.simps by simp
	+ moreover have "ys' = mergesort snd xs"
	+ using "1.prems"(3) closest_pair_rec_code.simps by (simp add: True)
	+ ultimately show ?thesis
	+ using "1.prems"(1) by simp
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L YS\<^sub>L' \<Delta>\<^sub>L' C\<^sub>0\<^sub>L' C\<^sub>1\<^sub>L' where YSC\<^sub>0\<^sub>1\<^sub>L_def:
	+ "(YS\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ "(YS\<^sub>L', \<Delta>\<^sub>L', C\<^sub>0\<^sub>L', C\<^sub>1\<^sub>L') = closest_pair_rec_code XS\<^sub>L"
	+ using prod.collapse by metis
	+ obtain YS\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R YS\<^sub>R' \<Delta>\<^sub>R' C\<^sub>0\<^sub>R' C\<^sub>1\<^sub>R' where YSC\<^sub>0\<^sub>1\<^sub>R_def:
	+ "(YS\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ "(YS\<^sub>R', \<Delta>\<^sub>R', C\<^sub>0\<^sub>R', C\<^sub>1\<^sub>R') = closest_pair_rec_code XS\<^sub>R"
	+ using prod.collapse by metis
	+
	+ define YS YS' where YS_def:
	+ "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ "YS' = merge (\<lambda>p. snd p) YS\<^sub>L' YS\<^sub>R'"
	+ obtain C\<^sub>0 C\<^sub>1 \<Delta>' C\<^sub>0' C\<^sub>1' where C\<^sub>0\<^sub>1_def:
	+ "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ "(\<Delta>', C\<^sub>0', C\<^sub>1') = combine_code (\<Delta>\<^sub>L', C\<^sub>0\<^sub>L', C\<^sub>1\<^sub>L') (\<Delta>\<^sub>R', C\<^sub>0\<^sub>R', C\<^sub>1\<^sub>R') L YS'"
	+ using prod.collapse by metis
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSC\<^sub>0\<^sub>1\<^sub>L_def YSC\<^sub>0\<^sub>1\<^sub>R_def YS_def C\<^sub>0\<^sub>1_def
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHL: "YS\<^sub>L = YS\<^sub>L'"
	+ using "1.IH" defs by metis
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHR: "YS\<^sub>R = YS\<^sub>R'"
	+ using "1.IH" defs by metis
	+
	+ have "(YS, C\<^sub>0, C\<^sub>1) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs(1,2,3,5,7,9)
	+ by (auto simp: Let_def split: prod.split)
	+ moreover have "(YS', \<Delta>', C\<^sub>0', C\<^sub>1') = closest_pair_rec_code xs"
	+ using False closest_pair_rec_code_simps defs(1,2,4,6,8,10)
	+ by (auto simp: Let_def split: prod.split)
	+ moreover have "YS = YS'"
	+ using IHL IHR YS_def by simp
	+ ultimately show ?thesis
	+ by (metis "1.prems"(2,3) Pair_inject)
	+ qed
	+qed
	+
	+lemma closest_pair_rec_code_eq:
	+ assumes "1 < length xs"
	+ assumes "(ys, c\<^sub>0, c\<^sub>1) = closest_pair_rec xs"
	+ assumes "(ys', \<delta>', c\<^sub>0', c\<^sub>1') = closest_pair_rec_code xs"
	+ shows "c\<^sub>0 = c\<^sub>0' \<and> c\<^sub>1 = c\<^sub>1'"
	+ using assms
	+proof (induction xs arbitrary: ys c\<^sub>0 c\<^sub>1 ys' \<delta>' c\<^sub>0' c\<^sub>1' rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "(c\<^sub>0, c\<^sub>1) = closest_pair_bf xs"
	+ using "1.prems"(2) closest_pair_rec.simps by simp
	+ moreover have "(\<delta>', c\<^sub>0', c\<^sub>1') = closest_pair_bf_code xs"
	+ using "1.prems"(3) closest_pair_rec_code.simps by (simp add: True)
	+ ultimately show ?thesis
	+ using "1.prems"(1) closest_pair_bf_code_eq by simp
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L YS\<^sub>L' \<Delta>\<^sub>L' C\<^sub>0\<^sub>L' C\<^sub>1\<^sub>L' where YSC\<^sub>0\<^sub>1\<^sub>L_def:
	+ "(YS\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ "(YS\<^sub>L', \<Delta>\<^sub>L', C\<^sub>0\<^sub>L', C\<^sub>1\<^sub>L') = closest_pair_rec_code XS\<^sub>L"
	+ using prod.collapse by metis
	+ obtain YS\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R YS\<^sub>R' \<Delta>\<^sub>R' C\<^sub>0\<^sub>R' C\<^sub>1\<^sub>R' where YSC\<^sub>0\<^sub>1\<^sub>R_def:
	+ "(YS\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ "(YS\<^sub>R', \<Delta>\<^sub>R', C\<^sub>0\<^sub>R', C\<^sub>1\<^sub>R') = closest_pair_rec_code XS\<^sub>R"
	+ using prod.collapse by metis
	+
	+ define YS YS' where YS_def:
	+ "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ "YS' = merge (\<lambda>p. snd p) YS\<^sub>L' YS\<^sub>R'"
	+ obtain C\<^sub>0 C\<^sub>1 \<Delta>' C\<^sub>0' C\<^sub>1' where C\<^sub>0\<^sub>1_def:
	+ "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ "(\<Delta>', C\<^sub>0', C\<^sub>1') = combine_code (\<Delta>\<^sub>L', C\<^sub>0\<^sub>L', C\<^sub>1\<^sub>L') (\<Delta>\<^sub>R', C\<^sub>0\<^sub>R', C\<^sub>1\<^sub>R') L YS'"
	+ using prod.collapse by metis
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSC\<^sub>0\<^sub>1\<^sub>L_def YSC\<^sub>0\<^sub>1\<^sub>R_def YS_def C\<^sub>0\<^sub>1_def
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHL: "C\<^sub>0\<^sub>L = C\<^sub>0\<^sub>L'" "C\<^sub>1\<^sub>L = C\<^sub>1\<^sub>L'"
	+ using "1.IH" defs by metis+
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHR: "C\<^sub>0\<^sub>R = C\<^sub>0\<^sub>R'" "C\<^sub>1\<^sub>R = C\<^sub>1\<^sub>R'"
	+ using "1.IH" defs by metis+
	+
	+ have "sorted_snd YS\<^sub>L" "sorted_snd YS\<^sub>R"
	+ using closest_pair_rec_set_length_sorted_snd YSC\<^sub>0\<^sub>1\<^sub>L_def(1) YSC\<^sub>0\<^sub>1\<^sub>R_def(1) by blast+
	+ hence "sorted_snd YS"
	+ using sorted_merge sorted_snd_def YS_def by blast
	+ moreover have "YS = YS'"
	+ using defs \<open>1 < length XS\<^sub>L\<close> \<open>1 < length XS\<^sub>R\<close> closest_pair_rec_ys_eq by blast
	+ moreover have "\<Delta>\<^sub>L' = dist_code C\<^sub>0\<^sub>L' C\<^sub>1\<^sub>L'" "\<Delta>\<^sub>R' = dist_code C\<^sub>0\<^sub>R' C\<^sub>1\<^sub>R'"
	+ using defs \<open>1 < length XS\<^sub>L\<close> \<open>1 < length XS\<^sub>R\<close> closest_pair_rec_code_dist_eq by blast+
	+ ultimately have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using combine_code_eq IHL IHR C\<^sub>0\<^sub>1_def by blast+
	+ moreover have "(YS, C\<^sub>0, C\<^sub>1) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs(1,2,3,5,7,9)
	+ by (auto simp: Let_def split: prod.split)
	+ moreover have "(YS', \<Delta>', C\<^sub>0', C\<^sub>1') = closest_pair_rec_code xs"
	+ using False closest_pair_rec_code_simps defs(1,2,4,6,8,10)
	+ by (auto simp: Let_def split: prod.split)
	+ ultimately show ?thesis
	+ using "1.prems"(2,3) by (metis Pair_inject)
	+ qed
	+qed
	+
	+declare closest_pair.simps [simp add]
	+
	+fun closest_pair_code :: "point list \<Rightarrow> (point * point)" where
	+ "closest_pair_code [] = undefined"
	+\| "closest_pair_code [_] = undefined"
	+\| "closest_pair_code ps = (let (_, _, c\<^sub>0, c\<^sub>1) = closest_pair_rec_code (mergesort fst ps) in (c\<^sub>0, c\<^sub>1))"
	+
	+lemma closest_pair_code_eq:
	+ "closest_pair ps = closest_pair_code ps"
	+proof (induction ps rule: induct_list012)
	+ case (3 x y zs)
	+ obtain ys c\<^sub>0 c\<^sub>1 ys' \<delta>' c\<^sub>0' c\<^sub>1' where *:
	+ "(ys, c\<^sub>0, c\<^sub>1) = closest_pair_rec (mergesort fst (x # y # zs))"
	+ "(ys', \<delta>', c\<^sub>0', c\<^sub>1') = closest_pair_rec_code (mergesort fst (x # y # zs))"
	+ by (metis prod_cases3)
	+ moreover have "1 < length (mergesort fst (x # y # zs))"
	+ using length_mergesort[of fst "x # y # zs"] by simp
	+ ultimately have "c\<^sub>0 = c\<^sub>0'" "c\<^sub>1 = c\<^sub>1'"
	+ using closest_pair_rec_code_eq by blast+
	+ thus ?case
	+ using * by (auto split: prod.splits)
	+qed auto
	+
	+export_code closest_pair_code in OCaml
	+ module_name Verified
	+
	+end
	diff --git a/thys/Closest_Pair_Points/Closest_Pair_Alternative.thy b/thys/Closest_Pair_Points/Closest_Pair_Alternative.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Closest_Pair_Points/Closest_Pair_Alternative.thy
	@@ -0,0 +1,1438 @@
	+section "Closest Pair Algorithm 2"
	+
	+theory Closest_Pair_Alternative
	+ imports Common
	+begin
	+
	+text\<open>
	+ Formalization of a divide-and-conquer algorithm solving the Closest Pair Problem based
	+ on the presentation of Kleinberg and Tardos \cite{Algorithm-Design:2005}.
	+\<close>
	+
	+subsection "Functional Correctness Proof"
	+
	+subsubsection "Core Argument"
	+
	+lemma core_argument:
	+ assumes "distinct (p\<^sub>0 # ps)" "sorted_snd (p\<^sub>0 # ps)" "0 \<le> \<delta>" "set (p\<^sub>0 # ps) = ps\<^sub>L \<union> ps\<^sub>R"
	+ assumes "\<forall>p \<in> set (p\<^sub>0 # ps). l - \<delta> \<le> fst p \<and> fst p \<le> l + \<delta>"
	+ assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
	+ assumes "sparse \<delta> ps\<^sub>L" "sparse \<delta> ps\<^sub>R"
	+ assumes "p\<^sub>1 \<in> set ps" "dist p\<^sub>0 p\<^sub>1 < \<delta>"
	+ shows "p\<^sub>1 \<in> set (take 7 ps)"
	+proof -
	+ define PS where "PS = p\<^sub>0 # ps"
	+ define R where "R = cbox (l - \<delta>, snd p\<^sub>0) (l + \<delta>, snd p\<^sub>0 + \<delta>)"
	+ define RPS where "RPS = { p \<in> set PS. p \<in> R }"
	+ define LSQ where "LSQ = cbox (l - \<delta>, snd p\<^sub>0) (l, snd p\<^sub>0 + \<delta>)"
	+ define LSQPS where "LSQPS = { p \<in> ps\<^sub>L. p \<in> LSQ }"
	+ define RSQ where "RSQ = cbox (l, snd p\<^sub>0) (l + \<delta>, snd p\<^sub>0 + \<delta>)"
	+ define RSQPS where "RSQPS = { p \<in> ps\<^sub>R. p \<in> RSQ }"
	+ note defs = PS_def R_def RPS_def LSQ_def LSQPS_def RSQ_def RSQPS_def
	+
	+ have "R = LSQ \<union> RSQ"
	+ using defs cbox_right_un by auto
	+ moreover have "\<forall>p \<in> ps\<^sub>L. p \<in> RSQ \<longrightarrow> p \<in> LSQ"
	+ using RSQ_def LSQ_def assms(6) by auto
	+ moreover have "\<forall>p \<in> ps\<^sub>R. p \<in> LSQ \<longrightarrow> p \<in> RSQ"
	+ using RSQ_def LSQ_def assms(7) by auto
	+ ultimately have "RPS = LSQPS \<union> RSQPS"
	+ using LSQPS_def RSQPS_def PS_def RPS_def assms(4) by blast
	+
	+ have "sparse \<delta> LSQPS"
	+ using assms(8) LSQPS_def sparse_def by simp
	+ hence CLSQPS: "card LSQPS \<le> 4"
	+ using max_points_square[of LSQPS "l - \<delta>" "snd p\<^sub>0" \<delta>] assms(3) LSQ_def LSQPS_def by auto
	+
	+ have "sparse \<delta> RSQPS"
	+ using assms(9) RSQPS_def sparse_def by simp
	+ hence CRSQPS: "card RSQPS \<le> 4"
	+ using max_points_square[of RSQPS l "snd p\<^sub>0" \<delta>] assms(3) RSQ_def RSQPS_def by auto
	+
	+ have CRPS: "card RPS \<le> 8"
	+ using CLSQPS CRSQPS card_Un_le[of LSQPS RSQPS] \<open>RPS = LSQPS \<union> RSQPS\<close> by auto
	+
	+ have "RPS \<subseteq> set (take 8 PS)"
	+ proof (rule ccontr)
	+ assume "\<not> (RPS \<subseteq> set (take 8 PS))"
	+ then obtain p where *: "p \<in> set PS" "p \<in> RPS" "p \<notin> set (take 8 PS)" "p \<in> R"
	+ using RPS_def by auto
	+
	+ have "\<forall>p\<^sub>0 \<in> set (take 8 PS). \<forall>p\<^sub>1 \<in> set (drop 8 PS). snd p\<^sub>0 \<le> snd p\<^sub>1"
	+ using sorted_wrt_take_drop[of "\<lambda>p\<^sub>0 p\<^sub>1. snd p\<^sub>0 \<le> snd p\<^sub>1" PS 8] assms(2) sorted_snd_def PS_def by fastforce
	+ hence "\<forall>p' \<in> set (take 8 PS). snd p' \<le> snd p"
	+ using append_take_drop_id set_append Un_iff *(1,3) by metis
	+ moreover have "snd p \<le> snd p\<^sub>0 + \<delta>"
	+ using \<open>p \<in> R\<close> R_def mem_cbox_2D by (metis (mono_tags, lifting) prod.case_eq_if)
	+ ultimately have "\<forall>p \<in> set (take 8 PS). snd p \<le> snd p\<^sub>0 + \<delta>"
	+ by fastforce
	+ moreover have "\<forall>p \<in> set (take 8 PS). snd p\<^sub>0 \<le> snd p"
	+ using sorted_wrt_hd_less_take[of "\<lambda>p\<^sub>0 p\<^sub>1. snd p\<^sub>0 \<le> snd p\<^sub>1" p\<^sub>0 ps 8] assms(2) sorted_snd_def PS_def by fastforce
	+ moreover have "\<forall>p \<in> set (take 8 PS). l - \<delta> \<le> fst p \<and> fst p \<le> l + \<delta>"
	+ using assms(5) PS_def by (meson in_set_takeD)
	+ ultimately have "\<forall>p \<in> set (take 8 PS). p \<in> R"
	+ using R_def mem_cbox_2D by fastforce
	+
	+ hence "set (take 8 PS) \<subseteq> RPS"
	+ using RPS_def set_take_subset by fastforce
	+ hence NINE: "{ p } \<union> set (take 8 PS) \<subseteq> RPS"
	+ using * by simp
	+
	+ have "8 \<le> length PS"
	+ using *(1,3) nat_le_linear by fastforce
	+ hence "length (take 8 PS) = 8"
	+ by simp
	+
	+ have "finite { p }" "finite (set (take 8 PS))"
	+ by simp_all
	+ hence "card ({ p } \<union> set (take 8 PS)) = card ({ p }) + card (set (take 8 PS))"
	+ using *(3) card_Un_disjoint by blast
	+ hence "card ({ p } \<union> set (take 8 PS)) = 9"
	+ using assms(1) \<open>length (take 8 PS) = 8\<close> distinct_card[of "take 8 PS"] distinct_take[of PS] PS_def by fastforce
	+ moreover have "finite RPS"
	+ using RPS_def by simp
	+ ultimately have "9 \<le> card RPS"
	+ using NINE card_mono by metis
	+ thus False
	+ using CRPS by simp
	+ qed
	+
	+ have "dist (snd p\<^sub>0) (snd p\<^sub>1) < \<delta>"
	+ using assms(11) dist_snd_le le_less_trans by (metis (no_types, lifting) prod.case_eq_if snd_conv)
	+ hence "snd p\<^sub>1 \<le> snd p\<^sub>0 + \<delta>"
	+ by (simp add: dist_real_def)
	+ moreover have "l - \<delta> \<le> fst p\<^sub>1" "fst p\<^sub>1 \<le> l + \<delta>"
	+ using assms(5,10) by auto
	+ moreover have "snd p\<^sub>0 \<le> snd p\<^sub>1"
	+ using sorted_snd_def assms(2,10) by auto
	+ ultimately have "p\<^sub>1 \<in> R"
	+ using mem_cbox_2D[of "l - \<delta>" "fst p\<^sub>1" "l + \<delta>" "snd p\<^sub>0" "snd p\<^sub>1" "snd p\<^sub>0 + \<delta>"] defs
	+ by (simp add: \<open>l - \<delta> \<le> fst p\<^sub>1\<close> \<open>snd p\<^sub>0 \<le> snd p\<^sub>1\<close> prod.case_eq_if)
	+ moreover have "p\<^sub>1 \<in> set PS"
	+ using PS_def assms(10) by simp
	+ ultimately have "p\<^sub>1 \<in> set (take 8 PS)"
	+ using RPS_def \<open>RPS \<subseteq> set (take 8 PS)\<close> by auto
	+ thus ?thesis
	+ using assms(1,10) PS_def by auto
	+qed
	+
	+subsubsection "Combine step"
	+
	+lemma find_closest_bf_dist_take_7:
	+ assumes "\<exists>p\<^sub>1 \<in> set ps. dist p\<^sub>0 p\<^sub>1 < \<delta>"
	+ assumes "distinct (p\<^sub>0 # ps)" "sorted_snd (p\<^sub>0 # ps)" "0 < length ps" "0 \<le> \<delta>" "set (p\<^sub>0 # ps) = ps\<^sub>L \<union> ps\<^sub>R"
	+ assumes "\<forall>p \<in> set (p\<^sub>0 # ps). l - \<delta> \<le> fst p \<and> fst p \<le> l + \<delta>"
	+ assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
	+ assumes "sparse \<delta> ps\<^sub>L" "sparse \<delta> ps\<^sub>R"
	+ shows "\<forall>p\<^sub>1 \<in> set ps. dist p\<^sub>0 (find_closest_bf p\<^sub>0 (take 7 ps)) \<le> dist p\<^sub>0 p\<^sub>1"
	+proof -
	+ have "dist p\<^sub>0 (find_closest_bf p\<^sub>0 ps) < \<delta>"
	+ using assms(1) dual_order.strict_trans2 find_closest_bf_dist by blast
	+ moreover have "find_closest_bf p\<^sub>0 ps \<in> set ps"
	+ using assms(4) find_closest_bf_set by blast
	+ ultimately have "find_closest_bf p\<^sub>0 ps \<in> set (take 7 ps)"
	+ using core_argument[of p\<^sub>0 ps \<delta> ps\<^sub>L ps\<^sub>R l "find_closest_bf p\<^sub>0 ps"] assms by blast
	+ moreover have "\<forall>p\<^sub>1 \<in> set (take 7 ps). dist p\<^sub>0 (find_closest_bf p\<^sub>0 (take 7 ps)) \<le> dist p\<^sub>0 p\<^sub>1"
	+ using find_closest_bf_dist by blast
	+ ultimately have "\<forall>p\<^sub>1 \<in> set ps. dist p\<^sub>0 (find_closest_bf p\<^sub>0 (take 7 ps)) \<le> dist p\<^sub>0 p\<^sub>1"
	+ using find_closest_bf_dist order.trans by blast
	+ thus ?thesis .
	+qed
	+
	+fun find_closest_pair :: "(point * point) \<Rightarrow> point list \<Rightarrow> (point * point)" where
	+ "find_closest_pair (c\<^sub>0, c\<^sub>1) [] = (c\<^sub>0, c\<^sub>1)"
	+\| "find_closest_pair (c\<^sub>0, c\<^sub>1) [_] = (c\<^sub>0, c\<^sub>1)"
	+\| "find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>0 # ps) = (
	+ let p\<^sub>1 = find_closest_bf p\<^sub>0 (take 7 ps) in
	+ if dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1 then
	+ find_closest_pair (c\<^sub>0, c\<^sub>1) ps
	+ else
	+ find_closest_pair (p\<^sub>0, p\<^sub>1) ps
	+ )"
	+
	+lemma find_closest_pair_set:
	+ assumes "(C\<^sub>0, C\<^sub>1) = find_closest_pair (c\<^sub>0, c\<^sub>1) ps"
	+ shows "(C\<^sub>0 \<in> set ps \<and> C\<^sub>1 \<in> set ps) \<or> (C\<^sub>0 = c\<^sub>0 \<and> C\<^sub>1 = c\<^sub>1)"
	+ using assms
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: c\<^sub>0 c\<^sub>1 C\<^sub>0 C\<^sub>1 rule: find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 (take 7 (p\<^sub>2 # ps))"
	+ hence A: "p\<^sub>1 \<in> set (p\<^sub>2 # ps)"
	+ using find_closest_bf_set[of "take 7 (p\<^sub>2 # ps)"] in_set_takeD by fastforce
	+ show ?case
	+ proof (cases "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1")
	+ case True
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "(C\<^sub>0' \<in> set (p\<^sub>2 # ps) \<and> C\<^sub>1' \<in> set (p\<^sub>2 # ps)) \<or> (C\<^sub>0' = c\<^sub>0 \<and> C\<^sub>1' = c\<^sub>1)"
	+ using "3.hyps"(1) True p\<^sub>1_def by blast
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs True "3.prems" apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by auto
	+ next
	+ case False
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "(C\<^sub>0' \<in> set (p\<^sub>2 # ps) \<and> C\<^sub>1' \<in> set (p\<^sub>2 # ps)) \<or> (C\<^sub>0' = p\<^sub>0 \<and> C\<^sub>1' = p\<^sub>1)"
	+ using "3.hyps"(2) p\<^sub>1_def False by blast
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs False "3.prems" apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ using A by auto
	+ qed
	+qed auto
	+
	+lemma find_closest_pair_c0_ne_c1:
	+ "c\<^sub>0 \<noteq> c\<^sub>1 \<Longrightarrow> distinct ps \<Longrightarrow> (C\<^sub>0, C\<^sub>1) = find_closest_pair (c\<^sub>0, c\<^sub>1) ps \<Longrightarrow> C\<^sub>0 \<noteq> C\<^sub>1"
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: c\<^sub>0 c\<^sub>1 C\<^sub>0 C\<^sub>1 rule: find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 (take 7 (p\<^sub>2 # ps))"
	+ hence "p\<^sub>1 \<in> set (p\<^sub>2 # ps)"
	+ using find_closest_bf_set[of "take 7 (p\<^sub>2 # ps)"] in_set_takeD by fastforce
	+ hence A: "p\<^sub>0 \<noteq> p\<^sub>1"
	+ using "3.prems"(1,2) by auto
	+ show ?case
	+ proof (cases "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1")
	+ case True
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "C\<^sub>0' \<noteq> C\<^sub>1'"
	+ using "3.hyps"(1) "3.prems"(1,2) True p\<^sub>1_def by simp
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs True "3.prems"(3) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ next
	+ case False
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "C\<^sub>0' \<noteq> C\<^sub>1'"
	+ using "3.hyps"(2) "3.prems"(2) A False p\<^sub>1_def by simp
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs False "3.prems"(3) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+qed auto
	+
	+lemma find_closest_pair_dist_mono:
	+ assumes "(C\<^sub>0, C\<^sub>1) = find_closest_pair (c\<^sub>0, c\<^sub>1) ps"
	+ shows "dist C\<^sub>0 C\<^sub>1 \<le> dist c\<^sub>0 c\<^sub>1"
	+ using assms
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: c\<^sub>0 c\<^sub>1 C\<^sub>0 C\<^sub>1 rule: find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 (take 7 (p\<^sub>2 # ps))"
	+ show ?case
	+ proof (cases "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1")
	+ case True
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "dist C\<^sub>0' C\<^sub>1' \<le> dist c\<^sub>0 c\<^sub>1"
	+ using "3.hyps"(1) True p\<^sub>1_def by simp
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs True "3.prems" apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ next
	+ case False
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ note defs = p\<^sub>1_def C'_def
	+ hence "dist C\<^sub>0' C\<^sub>1' \<le> dist p\<^sub>0 p\<^sub>1"
	+ using "3.hyps"(2) False p\<^sub>1_def by blast
	+ moreover have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs False "3.prems"(1) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ using False by simp
	+ qed
	+qed auto
	+
	+lemma find_closest_pair_dist:
	+ assumes "sorted_snd ps" "distinct ps" "set ps = ps\<^sub>L \<union> ps\<^sub>R" "0 \<le> \<delta>"
	+ assumes "\<forall>p \<in> set ps. l - \<delta> \<le> fst p \<and> fst p \<le> l + \<delta>"
	+ assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
	+ assumes "sparse \<delta> ps\<^sub>L" "sparse \<delta> ps\<^sub>R" "dist c\<^sub>0 c\<^sub>1 \<le> \<delta>"
	+ assumes "(C\<^sub>0, C\<^sub>1) = find_closest_pair (c\<^sub>0, c\<^sub>1) ps"
	+ shows "sparse (dist C\<^sub>0 C\<^sub>1) (set ps)"
	+ using assms
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: c\<^sub>0 c\<^sub>1 C\<^sub>0 C\<^sub>1 ps\<^sub>L ps\<^sub>R rule: find_closest_pair.induct)
	+ case (1 c\<^sub>0 c\<^sub>1)
	+ thus ?case unfolding sparse_def
	+ by simp
	+next
	+ case (2 c\<^sub>0 c\<^sub>1 uu)
	+ thus ?case unfolding sparse_def
	+ by (metis length_greater_0_conv length_pos_if_in_set set_ConsD)
	+next
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 (take 7 (p\<^sub>2 # ps))"
	+ define PS\<^sub>L where PS\<^sub>L_def: "PS\<^sub>L = ps\<^sub>L - { p\<^sub>0 }"
	+ define PS\<^sub>R where PS\<^sub>R_def: "PS\<^sub>R = ps\<^sub>R - { p\<^sub>0 }"
	+
	+ have assms: "sorted_snd (p\<^sub>2 # ps)" "distinct (p\<^sub>2 # ps)" "set (p\<^sub>2 # ps) = PS\<^sub>L \<union> PS\<^sub>R"
	+ "\<forall>p \<in> set (p\<^sub>2 # ps). l - \<delta> \<le> (fst p) \<and> (fst p) \<le> l + \<delta>"
	+ "\<forall>p \<in> PS\<^sub>L. fst p \<le> l" "\<forall>p \<in> PS\<^sub>R. l \<le> fst p"
	+ "sparse \<delta> PS\<^sub>L" "sparse \<delta> PS\<^sub>R"
	+ using "3.prems"(1-9) sparse_def sorted_snd_def PS\<^sub>L_def PS\<^sub>R_def by auto
	+
	+ show ?case
	+ proof cases
	+ assume C1: "\<exists>p \<in> set (p\<^sub>2 # ps). dist p\<^sub>0 p < \<delta>"
	+ hence A: "\<forall>p \<in> set (p\<^sub>2 # ps). dist p\<^sub>0 p\<^sub>1 \<le> dist p\<^sub>0 p"
	+ using p\<^sub>1_def find_closest_bf_dist_take_7 "3.prems" by blast
	+ hence B: "dist p\<^sub>0 p\<^sub>1 < \<delta>"
	+ using C1 by auto
	+ show ?thesis
	+ proof cases
	+ assume C2: "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1"
	+ obtain C\<^sub>0' C\<^sub>1' where def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ hence "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>2 # ps))"
	+ using "3.hyps"(1)[of p\<^sub>1 PS\<^sub>L PS\<^sub>R] C2 p\<^sub>1_def "3.prems"(4,10) assms by blast
	+ moreover have "dist C\<^sub>0' C\<^sub>1' \<le> dist c\<^sub>0 c\<^sub>1"
	+ using def find_closest_pair_dist_mono by blast
	+ ultimately have "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>0 # p\<^sub>2 # ps))"
	+ using A C2 sparse_identity[of "dist C\<^sub>0' C\<^sub>1'" "p\<^sub>2 # ps" p\<^sub>0] by fastforce
	+ moreover have "C\<^sub>0' = C\<^sub>0" "C\<^sub>1' = C\<^sub>1"
	+ using def "3.prems"(11) C2 p\<^sub>1_def apply (auto) by (metis prod.inject)+
	+ ultimately show ?thesis
	+ by simp
	+ next
	+ assume C2: "\<not> dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1"
	+ obtain C\<^sub>0' C\<^sub>1' where def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ hence "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>2 # ps))"
	+ using "3.hyps"(2)[of p\<^sub>1 PS\<^sub>L PS\<^sub>R] C2 p\<^sub>1_def "3.prems"(4) assms B by auto
	+ moreover have "dist C\<^sub>0' C\<^sub>1' \<le> dist p\<^sub>0 p\<^sub>1"
	+ using def find_closest_pair_dist_mono by blast
	+ ultimately have "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>0 # p\<^sub>2 # ps))"
	+ using A sparse_identity order_trans by blast
	+ moreover have "C\<^sub>0' = C\<^sub>0" "C\<^sub>1' = C\<^sub>1"
	+ using def "3.prems"(11) C2 p\<^sub>1_def apply (auto) by (metis prod.inject)+
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+ next
	+ assume C1: "\<not> (\<exists>p \<in> set (p\<^sub>2 # ps). dist p\<^sub>0 p < \<delta>)"
	+ show ?thesis
	+ proof cases
	+ assume C2: "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1"
	+ obtain C\<^sub>0' C\<^sub>1' where def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ hence "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>2 # ps))"
	+ using "3.hyps"(1)[of p\<^sub>1 PS\<^sub>L PS\<^sub>R] C2 p\<^sub>1_def "3.prems"(4,10) assms by blast
	+ moreover have "dist C\<^sub>0' C\<^sub>1' \<le> dist c\<^sub>0 c\<^sub>1"
	+ using def find_closest_pair_dist_mono by blast
	+ ultimately have "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>0 # p\<^sub>2 # ps))"
	+ using "3.prems"(10) C1 sparse_identity[of "dist C\<^sub>0' C\<^sub>1'" "p\<^sub>2 # ps" p\<^sub>0] by force
	+ moreover have "C\<^sub>0' = C\<^sub>0" "C\<^sub>1' = C\<^sub>1"
	+ using def "3.prems"(11) C2 p\<^sub>1_def apply (auto) by (metis prod.inject)+
	+ ultimately show ?thesis
	+ by simp
	+ next
	+ assume C2: "\<not> dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1"
	+ obtain C\<^sub>0' C\<^sub>1' where def: "(C\<^sub>0', C\<^sub>1') = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ using prod.collapse by blast
	+ hence "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>2 # ps))"
	+ using "3.hyps"(2)[of p\<^sub>1 PS\<^sub>L PS\<^sub>R] C2 p\<^sub>1_def "3.prems"(4,10) assms by auto
	+ moreover have "dist C\<^sub>0' C\<^sub>1' \<le> dist p\<^sub>0 p\<^sub>1"
	+ using def find_closest_pair_dist_mono by blast
	+ ultimately have "sparse (dist C\<^sub>0' C\<^sub>1') (set (p\<^sub>0 # p\<^sub>2 # ps))"
	+ using "3.prems"(10) C1 C2 sparse_identity[of "dist C\<^sub>0' C\<^sub>1'" "p\<^sub>2 # ps" p\<^sub>0] by force
	+ moreover have "C\<^sub>0' = C\<^sub>0" "C\<^sub>1' = C\<^sub>1"
	+ using def "3.prems"(11) C2 p\<^sub>1_def apply (auto) by (metis prod.inject)+
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+ qed
	+qed
	+
	+declare find_closest_pair.simps [simp del]
	+
	+fun combine :: "(point * point) \<Rightarrow> (point * point) \<Rightarrow> int \<Rightarrow> point list \<Rightarrow> (point * point)" where
	+ "combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps = (
	+ let (c\<^sub>0, c\<^sub>1) = if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) in
	+ let ps' = filter (\<lambda>p. dist p (l, snd p) < dist c\<^sub>0 c\<^sub>1) ps in
	+ find_closest_pair (c\<^sub>0, c\<^sub>1) ps'
	+ )"
	+
	+lemma combine_set:
	+ assumes "(c\<^sub>0, c\<^sub>1) = combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ shows "(c\<^sub>0 \<in> set ps \<and> c\<^sub>1 \<in> set ps) \<or> (c\<^sub>0 = p\<^sub>0\<^sub>L \<and> c\<^sub>1 = p\<^sub>1\<^sub>L) \<or> (c\<^sub>0 = p\<^sub>0\<^sub>R \<and> c\<^sub>1 = p\<^sub>1\<^sub>R)"
	+proof -
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = (if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))"
	+ by metis
	+ define ps' where ps'_def: "ps' = filter (\<lambda>p. dist p (l, snd p) < dist C\<^sub>0' C\<^sub>1') ps"
	+ obtain C\<^sub>0 C\<^sub>1 where C_def: "(C\<^sub>0, C\<^sub>1) = find_closest_pair (C\<^sub>0', C\<^sub>1') ps'"
	+ using prod.collapse by blast
	+ note defs = C'_def ps'_def C_def
	+ have "(C\<^sub>0 \<in> set ps' \<and> C\<^sub>1 \<in> set ps') \<or> (C\<^sub>0 = C\<^sub>0' \<and> C\<^sub>1 = C\<^sub>1')"
	+ using C_def find_closest_pair_set by blast+
	+ hence "(C\<^sub>0 \<in> set ps \<and> C\<^sub>1 \<in> set ps)\<or> (C\<^sub>0 = C\<^sub>0' \<and> C\<^sub>1 = C\<^sub>1')"
	+ using ps'_def by auto
	+ moreover have "C\<^sub>0 = c\<^sub>0" "C\<^sub>1 = c\<^sub>1"
	+ using assms defs apply (auto split: if_splits prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ using C'_def by (auto split: if_splits)
	+qed
	+
	+lemma combine_c0_ne_c1:
	+ assumes "p\<^sub>0\<^sub>L \<noteq> p\<^sub>1\<^sub>L" "p\<^sub>0\<^sub>R \<noteq> p\<^sub>1\<^sub>R" "distinct ps"
	+ assumes "(c\<^sub>0, c\<^sub>1) = combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ shows "c\<^sub>0 \<noteq> c\<^sub>1"
	+proof -
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = (if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))"
	+ by metis
	+ define ps' where ps'_def: "ps' = filter (\<lambda>p. dist p (l, snd p) < dist C\<^sub>0' C\<^sub>1') ps"
	+ obtain C\<^sub>0 C\<^sub>1 where C_def: "(C\<^sub>0, C\<^sub>1) = find_closest_pair (C\<^sub>0', C\<^sub>1') ps'"
	+ using prod.collapse by blast
	+ note defs = C'_def ps'_def C_def
	+ have "C\<^sub>0 \<noteq> C\<^sub>1"
	+ using defs find_closest_pair_c0_ne_c1[of C\<^sub>0' C\<^sub>1' ps'] assms by (auto split: if_splits)
	+ moreover have "C\<^sub>0 = c\<^sub>0" "C\<^sub>1 = c\<^sub>1"
	+ using assms defs apply (auto split: if_splits prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by blast
	+qed
	+
	+lemma combine_dist:
	+ assumes "distinct ps" "sorted_snd ps" "set ps = ps\<^sub>L \<union> ps\<^sub>R"
	+ assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
	+ assumes "sparse (dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L) ps\<^sub>L" "sparse (dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R) ps\<^sub>R"
	+ assumes "(c\<^sub>0, c\<^sub>1) = combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ shows "sparse (dist c\<^sub>0 c\<^sub>1) (set ps)"
	+proof -
	+ obtain C\<^sub>0' C\<^sub>1' where C'_def: "(C\<^sub>0', C\<^sub>1') = (if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))"
	+ by metis
	+ define ps' where ps'_def: "ps' = filter (\<lambda>p. dist p (l, snd p) < dist C\<^sub>0' C\<^sub>1') ps"
	+ define PS\<^sub>L where PS\<^sub>L_def: "PS\<^sub>L = { p \<in> ps\<^sub>L. dist p (l, snd p) < dist C\<^sub>0' C\<^sub>1' }"
	+ define PS\<^sub>R where PS\<^sub>R_def: "PS\<^sub>R = { p \<in> ps\<^sub>R. dist p (l, snd p) < dist C\<^sub>0' C\<^sub>1' }"
	+ obtain C\<^sub>0 C\<^sub>1 where C_def: "(C\<^sub>0, C\<^sub>1) = find_closest_pair (C\<^sub>0', C\<^sub>1') ps'"
	+ using prod.collapse by blast
	+ note defs = C'_def ps'_def PS\<^sub>L_def PS\<^sub>R_def C_def
	+ have EQ: "C\<^sub>0 = c\<^sub>0" "C\<^sub>1 = c\<^sub>1"
	+ using defs assms(8) apply (auto split: if_splits prod.splits) by (metis Pair_inject)+
	+ have ps': "ps' = filter (\<lambda>p. l - dist C\<^sub>0' C\<^sub>1' < fst p \<and> fst p < l + dist C\<^sub>0' C\<^sub>1') ps"
	+ using ps'_def dist_transform by simp
	+ have ps\<^sub>L: "sparse (dist C\<^sub>0' C\<^sub>1') ps\<^sub>L"
	+ using assms(6,8) C'_def sparse_def apply (auto split: if_splits) by force+
	+ hence PS\<^sub>L: "sparse (dist C\<^sub>0' C\<^sub>1') PS\<^sub>L"
	+ using PS\<^sub>L_def by (simp add: sparse_def)
	+ have ps\<^sub>R: "sparse (dist C\<^sub>0' C\<^sub>1') ps\<^sub>R"
	+ using assms(5,7) C'_def sparse_def apply (auto split: if_splits) by force+
	+ hence PS\<^sub>R: "sparse (dist C\<^sub>0' C\<^sub>1') PS\<^sub>R"
	+ using PS\<^sub>R_def by (simp add: sparse_def)
	+ have "sorted_snd ps'"
	+ using ps'_def assms(2) sorted_snd_def sorted_wrt_filter by blast
	+ moreover have "distinct ps'"
	+ using ps'_def assms(1) distinct_filter by blast
	+ moreover have "set ps' = PS\<^sub>L \<union> PS\<^sub>R "
	+ using ps'_def PS\<^sub>L_def PS\<^sub>R_def assms(3) filter_Un by auto
	+ moreover have "0 \<le> dist C\<^sub>0' C\<^sub>1'"
	+ by simp
	+ moreover have "\<forall>p \<in> set ps'. l - dist C\<^sub>0' C\<^sub>1' \<le> fst p \<and> fst p \<le> l + dist C\<^sub>0' C\<^sub>1'"
	+ using ps' by simp
	+ ultimately have *: "sparse (dist C\<^sub>0 C\<^sub>1) (set ps')"
	+ using find_closest_pair_dist[of ps' PS\<^sub>L PS\<^sub>R "dist C\<^sub>0' C\<^sub>1'" l C\<^sub>0' C\<^sub>1'] C_def PS\<^sub>L PS\<^sub>R
	+ by (simp add: PS\<^sub>L_def PS\<^sub>R_def assms(4,5))
	+ have "\<forall>p\<^sub>0 \<in> set ps. \<forall>p\<^sub>1 \<in> set ps. p\<^sub>0 \<noteq> p\<^sub>1 \<and> dist p\<^sub>0 p\<^sub>1 < dist C\<^sub>0' C\<^sub>1' \<longrightarrow> p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<in> set ps'"
	+ using set_band_filter ps' ps\<^sub>L ps\<^sub>R assms(3,4,5) by blast
	+ moreover have "dist C\<^sub>0 C\<^sub>1 \<le> dist C\<^sub>0' C\<^sub>1'"
	+ using C_def find_closest_pair_dist_mono by blast
	+ ultimately have "\<forall>p\<^sub>0 \<in> set ps. \<forall>p\<^sub>1 \<in> set ps. p\<^sub>0 \<noteq> p\<^sub>1 \<and> dist p\<^sub>0 p\<^sub>1 < dist C\<^sub>0 C\<^sub>1 \<longrightarrow> p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<in> set ps'"
	+ by simp
	+ hence "sparse (dist C\<^sub>0 C\<^sub>1) (set ps)"
	+ using sparse_def * by (meson not_less)
	+ thus ?thesis
	+ using EQ by blast
	+qed
	+
	+subsubsection "Divide and Conquer Algorithm"
	+
	+function closest_pair_rec :: "point list \<Rightarrow> (point list * point * point)" where
	+ "closest_pair_rec xs = (
	+ let n = length xs in
	+ if n \<le> 3 then
	+ (mergesort snd xs, closest_pair_bf xs)
	+ else
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ let l = fst (hd xs\<^sub>R) in
	+
	+ let (ys\<^sub>L, p\<^sub>L) = closest_pair_rec xs\<^sub>L in
	+ let (ys\<^sub>R, p\<^sub>R) = closest_pair_rec xs\<^sub>R in
	+
	+ let ys = merge snd ys\<^sub>L ys\<^sub>R in
	+ (ys, combine p\<^sub>L p\<^sub>R l ys)
	+ )"
	+ by pat_completeness auto
	+termination closest_pair_rec
	+ apply (relation "Wellfounded.measure (\<lambda>xs. length xs)")
	+ apply (auto simp: split_at_take_drop_conv Let_def)
	+ done
	+
	+lemma closest_pair_rec_simps:
	+ assumes "n = length xs" "\<not> (n \<le> 3)"
	+ shows "closest_pair_rec xs = (
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ let l = fst (hd xs\<^sub>R) in
	+ let (ys\<^sub>L, p\<^sub>L) = closest_pair_rec xs\<^sub>L in
	+ let (ys\<^sub>R, p\<^sub>R) = closest_pair_rec xs\<^sub>R in
	+ let ys = merge snd ys\<^sub>L ys\<^sub>R in
	+ (ys, combine p\<^sub>L p\<^sub>R l ys)
	+ )"
	+ using assms by (auto simp: Let_def)
	+
	+declare combine.simps closest_pair_rec.simps [simp del]
	+
	+lemma closest_pair_rec_set_length_sorted_snd:
	+ assumes "(ys, p) = closest_pair_rec xs"
	+ shows "set ys = set xs \<and> length ys = length xs \<and> sorted_snd ys"
	+ using assms
	+proof (induction xs arbitrary: ys p rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ thus ?thesis using "1.prems" sorted_snd_def
	+ by (auto simp: mergesort closest_pair_rec.simps)
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+ obtain YS\<^sub>L P\<^sub>L where YSP\<^sub>L_def: "(YS\<^sub>L, P\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ using prod.collapse by blast
	+ obtain YS\<^sub>R P\<^sub>R where YSP\<^sub>R_def: "(YS\<^sub>R, P\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ using prod.collapse by blast
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ define P where "P = combine P\<^sub>L P\<^sub>R L YS"
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSP\<^sub>L_def YSP\<^sub>R_def YS_def P_def
	+
	+ have "length XS\<^sub>L < length xs" "length XS\<^sub>R < length xs"
	+ using False defs by (auto simp: split_at_take_drop_conv)
	+ hence IH: "set XS\<^sub>L = set YS\<^sub>L" "set XS\<^sub>R = set YS\<^sub>R"
	+ "length XS\<^sub>L = length YS\<^sub>L" "length XS\<^sub>R = length YS\<^sub>R"
	+ "sorted_snd YS\<^sub>L" "sorted_snd YS\<^sub>R"
	+ using "1.IH" defs by metis+
	+
	+ have "set xs = set XS\<^sub>L \<union> set XS\<^sub>R"
	+ using defs by (auto simp: set_take_drop split_at_take_drop_conv)
	+ hence SET: "set xs = set YS"
	+ using set_merge IH(1,2) defs by fast
	+
	+ have "length xs = length XS\<^sub>L + length XS\<^sub>R"
	+ using defs by (auto simp: split_at_take_drop_conv)
	+ hence LENGTH: "length xs = length YS"
	+ using IH(3,4) length_merge defs by metis
	+
	+ have SORTED: "sorted_snd YS"
	+ using IH(5,6) by (simp add: defs sorted_snd_def sorted_merge)
	+
	+ have "(YS, P) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs by (auto simp: Let_def split: prod.split)
	+ hence "(ys, p) = (YS, P)"
	+ using "1.prems" by argo
	+ thus ?thesis
	+ using SET LENGTH SORTED by simp
	+ qed
	+qed
	+
	+lemma closest_pair_rec_distinct:
	+ assumes "distinct xs" "(ys, p) = closest_pair_rec xs"
	+ shows "distinct ys"
	+ using assms
	+proof (induction xs arbitrary: ys p rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ thus ?thesis using "1.prems"
	+ by (auto simp: mergesort closest_pair_rec.simps)
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+ obtain YS\<^sub>L P\<^sub>L where YSP\<^sub>L_def: "(YS\<^sub>L, P\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ using prod.collapse by blast
	+ obtain YS\<^sub>R P\<^sub>R where YSP\<^sub>R_def: "(YS\<^sub>R, P\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ using prod.collapse by blast
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ define P where "P = combine P\<^sub>L P\<^sub>R L YS"
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSP\<^sub>L_def YSP\<^sub>R_def YS_def P_def
	+
	+ have "length XS\<^sub>L < length xs" "length XS\<^sub>R < length xs"
	+ using False defs by (auto simp: split_at_take_drop_conv)
	+ moreover have "distinct XS\<^sub>L" "distinct XS\<^sub>R"
	+ using "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ ultimately have IH: "distinct YS\<^sub>L" "distinct YS\<^sub>R"
	+ using "1.IH" defs by blast+
	+
	+ have "set XS\<^sub>L \<inter> set XS\<^sub>R = {}"
	+ using "1.prems"(1) defs by (auto simp: split_at_take_drop_conv set_take_disj_set_drop_if_distinct)
	+ moreover have "set XS\<^sub>L = set YS\<^sub>L" "set XS\<^sub>R = set YS\<^sub>R"
	+ using closest_pair_rec_set_length_sorted_snd defs by blast+
	+ ultimately have "set YS\<^sub>L \<inter> set YS\<^sub>R = {}"
	+ by blast
	+ hence DISTINCT: "distinct YS"
	+ using distinct_merge IH defs by blast
	+
	+ have "(YS, P) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs by (auto simp: Let_def split: prod.split)
	+ hence "(ys, p) = (YS, P)"
	+ using "1.prems" by argo
	+ thus ?thesis
	+ using DISTINCT by blast
	+ qed
	+qed
	+
	+lemma closest_pair_rec_c0_c1:
	+ assumes "1 < length xs" "distinct xs" "(ys, c\<^sub>0, c\<^sub>1) = closest_pair_rec xs"
	+ shows "c\<^sub>0 \<in> set xs \<and> c\<^sub>1 \<in> set xs \<and> c\<^sub>0 \<noteq> c\<^sub>1"
	+ using assms
	+proof (induction xs arbitrary: ys c\<^sub>0 c\<^sub>1 rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "(c\<^sub>0, c\<^sub>1) = closest_pair_bf xs"
	+ using "1.prems"(3) closest_pair_rec.simps by simp
	+ thus ?thesis
	+ using "1.prems"(1,2) closest_pair_bf_c0_c1 by simp
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L where YSC\<^sub>0\<^sub>1\<^sub>L_def: "(YS\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ using prod.collapse by metis
	+ obtain YS\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R where YSC\<^sub>0\<^sub>1\<^sub>R_def: "(YS\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ using prod.collapse by metis
	+
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ obtain C\<^sub>0 C\<^sub>1 where C\<^sub>0\<^sub>1_def: "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ using prod.collapse by metis
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSC\<^sub>0\<^sub>1\<^sub>L_def YSC\<^sub>0\<^sub>1\<^sub>R_def YS_def C\<^sub>0\<^sub>1_def
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length xs" "distinct XS\<^sub>L"
	+ using False "1.prems"(2) defs by (auto simp: split_at_take_drop_conv)
	+ hence "C\<^sub>0\<^sub>L \<in> set XS\<^sub>L" "C\<^sub>1\<^sub>L \<in> set XS\<^sub>L" and IHL1: "C\<^sub>0\<^sub>L \<noteq> C\<^sub>1\<^sub>L"
	+ using "1.IH" defs by metis+
	+ hence IHL2: "C\<^sub>0\<^sub>L \<in> set xs" "C\<^sub>1\<^sub>L \<in> set xs"
	+ using split_at_take_drop_conv in_set_takeD fst_conv defs by metis+
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length xs" "distinct XS\<^sub>R"
	+ using False "1.prems"(2) defs by (auto simp: split_at_take_drop_conv)
	+ hence "C\<^sub>0\<^sub>R \<in> set XS\<^sub>R" "C\<^sub>1\<^sub>R \<in> set XS\<^sub>R" and IHR1: "C\<^sub>0\<^sub>R \<noteq> C\<^sub>1\<^sub>R"
	+ using "1.IH" defs by metis+
	+ hence IHR2: "C\<^sub>0\<^sub>R \<in> set xs" "C\<^sub>1\<^sub>R \<in> set xs"
	+ using split_at_take_drop_conv in_set_dropD snd_conv defs by metis+
	+
	+ have *: "(YS, C\<^sub>0, C\<^sub>1) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs by (auto simp: Let_def split: prod.split)
	+ have YS: "set xs = set YS" "distinct YS"
	+ using "1.prems"(2) closest_pair_rec_set_length_sorted_snd closest_pair_rec_distinct * by blast+
	+
	+ have "C\<^sub>0 \<in> set xs" "C\<^sub>1 \<in> set xs"
	+ using combine_set IHL2 IHR2 YS defs by blast+
	+ moreover have "C\<^sub>0 \<noteq> C\<^sub>1"
	+ using combine_c0_ne_c1 IHL1(1) IHR1(1) YS defs by blast
	+ ultimately show ?thesis
	+ using "1.prems"(3) * by (metis Pair_inject)
	+ qed
	+qed
	+
	+lemma closest_pair_rec_dist:
	+ assumes "1 < length xs" "distinct xs" "sorted_fst xs" "(ys, c\<^sub>0, c\<^sub>1) = closest_pair_rec xs"
	+ shows "sparse (dist c\<^sub>0 c\<^sub>1) (set xs)"
	+ using assms
	+proof (induction xs arbitrary: ys c\<^sub>0 c\<^sub>1 rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "(c\<^sub>0, c\<^sub>1) = closest_pair_bf xs"
	+ using "1.prems"(4) closest_pair_rec.simps by simp
	+ thus ?thesis
	+ using "1.prems"(1,4) closest_pair_bf_dist by metis
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L where YSC\<^sub>0\<^sub>1\<^sub>L_def: "(YS\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ using prod.collapse by metis
	+ obtain YS\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R where YSC\<^sub>0\<^sub>1\<^sub>R_def: "(YS\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ using prod.collapse by metis
	+
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ obtain C\<^sub>0 C\<^sub>1 where C\<^sub>0\<^sub>1_def: "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ using prod.collapse by metis
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSC\<^sub>0\<^sub>1\<^sub>L_def YSC\<^sub>0\<^sub>1\<^sub>R_def YS_def C\<^sub>0\<^sub>1_def
	+
	+ have XSLR: "XS\<^sub>L = take (?n div 2) xs" "XS\<^sub>R = drop (?n div 2) xs"
	+ using defs by (auto simp: split_at_take_drop_conv)
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length xs"
	+ using False XSLR by simp_all
	+ moreover have "distinct XS\<^sub>L" "sorted_fst XS\<^sub>L"
	+ using "1.prems"(2,3) XSLR by (auto simp: sorted_fst_def sorted_wrt_take)
	+ ultimately have L: "sparse (dist C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L) (set XS\<^sub>L)"
	+ "set XS\<^sub>L = set YS\<^sub>L"
	+ using 1 closest_pair_rec_set_length_sorted_snd closest_pair_rec_c0_c1
	+ YSC\<^sub>0\<^sub>1\<^sub>L_def by blast+
	+ hence IHL: "sparse (dist C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L) (set YS\<^sub>L)"
	+ by argo
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length xs"
	+ using False XSLR by simp_all
	+ moreover have "distinct XS\<^sub>R" "sorted_fst XS\<^sub>R"
	+ using "1.prems"(2,3) XSLR by (auto simp: sorted_fst_def sorted_wrt_drop)
	+ ultimately have R: "sparse (dist C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R) (set XS\<^sub>R)"
	+ "set XS\<^sub>R = set YS\<^sub>R"
	+ using 1 closest_pair_rec_set_length_sorted_snd closest_pair_rec_c0_c1
	+ YSC\<^sub>0\<^sub>1\<^sub>R_def by blast+
	+ hence IHR: "sparse (dist C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R) (set YS\<^sub>R)"
	+ by argo
	+
	+ have *: "(YS, C\<^sub>0, C\<^sub>1) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs by (auto simp: Let_def split: prod.split)
	+
	+ have "set xs = set YS" "distinct YS" "sorted_snd YS"
	+ using "1.prems"(2) closest_pair_rec_set_length_sorted_snd closest_pair_rec_distinct * by blast+
	+ moreover have "\<forall>p \<in> set YS\<^sub>L. fst p \<le> L"
	+ using False "1.prems"(3) XSLR L_def L(2) sorted_fst_take_less_hd_drop by simp
	+ moreover have "\<forall>p \<in> set YS\<^sub>R. L \<le> fst p"
	+ using False "1.prems"(3) XSLR L_def R(2) sorted_fst_hd_drop_less_drop by simp
	+ moreover have "set YS = set YS\<^sub>L \<union> set YS\<^sub>R"
	+ using set_merge defs by fast
	+ moreover have "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ by (auto simp add: defs)
	+ ultimately have "sparse (dist C\<^sub>0 C\<^sub>1) (set xs)"
	+ using combine_dist IHL IHR by auto
	+ moreover have "(YS, C\<^sub>0, C\<^sub>1) = (ys, c\<^sub>0, c\<^sub>1)"
	+ using "1.prems"(4) * by simp
	+ ultimately show ?thesis
	+ by blast
	+ qed
	+qed
	+
	+fun closest_pair :: "point list \<Rightarrow> (point * point)" where
	+ "closest_pair [] = undefined"
	+\| "closest_pair [_] = undefined"
	+\| "closest_pair ps = (let (_, c\<^sub>0, c\<^sub>1) = closest_pair_rec (mergesort fst ps) in (c\<^sub>0, c\<^sub>1))"
	+
	+lemma closest_pair_simps:
	+ "1 < length ps \<Longrightarrow> closest_pair ps = (let (_, c\<^sub>0, c\<^sub>1) = closest_pair_rec (mergesort fst ps) in (c\<^sub>0, c\<^sub>1))"
	+ by (induction ps rule: induct_list012) auto
	+
	+declare closest_pair.simps [simp del]
	+
	+theorem closest_pair_c0_c1:
	+ assumes "1 < length ps" "distinct ps" "(c\<^sub>0, c\<^sub>1) = closest_pair ps"
	+ shows "c\<^sub>0 \<in> set ps" "c\<^sub>1 \<in> set ps" "c\<^sub>0 \<noteq> c\<^sub>1"
	+ using assms closest_pair_rec_c0_c1[of "mergesort fst ps"]
	+ by (auto simp: mergesort closest_pair_simps split: prod.splits)
	+
	+theorem closest_pair_dist:
	+ assumes "1 < length ps" "distinct ps" "(c\<^sub>0, c\<^sub>1) = closest_pair ps"
	+ shows "sparse (dist c\<^sub>0 c\<^sub>1) (set ps)"
	+ using assms closest_pair_rec_dist[of "mergesort fst ps"] closest_pair_rec_c0_c1[of "mergesort fst ps"]
	+ by (auto simp: sorted_fst_def mergesort closest_pair_simps split: prod.splits)
	+
	+
	+subsection "Time Complexity Proof"
	+
	+subsubsection "Combine Step"
	+
	+fun t_find_closest_pair :: "point \<times> point \<Rightarrow> point list \<Rightarrow> nat" where
	+ "t_find_closest_pair _ [] = 0"
	+\| "t_find_closest_pair _ [p\<^sub>0] = 1"
	+\| "t_find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>0 # ps) = 1 + (
	+ let p\<^sub>1 = find_closest_bf p\<^sub>0 (take 7 ps) in
	+ t_take 7 ps + t_find_closest_bf p\<^sub>0 (take 7 ps) + (
	+ if dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1 then
	+ t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps
	+ else
	+ t_find_closest_pair (p\<^sub>0, p\<^sub>1) ps
	+ ))"
	+
	+lemma t_find_closest_pair:
	+ "t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps \<le> 16 * length ps"
	+proof (induction ps rule: t_find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ let ?ps = "p\<^sub>2 # ps"
	+ let ?p\<^sub>1 = "find_closest_bf p\<^sub>0 (take 7 ?ps)"
	+ show ?case
	+ proof cases
	+ assume C1: "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 ?p\<^sub>1"
	+ hence "t_find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>0 # ?ps) = 1 + t_take 7 ?ps +
	+ t_find_closest_bf p\<^sub>0 (take 7 ?ps) + t_find_closest_pair (c\<^sub>0, c\<^sub>1) ?ps"
	+ by simp
	+ also have "... \<le> 16 + t_find_closest_pair (c\<^sub>0, c\<^sub>1) ?ps"
	+ using t_take[of 7 ?ps] t_find_closest_bf by auto
	+ also have "... \<le> 16 + 16 * (length ?ps)"
	+ using "3.IH"(1) C1 by simp
	+ also have "... = 16 * length (p\<^sub>0 # ?ps)"
	+ by simp
	+ finally show ?thesis .
	+ next
	+ assume C1: "\<not> dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 ?p\<^sub>1"
	+ hence "t_find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>0 # ?ps) = 1 + t_take 7 ?ps +
	+ t_find_closest_bf p\<^sub>0 (take 7 ?ps) + t_find_closest_pair (p\<^sub>0, ?p\<^sub>1) ?ps"
	+ by simp
	+ also have "... \<le> 16 + t_find_closest_pair (p\<^sub>0, ?p\<^sub>1) ?ps"
	+ using t_take[of 7 ?ps] t_find_closest_bf by auto
	+ also have "... \<le> 16 + 16 * (length ?ps)"
	+ using "3.IH"(2) C1 by simp
	+ also have "... = 16 * length (p\<^sub>0 # ?ps)"
	+ by simp
	+ finally show ?thesis .
	+ qed
	+qed simp_all
	+
	+declare t_find_closest_pair.simps [simp del]
	+
	+fun t_combine :: "(point * point) \<Rightarrow> (point * point) \<Rightarrow> int \<Rightarrow> point list \<Rightarrow> nat" where
	+ "t_combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps = (
	+ let (c\<^sub>0, c\<^sub>1) = if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) in
	+ let ps' = filter (\<lambda>p. dist p (l, snd p) < dist c\<^sub>0 c\<^sub>1) ps in
	+ t_filter (\<lambda>p. dist p (l, snd p) < dist c\<^sub>0 c\<^sub>1) ps + t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps'
	+ )"
	+
	+lemma t_combine:
	+ fixes ps :: "point list"
	+ shows "t_combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps \<le> 17 * length ps"
	+proof -
	+ obtain c\<^sub>0 c\<^sub>1 where c_def:
	+ "(c\<^sub>0, c\<^sub>1) = (if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))" by metis
	+ let ?P = "(\<lambda>p. dist p (l, snd p) < dist c\<^sub>0 c\<^sub>1)"
	+ define ps' where ps'_def: "ps' = filter ?P ps"
	+ note defs = c_def ps'_def
	+ have "t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps' \<le> 16 * length ps'"
	+ using t_find_closest_pair by blast
	+ moreover have "length ps' \<le> length ps"
	+ using ps'_def by simp
	+ ultimately have : "t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps' \<le> 16 length ps"
	+ by simp
	+ have "t_combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps =
	+ t_filter ?P ps + t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps'"
	+ using defs by (auto split: prod.splits)
	+ also have "... = length ps + t_find_closest_pair (c\<^sub>0, c\<^sub>1) ps'"
	+ using t_filter by auto
	+ finally show ?thesis
	+ using * by simp
	+qed
	+
	+declare t_combine.simps [simp del]
	+
	+subsubsection "Divide and Conquer Algorithm"
	+
	+function t_closest_pair_rec :: "point list \<Rightarrow> nat" where
	+ "t_closest_pair_rec xs = (
	+ let n = length xs in
	+ t_length xs + (
	+ if n \<le> 3 then
	+ t_mergesort snd xs + t_closest_pair_bf xs
	+ else
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ t_split_at (n div 2) xs + (
	+
	+ let (ys\<^sub>L, p\<^sub>L) = closest_pair_rec xs\<^sub>L in
	+ t_closest_pair_rec xs\<^sub>L + (
	+ let (ys\<^sub>R, p\<^sub>R) = closest_pair_rec xs\<^sub>R in
	+ t_closest_pair_rec xs\<^sub>R + (
	+
	+ let ys = merge (\<lambda>p. snd p) ys\<^sub>L ys\<^sub>R in
	+ t_merge (\<lambda>p. snd p) (ys\<^sub>L, ys\<^sub>R) + t_combine p\<^sub>L p\<^sub>R (fst (hd xs\<^sub>R)) ys
	+ ))))
	+ )"
	+ by pat_completeness auto
	+termination t_closest_pair_rec
	+ apply (relation "Wellfounded.measure (\<lambda>xs. length xs)")
	+ apply (auto simp: split_at_take_drop_conv Let_def)
	+ done
	+
	+lemma t_closest_pair_rec_simps_1:
	+ assumes "n = length xs" "n \<le> 3"
	+ shows "t_closest_pair_rec xs = t_length xs + t_mergesort snd xs + t_closest_pair_bf xs"
	+ using assms by simp
	+
	+lemma t_closest_pair_rec_simps_2:
	+ assumes "n = length xs" "\<not> (n \<le> 3)"
	+ shows "t_closest_pair_rec xs = (
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ let t_s = t_split_at (n div 2) xs in
	+ let l = fst (hd xs\<^sub>R) in
	+ let (ys\<^sub>L, p\<^sub>L) = closest_pair_rec xs\<^sub>L in
	+ let (ys\<^sub>R, p\<^sub>R) = closest_pair_rec xs\<^sub>R in
	+ let t_cl = t_closest_pair_rec xs\<^sub>L in
	+ let t_cr = t_closest_pair_rec xs\<^sub>R in
	+ let ys = merge (\<lambda>p. snd p) ys\<^sub>L ys\<^sub>R in
	+ let t_m = t_merge (\<lambda>p. snd p) (ys\<^sub>L, ys\<^sub>R) in
	+ let t_c = t_combine p\<^sub>L p\<^sub>R l ys in
	+ t_length xs + t_s + t_cl + t_cr + t_m + t_c
	+ )"
	+ using assms by (auto simp add: Let_def split!: if_splits prod.splits)
	+
	+declare t_closest_pair_rec.simps [simp del]
	+
	+function closest_pair_rec_recurrence :: "nat \<Rightarrow> real" where
	+ "n \<le> 3 \<Longrightarrow> closest_pair_rec_recurrence n = n + mergesort_recurrence n + n * n"
	+\| "3 < n \<Longrightarrow> closest_pair_rec_recurrence n = closest_pair_rec_recurrence (nat \<lfloor>real n / 2\<rfloor>) +
	+ closest_pair_rec_recurrence (nat \<lceil>real n / 2\<rceil>) + 20 * n"
	+ by force simp_all
	+termination by akra_bazzi_termination simp_all
	+
	+lemma closest_pair_rec_recurrence_nonneg[simp]:
	+ "0 \<le> closest_pair_rec_recurrence n"
	+ by (induction n rule: closest_pair_rec_recurrence.induct) auto
	+
	+lemma t_closest_pair_rec_conv_closest_pair_rec_recurrence:
	+ "t_closest_pair_rec ps \<le> closest_pair_rec_recurrence (length ps)"
	+proof (induction ps rule: length_induct)
	+ case (1 ps)
	+ let ?n = "length ps"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "t_closest_pair_rec ps = t_length ps + t_mergesort snd ps + t_closest_pair_bf ps"
	+ using t_closest_pair_rec_simps_1 by simp
	+ moreover have "closest_pair_rec_recurrence ?n = ?n + mergesort_recurrence ?n + ?n * ?n"
	+ using True by simp
	+ moreover have "t_length ps \<le> ?n" "t_mergesort snd ps \<le> mergesort_recurrence ?n" "t_closest_pair_bf ps \<le> ?n * ?n"
	+ using t_length[of ps] t_mergesort_conv_mergesort_recurrence[of snd ps] t_closest_pair_bf[of ps] by auto
	+ ultimately show ?thesis
	+ by linarith
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) ps"
	+ using prod.collapse by blast
	+ define TS where "TS = t_split_at (?n div 2) ps"
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L where CP\<^sub>L_def: "(YS\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ using prod.collapse by metis
	+ define TL where "TL = t_closest_pair_rec XS\<^sub>L"
	+ obtain YS\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R where CP\<^sub>R_def: "(YS\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ using prod.collapse by metis
	+ define TR where "TR = t_closest_pair_rec XS\<^sub>R"
	+
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ define TM where "TM = t_merge (\<lambda>p. snd p) (YS\<^sub>L, YS\<^sub>R)"
	+ define TC where "TC = t_combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ obtain C\<^sub>0 C\<^sub>1 where C\<^sub>0\<^sub>1_def: "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ using prod.collapse by metis
	+ note defs = XS_def TS_def L_def CP\<^sub>L_def TL_def CP\<^sub>R_def TR_def YS_def TM_def TC_def
	+
	+ have FL: "t_closest_pair_rec ps = t_length ps + TS + TL + TR + TM + TC"
	+ using False t_closest_pair_rec_simps_2 defs by (auto simp: Let_def split!: if_splits prod.splits)
	+ have FR: "closest_pair_rec_recurrence (length ps) = closest_pair_rec_recurrence (nat \<lfloor>real ?n / 2\<rfloor>) +
	+ closest_pair_rec_recurrence (nat \<lceil>real ?n / 2\<rceil>) + 20 * ?n"
	+ using False by simp
	+
	+ have XSLR: "XS\<^sub>L = take (?n div 2) ps" "XS\<^sub>R = drop (?n div 2) ps"
	+ using defs by (auto simp: split_at_take_drop_conv)
	+ hence "length XS\<^sub>L = ?n div 2" "length XS\<^sub>R = ?n - ?n div 2"
	+ by simp_all
	+ hence *: "(nat \<lfloor>real ?n / 2\<rfloor>) = length XS\<^sub>L" "(nat \<lceil>real ?n / 2\<rceil>) = length XS\<^sub>R"
	+ by linarith+
	+ have "length XS\<^sub>L = length YS\<^sub>L" "length XS\<^sub>R = length YS\<^sub>R"
	+ using defs closest_pair_rec_set_length_sorted_snd by metis+
	+ hence L: "?n = length YS\<^sub>L + length YS\<^sub>R"
	+ using defs XSLR by fastforce
	+
	+ have "length XS\<^sub>L < length ps"
	+ using False XSLR by simp_all
	+ hence "t_closest_pair_rec XS\<^sub>L \<le> closest_pair_rec_recurrence (length XS\<^sub>L)"
	+ using "1.IH" by simp
	+ hence IHL: "t_closest_pair_rec XS\<^sub>L \<le> closest_pair_rec_recurrence (nat \<lfloor>real ?n / 2\<rfloor>)"
	+ using * by simp
	+
	+ have "length XS\<^sub>R < length ps"
	+ using False XSLR by simp_all
	+ hence "t_closest_pair_rec XS\<^sub>R \<le> closest_pair_rec_recurrence (length XS\<^sub>R)"
	+ using "1.IH" by simp
	+ hence IHR: "t_closest_pair_rec XS\<^sub>R \<le> closest_pair_rec_recurrence (nat \<lceil>real ?n / 2\<rceil>)"
	+ using * by simp
	+
	+ have "(YS, C\<^sub>0, C\<^sub>1) = closest_pair_rec ps"
	+ using False closest_pair_rec_simps defs C\<^sub>0\<^sub>1_def by (auto simp: Let_def split: prod.split)
	+ hence "length ps = length YS"
	+ using "1.prems" closest_pair_rec_set_length_sorted_snd by auto
	+ hence "TC \<le> 17 * ?n"
	+ using t_combine TC_def by simp
	+ moreover have "t_length ps = ?n"
	+ using t_length by blast
	+ moreover have "TS \<le> ?n"
	+ using t_split_at TS_def by blast
	+ moreover have "TL \<le> closest_pair_rec_recurrence (nat \<lfloor>real ?n / 2\<rfloor>)"
	+ using IHL TL_def by blast
	+ moreover have "TR \<le> closest_pair_rec_recurrence (nat \<lceil>real ?n / 2\<rceil>)"
	+ using IHR TR_def by blast
	+ moreover have "TM \<le> ?n"
	+ using L t_merge TM_def by auto
	+ ultimately show ?thesis
	+ using FL FR by linarith
	+ qed
	+qed
	+
	+theorem closest_pair_rec_recurrence:
	+ "closest_pair_rec_recurrence \<in> \<Theta>(\<lambda>n. n * ln n)"
	+ by (master_theorem) auto
	+
	+theorem t_closest_pair_rec_bigo:
	+ "t_closest_pair_rec \<in> O[length going_to at_top]((\<lambda>n. n * ln n) o length)"
	+proof -
	+ have 0: "\<And>ps. t_closest_pair_rec ps \<le> (closest_pair_rec_recurrence o length) ps"
	+ unfolding comp_def using t_closest_pair_rec_conv_closest_pair_rec_recurrence by auto
	+ show ?thesis
	+ using bigo_measure_trans[OF 0] bigthetaD1[OF closest_pair_rec_recurrence] of_nat_0_le_iff by blast
	+qed
	+
	+definition t_closest_pair :: "point list \<Rightarrow> nat" where
	+ "t_closest_pair ps = t_mergesort fst ps + t_closest_pair_rec (mergesort fst ps)"
	+
	+definition closest_pair_time :: "nat \<Rightarrow> real" where
	+ "closest_pair_time n = mergesort_recurrence n + closest_pair_rec_recurrence n"
	+
	+lemma t_closest_pair_conv_closest_pair_recurrence:
	+ "t_closest_pair ps \<le> closest_pair_time (length ps)"
	+ unfolding t_closest_pair_def closest_pair_time_def
	+ using t_closest_pair_rec_conv_closest_pair_rec_recurrence[of "mergesort fst ps"] t_mergesort_conv_mergesort_recurrence[of fst ps]
	+ by (simp add: mergesort sorted_fst_def)
	+
	+corollary closest_pair_recurrence:
	+ "closest_pair_time \<in> O(\<lambda>n. n * ln n)"
	+ unfolding closest_pair_time_def using mergesort_recurrence closest_pair_rec_recurrence sum_in_bigo(1) by blast
	+
	+corollary t_closest_pair_bigo:
	+ "t_closest_pair \<in> O[length going_to at_top]((\<lambda>n. n * ln n) o length)"
	+proof -
	+ have 0: "\<And>ps. t_closest_pair ps \<le> (closest_pair_time o length) ps"
	+ unfolding comp_def using t_closest_pair_conv_closest_pair_recurrence by auto
	+ show ?thesis
	+ using bigo_measure_trans[OF 0] closest_pair_recurrence by fastforce
	+qed
	+
	+
	+subsection "Code Export"
	+
	+subsubsection "Combine Step"
	+
	+fun find_closest_pair_code :: "(int * point * point) \<Rightarrow> point list \<Rightarrow> (int * point * point)" where
	+ "find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) [] = (\<delta>, c\<^sub>0, c\<^sub>1)"
	+\| "find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) [p] = (\<delta>, c\<^sub>0, c\<^sub>1)"
	+\| "find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) (p\<^sub>0 # ps) = (
	+ let (\<delta>', p\<^sub>1) = find_closest_bf_code p\<^sub>0 (take 7 ps) in
	+ if \<delta> \<le> \<delta>' then
	+ find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) ps
	+ else
	+ find_closest_pair_code (\<delta>', p\<^sub>0, p\<^sub>1) ps
	+ )"
	+
	+lemma find_closest_pair_code_dist_eq:
	+ assumes "\<delta> = dist_code c\<^sub>0 c\<^sub>1" "(\<Delta>, C\<^sub>0, C\<^sub>1) = find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) ps"
	+ shows "\<Delta> = dist_code C\<^sub>0 C\<^sub>1"
	+ using assms
	+proof (induction "(\<delta>, c\<^sub>0, c\<^sub>1)" ps arbitrary: \<delta> c\<^sub>0 c\<^sub>1 \<Delta> C\<^sub>0 C\<^sub>1 rule: find_closest_pair_code.induct)
	+ case (3 \<delta> c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ obtain \<delta>' p\<^sub>1 where \<delta>'_def: "(\<delta>', p\<^sub>1) = find_closest_bf_code p\<^sub>0 (take 7 (p\<^sub>2 # ps))"
	+ by (metis surj_pair)
	+ hence A: "\<delta>' = dist_code p\<^sub>0 p\<^sub>1"
	+ using find_closest_bf_code_dist_eq[of "take 7 (p\<^sub>2 # ps)"] by simp
	+ show ?case
	+ proof (cases "\<delta> \<le> \<delta>'")
	+ case True
	+ obtain \<Delta>' C\<^sub>0' C\<^sub>1' where \<Delta>'_def: "(\<Delta>', C\<^sub>0', C\<^sub>1') = find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ by (metis prod_cases4)
	+ note defs = \<delta>'_def \<Delta>'_def
	+ hence "\<Delta>' = dist_code C\<^sub>0' C\<^sub>1'"
	+ using "3.hyps"(1)[of "(\<delta>', p\<^sub>1)" \<delta>' p\<^sub>1] "3.prems"(1) True \<delta>'_def by blast
	+ moreover have "\<Delta> = \<Delta>'" "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs True "3.prems"(2) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ next
	+ case False
	+ obtain \<Delta>' C\<^sub>0' C\<^sub>1' where \<Delta>'_def: "(\<Delta>', C\<^sub>0', C\<^sub>1') = find_closest_pair_code (\<delta>', p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ by (metis prod_cases4)
	+ note defs = \<delta>'_def \<Delta>'_def
	+ hence "\<Delta>' = dist_code C\<^sub>0' C\<^sub>1'"
	+ using "3.hyps"(2)[of "(\<delta>', p\<^sub>1)" \<delta>' p\<^sub>1] A False \<delta>'_def by blast
	+ moreover have "\<Delta> = \<Delta>'" "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using defs False "3.prems"(2) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+qed auto
	+
	+declare find_closest_pair.simps [simp add]
	+
	+lemma find_closest_pair_code_eq:
	+ assumes "\<delta> = dist c\<^sub>0 c\<^sub>1" "\<delta>' = dist_code c\<^sub>0 c\<^sub>1"
	+ assumes "(C\<^sub>0, C\<^sub>1) = find_closest_pair (c\<^sub>0, c\<^sub>1) ps"
	+ assumes "(\<Delta>', C\<^sub>0', C\<^sub>1') = find_closest_pair_code (\<delta>', c\<^sub>0, c\<^sub>1) ps"
	+ shows "C\<^sub>0 = C\<^sub>0' \<and> C\<^sub>1 = C\<^sub>1'"
	+ using assms
	+proof (induction "(c\<^sub>0, c\<^sub>1)" ps arbitrary: \<delta> \<delta>' c\<^sub>0 c\<^sub>1 C\<^sub>0 C\<^sub>1 \<Delta>' C\<^sub>0' C\<^sub>1' rule: find_closest_pair.induct)
	+ case (3 c\<^sub>0 c\<^sub>1 p\<^sub>0 p\<^sub>2 ps)
	+ obtain p\<^sub>1 \<delta>\<^sub>p' p\<^sub>1' where \<delta>\<^sub>p_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 (take 7 (p\<^sub>2 # ps))"
	+ "(\<delta>\<^sub>p', p\<^sub>1') = find_closest_bf_code p\<^sub>0 (take 7 (p\<^sub>2 # ps))"
	+ by (metis surj_pair)
	+ hence A: "\<delta>\<^sub>p' = dist_code p\<^sub>0 p\<^sub>1'"
	+ using find_closest_bf_code_dist_eq[of "take 7 (p\<^sub>2 # ps)"] by simp
	+ have B: "p\<^sub>1 = p\<^sub>1'"
	+ using "3.prems"(1,2,3) \<delta>\<^sub>p_def find_closest_bf_code_eq by auto
	+ show ?case
	+ proof (cases "\<delta> \<le> dist p\<^sub>0 p\<^sub>1")
	+ case True
	+ hence C: "\<delta>' \<le> \<delta>\<^sub>p'"
	+ by (simp add: "3.prems"(1,2) A B dist_eq_dist_code_le)
	+ obtain C\<^sub>0\<^sub>i C\<^sub>1\<^sub>i \<Delta>\<^sub>i' C\<^sub>0\<^sub>i' C\<^sub>1\<^sub>i' where \<Delta>\<^sub>i_def:
	+ "(C\<^sub>0\<^sub>i, C\<^sub>1\<^sub>i) = find_closest_pair (c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ "(\<Delta>\<^sub>i', C\<^sub>0\<^sub>i', C\<^sub>1\<^sub>i') = find_closest_pair_code (\<delta>', c\<^sub>0, c\<^sub>1) (p\<^sub>2 # ps)"
	+ by (metis prod_cases3)
	+ note defs = \<delta>\<^sub>p_def \<Delta>\<^sub>i_def
	+ have "C\<^sub>0\<^sub>i = C\<^sub>0\<^sub>i' \<and> C\<^sub>1\<^sub>i = C\<^sub>1\<^sub>i'"
	+ using "3.hyps"(1)[of p\<^sub>1] "3.prems" True defs by blast
	+ moreover have "C\<^sub>0 = C\<^sub>0\<^sub>i" "C\<^sub>1 = C\<^sub>1\<^sub>i"
	+ using defs(1,3) True "3.prems"(1,3) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ moreover have "\<Delta>' = \<Delta>\<^sub>i'" "C\<^sub>0' = C\<^sub>0\<^sub>i'" "C\<^sub>1' = C\<^sub>1\<^sub>i'"
	+ using defs(2,4) C "3.prems"(4) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ next
	+ case False
	+ hence C: "\<not> \<delta>' \<le> \<delta>\<^sub>p'"
	+ by (simp add: "3.prems"(1,2) A B dist_eq_dist_code_le)
	+ obtain C\<^sub>0\<^sub>i C\<^sub>1\<^sub>i \<Delta>\<^sub>i' C\<^sub>0\<^sub>i' C\<^sub>1\<^sub>i' where \<Delta>\<^sub>i_def:
	+ "(C\<^sub>0\<^sub>i, C\<^sub>1\<^sub>i) = find_closest_pair (p\<^sub>0, p\<^sub>1) (p\<^sub>2 # ps)"
	+ "(\<Delta>\<^sub>i', C\<^sub>0\<^sub>i', C\<^sub>1\<^sub>i') = find_closest_pair_code (\<delta>\<^sub>p', p\<^sub>0, p\<^sub>1') (p\<^sub>2 # ps)"
	+ by (metis prod_cases3)
	+ note defs = \<delta>\<^sub>p_def \<Delta>\<^sub>i_def
	+ have "C\<^sub>0\<^sub>i = C\<^sub>0\<^sub>i' \<and> C\<^sub>1\<^sub>i = C\<^sub>1\<^sub>i'"
	+ using "3.prems" "3.hyps"(2)[of p\<^sub>1] A B False defs by blast
	+ moreover have "C\<^sub>0 = C\<^sub>0\<^sub>i" "C\<^sub>1 = C\<^sub>1\<^sub>i"
	+ using defs(1,3) False "3.prems"(1,3) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ moreover have "\<Delta>' = \<Delta>\<^sub>i'" "C\<^sub>0' = C\<^sub>0\<^sub>i'" "C\<^sub>1' = C\<^sub>1\<^sub>i'"
	+ using defs(2,4) C "3.prems"(4) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ ultimately show ?thesis
	+ by simp
	+ qed
	+qed auto
	+
	+fun combine_code :: "(int * point * point) \<Rightarrow> (int * point * point) \<Rightarrow> int \<Rightarrow> point list \<Rightarrow> (int * point * point)" where
	+ "combine_code (\<delta>\<^sub>L, p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (\<delta>\<^sub>R, p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps = (
	+ let (\<delta>, c\<^sub>0, c\<^sub>1) = if \<delta>\<^sub>L < \<delta>\<^sub>R then (\<delta>\<^sub>L, p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (\<delta>\<^sub>R, p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) in
	+ let ps' = filter (\<lambda>p. (fst p - l)\<^sup>2 < \<delta>) ps in
	+ find_closest_pair_code (\<delta>, c\<^sub>0, c\<^sub>1) ps'
	+ )"
	+
	+lemma combine_code_dist_eq:
	+ assumes "\<delta>\<^sub>L = dist_code p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L" "\<delta>\<^sub>R = dist_code p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R"
	+ assumes "(\<delta>, c\<^sub>0, c\<^sub>1) = combine_code (\<delta>\<^sub>L, p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (\<delta>\<^sub>R, p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ shows "\<delta> = dist_code c\<^sub>0 c\<^sub>1"
	+ using assms by (auto simp: find_closest_pair_code_dist_eq split: if_splits)
	+
	+lemma combine_code_eq:
	+ assumes "\<delta>\<^sub>L' = dist_code p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L" "\<delta>\<^sub>R' = dist_code p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R"
	+ assumes "(c\<^sub>0, c\<^sub>1) = combine (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ assumes "(\<delta>', c\<^sub>0', c\<^sub>1') = combine_code (\<delta>\<^sub>L', p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) (\<delta>\<^sub>R', p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R) l ps"
	+ shows "c\<^sub>0 = c\<^sub>0' \<and> c\<^sub>1 = c\<^sub>1'"
	+proof -
	+ obtain C\<^sub>0\<^sub>i C\<^sub>1\<^sub>i \<Delta>\<^sub>i' C\<^sub>0\<^sub>i' C\<^sub>1\<^sub>i' where \<Delta>\<^sub>i_def:
	+ "(C\<^sub>0\<^sub>i, C\<^sub>1\<^sub>i) = (if dist p\<^sub>0\<^sub>L p\<^sub>1\<^sub>L < dist p\<^sub>0\<^sub>R p\<^sub>1\<^sub>R then (p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))"
	+ "(\<Delta>\<^sub>i', C\<^sub>0\<^sub>i', C\<^sub>1\<^sub>i') = (if \<delta>\<^sub>L' < \<delta>\<^sub>R' then (\<delta>\<^sub>L', p\<^sub>0\<^sub>L, p\<^sub>1\<^sub>L) else (\<delta>\<^sub>R', p\<^sub>0\<^sub>R, p\<^sub>1\<^sub>R))"
	+ by metis
	+ define ps' ps'' where ps'_def:
	+ "ps' = filter (\<lambda>p. dist p (l, snd p) < dist C\<^sub>0\<^sub>i C\<^sub>1\<^sub>i) ps"
	+ "ps'' = filter (\<lambda>p. (fst p - l)\<^sup>2 < \<Delta>\<^sub>i') ps"
	+ obtain C\<^sub>0 C\<^sub>1 \<Delta>' C\<^sub>0' C\<^sub>1' where \<Delta>_def:
	+ "(C\<^sub>0, C\<^sub>1) = find_closest_pair (C\<^sub>0\<^sub>i, C\<^sub>1\<^sub>i) ps'"
	+ "(\<Delta>', C\<^sub>0', C\<^sub>1') = find_closest_pair_code (\<Delta>\<^sub>i', C\<^sub>0\<^sub>i', C\<^sub>1\<^sub>i') ps''"
	+ by (metis prod_cases3)
	+ note defs = \<Delta>\<^sub>i_def ps'_def \<Delta>_def
	+ have *: "C\<^sub>0\<^sub>i = C\<^sub>0\<^sub>i'" "C\<^sub>1\<^sub>i = C\<^sub>1\<^sub>i'" "\<Delta>\<^sub>i' = dist_code C\<^sub>0\<^sub>i' C\<^sub>1\<^sub>i'"
	+ using \<Delta>\<^sub>i_def assms(1,2,3,4) dist_eq_dist_code_lt by (auto split: if_splits)
	+ hence "\<And>p. \<bar>fst p - l\<bar> < dist C\<^sub>0\<^sub>i C\<^sub>1\<^sub>i \<longleftrightarrow> (fst p - l)\<^sup>2 < \<Delta>\<^sub>i'"
	+ using dist_eq_dist_code_abs_lt by (metis (mono_tags) of_int_abs)
	+ hence "ps' = ps''"
	+ using ps'_def dist_fst_abs by auto
	+ hence "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using * find_closest_pair_code_eq \<Delta>_def by blast+
	+ moreover have "C\<^sub>0 = c\<^sub>0" "C\<^sub>1 = c\<^sub>1"
	+ using assms(3) defs(1,3,5) apply (auto split: prod.splits) by (metis Pair_inject)+
	+ moreover have "C\<^sub>0' = c\<^sub>0'" "C\<^sub>1' = c\<^sub>1'"
	+ using assms(4) defs(2,4,6) apply (auto split: prod.splits) by (metis prod.inject)+
	+ ultimately show ?thesis
	+ by blast
	+qed
	+
	+subsubsection "Divide and Conquer Algorithm"
	+
	+function closest_pair_rec_code :: "point list \<Rightarrow> (point list * int * point * point)" where
	+ "closest_pair_rec_code xs = (
	+ let n = length xs in
	+ if n \<le> 3 then
	+ (mergesort snd xs, closest_pair_bf_code xs)
	+ else
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ let l = fst (hd xs\<^sub>R) in
	+
	+ let (ys\<^sub>L, p\<^sub>L) = closest_pair_rec_code xs\<^sub>L in
	+ let (ys\<^sub>R, p\<^sub>R) = closest_pair_rec_code xs\<^sub>R in
	+
	+ let ys = merge snd ys\<^sub>L ys\<^sub>R in
	+ (ys, combine_code p\<^sub>L p\<^sub>R l ys)
	+ )"
	+ by pat_completeness auto
	+termination closest_pair_rec_code
	+ apply (relation "Wellfounded.measure (\<lambda>xs. length xs)")
	+ apply (auto simp: split_at_take_drop_conv Let_def)
	+ done
	+
	+lemma closest_pair_rec_code_simps:
	+ assumes "n = length xs" "\<not> (n \<le> 3)"
	+ shows "closest_pair_rec_code xs = (
	+ let (xs\<^sub>L, xs\<^sub>R) = split_at (n div 2) xs in
	+ let l = fst (hd xs\<^sub>R) in
	+ let (ys\<^sub>L, p\<^sub>L) = closest_pair_rec_code xs\<^sub>L in
	+ let (ys\<^sub>R, p\<^sub>R) = closest_pair_rec_code xs\<^sub>R in
	+ let ys = merge snd ys\<^sub>L ys\<^sub>R in
	+ (ys, combine_code p\<^sub>L p\<^sub>R l ys)
	+ )"
	+ using assms by (auto simp: Let_def)
	+
	+declare combine.simps combine_code.simps closest_pair_rec_code.simps [simp del]
	+
	+lemma closest_pair_rec_code_dist_eq:
	+ assumes "1 < length xs" "(ys, \<delta>, c\<^sub>0, c\<^sub>1) = closest_pair_rec_code xs"
	+ shows "\<delta> = dist_code c\<^sub>0 c\<^sub>1"
	+ using assms
	+proof (induction xs arbitrary: ys \<delta> c\<^sub>0 c\<^sub>1 rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "(\<delta>, c\<^sub>0, c\<^sub>1) = closest_pair_bf_code xs"
	+ using "1.prems"(2) closest_pair_rec_code.simps by simp
	+ thus ?thesis
	+ using "1.prems"(1) closest_pair_bf_code_dist_eq by simp
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L \<Delta>\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L where YSC\<^sub>0\<^sub>1\<^sub>L_def: "(YS\<^sub>L, \<Delta>\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec_code XS\<^sub>L"
	+ using prod.collapse by metis
	+ obtain YS\<^sub>R \<Delta>\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R where YSC\<^sub>0\<^sub>1\<^sub>R_def: "(YS\<^sub>R, \<Delta>\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec_code XS\<^sub>R"
	+ using prod.collapse by metis
	+
	+ define YS where "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ obtain \<Delta> C\<^sub>0 C\<^sub>1 where C\<^sub>0\<^sub>1_def: "(\<Delta>, C\<^sub>0, C\<^sub>1) = combine_code (\<Delta>\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (\<Delta>\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ using prod.collapse by metis
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSC\<^sub>0\<^sub>1\<^sub>L_def YSC\<^sub>0\<^sub>1\<^sub>R_def YS_def C\<^sub>0\<^sub>1_def
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHL: "\<Delta>\<^sub>L = dist_code C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L"
	+ using "1.IH" defs by metis+
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHR: "\<Delta>\<^sub>R = dist_code C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R"
	+ using "1.IH" defs by metis+
	+
	+ have *: "(YS, \<Delta>, C\<^sub>0, C\<^sub>1) = closest_pair_rec_code xs"
	+ using False closest_pair_rec_code_simps defs by (auto simp: Let_def split: prod.split)
	+ moreover have "\<Delta> = dist_code C\<^sub>0 C\<^sub>1"
	+ using combine_code_dist_eq IHL IHR C\<^sub>0\<^sub>1_def by blast
	+ ultimately show ?thesis
	+ using "1.prems"(2) * by (metis Pair_inject)
	+ qed
	+qed
	+
	+lemma closest_pair_rec_ys_eq:
	+ assumes "1 < length xs"
	+ assumes "(ys, c\<^sub>0, c\<^sub>1) = closest_pair_rec xs"
	+ assumes "(ys', \<delta>', c\<^sub>0', c\<^sub>1') = closest_pair_rec_code xs"
	+ shows "ys = ys'"
	+ using assms
	+proof (induction xs arbitrary: ys c\<^sub>0 c\<^sub>1 ys' \<delta>' c\<^sub>0' c\<^sub>1' rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "ys = mergesort snd xs"
	+ using "1.prems"(2) closest_pair_rec.simps by simp
	+ moreover have "ys' = mergesort snd xs"
	+ using "1.prems"(3) closest_pair_rec_code.simps by (simp add: True)
	+ ultimately show ?thesis
	+ using "1.prems"(1) by simp
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L YS\<^sub>L' \<Delta>\<^sub>L' C\<^sub>0\<^sub>L' C\<^sub>1\<^sub>L' where YSC\<^sub>0\<^sub>1\<^sub>L_def:
	+ "(YS\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ "(YS\<^sub>L', \<Delta>\<^sub>L', C\<^sub>0\<^sub>L', C\<^sub>1\<^sub>L') = closest_pair_rec_code XS\<^sub>L"
	+ using prod.collapse by metis
	+ obtain YS\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R YS\<^sub>R' \<Delta>\<^sub>R' C\<^sub>0\<^sub>R' C\<^sub>1\<^sub>R' where YSC\<^sub>0\<^sub>1\<^sub>R_def:
	+ "(YS\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ "(YS\<^sub>R', \<Delta>\<^sub>R', C\<^sub>0\<^sub>R', C\<^sub>1\<^sub>R') = closest_pair_rec_code XS\<^sub>R"
	+ using prod.collapse by metis
	+
	+ define YS YS' where YS_def:
	+ "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ "YS' = merge (\<lambda>p. snd p) YS\<^sub>L' YS\<^sub>R'"
	+ obtain C\<^sub>0 C\<^sub>1 \<Delta>' C\<^sub>0' C\<^sub>1' where C\<^sub>0\<^sub>1_def:
	+ "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ "(\<Delta>', C\<^sub>0', C\<^sub>1') = combine_code (\<Delta>\<^sub>L', C\<^sub>0\<^sub>L', C\<^sub>1\<^sub>L') (\<Delta>\<^sub>R', C\<^sub>0\<^sub>R', C\<^sub>1\<^sub>R') L YS'"
	+ using prod.collapse by metis
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSC\<^sub>0\<^sub>1\<^sub>L_def YSC\<^sub>0\<^sub>1\<^sub>R_def YS_def C\<^sub>0\<^sub>1_def
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHL: "YS\<^sub>L = YS\<^sub>L'"
	+ using "1.IH" defs by metis
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHR: "YS\<^sub>R = YS\<^sub>R'"
	+ using "1.IH" defs by metis
	+
	+ have "(YS, C\<^sub>0, C\<^sub>1) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs(1,2,3,5,7,9)
	+ by (auto simp: Let_def split: prod.split)
	+ moreover have "(YS', \<Delta>', C\<^sub>0', C\<^sub>1') = closest_pair_rec_code xs"
	+ using False closest_pair_rec_code_simps defs(1,2,4,6,8,10)
	+ by (auto simp: Let_def split: prod.split)
	+ moreover have "YS = YS'"
	+ using IHL IHR YS_def by simp
	+ ultimately show ?thesis
	+ by (metis "1.prems"(2,3) Pair_inject)
	+ qed
	+qed
	+
	+lemma closest_pair_rec_code_eq:
	+ assumes "1 < length xs"
	+ assumes "(ys, c\<^sub>0, c\<^sub>1) = closest_pair_rec xs"
	+ assumes "(ys', \<delta>', c\<^sub>0', c\<^sub>1') = closest_pair_rec_code xs"
	+ shows "c\<^sub>0 = c\<^sub>0' \<and> c\<^sub>1 = c\<^sub>1'"
	+ using assms
	+proof (induction xs arbitrary: ys c\<^sub>0 c\<^sub>1 ys' \<delta>' c\<^sub>0' c\<^sub>1' rule: length_induct)
	+ case (1 xs)
	+ let ?n = "length xs"
	+ show ?case
	+ proof (cases "?n \<le> 3")
	+ case True
	+ hence "(c\<^sub>0, c\<^sub>1) = closest_pair_bf xs"
	+ using "1.prems"(2) closest_pair_rec.simps by simp
	+ moreover have "(\<delta>', c\<^sub>0', c\<^sub>1') = closest_pair_bf_code xs"
	+ using "1.prems"(3) closest_pair_rec_code.simps by (simp add: True)
	+ ultimately show ?thesis
	+ using "1.prems"(1) closest_pair_bf_code_eq by simp
	+ next
	+ case False
	+
	+ obtain XS\<^sub>L XS\<^sub>R where XS\<^sub>L\<^sub>R_def: "(XS\<^sub>L, XS\<^sub>R) = split_at (?n div 2) xs"
	+ using prod.collapse by blast
	+ define L where "L = fst (hd XS\<^sub>R)"
	+
	+ obtain YS\<^sub>L C\<^sub>0\<^sub>L C\<^sub>1\<^sub>L YS\<^sub>L' \<Delta>\<^sub>L' C\<^sub>0\<^sub>L' C\<^sub>1\<^sub>L' where YSC\<^sub>0\<^sub>1\<^sub>L_def:
	+ "(YS\<^sub>L, C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) = closest_pair_rec XS\<^sub>L"
	+ "(YS\<^sub>L', \<Delta>\<^sub>L', C\<^sub>0\<^sub>L', C\<^sub>1\<^sub>L') = closest_pair_rec_code XS\<^sub>L"
	+ using prod.collapse by metis
	+ obtain YS\<^sub>R C\<^sub>0\<^sub>R C\<^sub>1\<^sub>R YS\<^sub>R' \<Delta>\<^sub>R' C\<^sub>0\<^sub>R' C\<^sub>1\<^sub>R' where YSC\<^sub>0\<^sub>1\<^sub>R_def:
	+ "(YS\<^sub>R, C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) = closest_pair_rec XS\<^sub>R"
	+ "(YS\<^sub>R', \<Delta>\<^sub>R', C\<^sub>0\<^sub>R', C\<^sub>1\<^sub>R') = closest_pair_rec_code XS\<^sub>R"
	+ using prod.collapse by metis
	+
	+ define YS YS' where YS_def:
	+ "YS = merge (\<lambda>p. snd p) YS\<^sub>L YS\<^sub>R"
	+ "YS' = merge (\<lambda>p. snd p) YS\<^sub>L' YS\<^sub>R'"
	+ obtain C\<^sub>0 C\<^sub>1 \<Delta>' C\<^sub>0' C\<^sub>1' where C\<^sub>0\<^sub>1_def:
	+ "(C\<^sub>0, C\<^sub>1) = combine (C\<^sub>0\<^sub>L, C\<^sub>1\<^sub>L) (C\<^sub>0\<^sub>R, C\<^sub>1\<^sub>R) L YS"
	+ "(\<Delta>', C\<^sub>0', C\<^sub>1') = combine_code (\<Delta>\<^sub>L', C\<^sub>0\<^sub>L', C\<^sub>1\<^sub>L') (\<Delta>\<^sub>R', C\<^sub>0\<^sub>R', C\<^sub>1\<^sub>R') L YS'"
	+ using prod.collapse by metis
	+ note defs = XS\<^sub>L\<^sub>R_def L_def YSC\<^sub>0\<^sub>1\<^sub>L_def YSC\<^sub>0\<^sub>1\<^sub>R_def YS_def C\<^sub>0\<^sub>1_def
	+
	+ have "1 < length XS\<^sub>L" "length XS\<^sub>L < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHL: "C\<^sub>0\<^sub>L = C\<^sub>0\<^sub>L'" "C\<^sub>1\<^sub>L = C\<^sub>1\<^sub>L'"
	+ using "1.IH" defs by metis+
	+
	+ have "1 < length XS\<^sub>R" "length XS\<^sub>R < length xs"
	+ using False "1.prems"(1) defs by (auto simp: split_at_take_drop_conv)
	+ hence IHR: "C\<^sub>0\<^sub>R = C\<^sub>0\<^sub>R'" "C\<^sub>1\<^sub>R = C\<^sub>1\<^sub>R'"
	+ using "1.IH" defs by metis+
	+
	+ have "YS = YS'"
	+ using defs \<open>1 < length XS\<^sub>L\<close> \<open>1 < length XS\<^sub>R\<close> closest_pair_rec_ys_eq by blast
	+ moreover have "\<Delta>\<^sub>L' = dist_code C\<^sub>0\<^sub>L' C\<^sub>1\<^sub>L'" "\<Delta>\<^sub>R' = dist_code C\<^sub>0\<^sub>R' C\<^sub>1\<^sub>R'"
	+ using defs \<open>1 < length XS\<^sub>L\<close> \<open>1 < length XS\<^sub>R\<close> closest_pair_rec_code_dist_eq by blast+
	+ ultimately have "C\<^sub>0 = C\<^sub>0'" "C\<^sub>1 = C\<^sub>1'"
	+ using combine_code_eq IHL IHR C\<^sub>0\<^sub>1_def by blast+
	+ moreover have "(YS, C\<^sub>0, C\<^sub>1) = closest_pair_rec xs"
	+ using False closest_pair_rec_simps defs(1,2,3,5,7,9)
	+ by (auto simp: Let_def split: prod.split)
	+ moreover have "(YS', \<Delta>', C\<^sub>0', C\<^sub>1') = closest_pair_rec_code xs"
	+ using False closest_pair_rec_code_simps defs(1,2,4,6,8,10)
	+ by (auto simp: Let_def split: prod.split)
	+ ultimately show ?thesis
	+ using "1.prems"(2,3) by (metis Pair_inject)
	+ qed
	+qed
	+
	+declare closest_pair.simps [simp add]
	+
	+fun closest_pair_code :: "point list \<Rightarrow> (point * point)" where
	+ "closest_pair_code [] = undefined"
	+\| "closest_pair_code [_] = undefined"
	+\| "closest_pair_code ps = (let (_, _, c\<^sub>0, c\<^sub>1) = closest_pair_rec_code (mergesort fst ps) in (c\<^sub>0, c\<^sub>1))"
	+
	+lemma closest_pair_code_eq:
	+ "closest_pair ps = closest_pair_code ps"
	+proof (induction ps rule: induct_list012)
	+ case (3 x y zs)
	+ obtain ys c\<^sub>0 c\<^sub>1 ys' \<delta>' c\<^sub>0' c\<^sub>1' where *:
	+ "(ys, c\<^sub>0, c\<^sub>1) = closest_pair_rec (mergesort fst (x # y # zs))"
	+ "(ys', \<delta>', c\<^sub>0', c\<^sub>1') = closest_pair_rec_code (mergesort fst (x # y # zs))"
	+ by (metis prod_cases3)
	+ moreover have "1 < length (mergesort fst (x # y # zs))"
	+ using length_mergesort[of fst "x # y # zs"] by simp
	+ ultimately have "c\<^sub>0 = c\<^sub>0'" "c\<^sub>1 = c\<^sub>1'"
	+ using closest_pair_rec_code_eq by blast+
	+ thus ?case
	+ using * by (auto split: prod.splits)
	+qed auto
	+
	+export_code closest_pair_code in OCaml
	+ module_name Verified
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Closest_Pair_Points/Common.thy b/thys/Closest_Pair_Points/Common.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Closest_Pair_Points/Common.thy
	@@ -0,0 +1,1121 @@
	+section "Common"
	+
	+theory Common
	+imports
	+ "HOL-Library.Going_To_Filter"
	+ "Akra_Bazzi.Akra_Bazzi_Method"
	+ "Akra_Bazzi.Akra_Bazzi_Approximation"
	+ "HOL-Library.Code_Target_Numeral"
	+begin
	+
	+type_synonym point = "int * int"
	+
	+subsection "Auxiliary Functions and Lemmas"
	+
	+subsubsection "Landau Auxiliary"
	+
	+text \<open>
	+ The following lemma expresses a procedure for deriving complexity properties of
	+ the form @{prop"t \<in> O[m going_to at_top within A](f o m)"} where
	+ \<^item> \<open>t\<close> is a (timing) function on same data domain (e.g. lists),
	+ \<^item> \<open>m\<close> is a measure function on that data domain (e.g. length),
	+ \<^item> \<open>t'\<close> is a function on @{typ nat},
	+ \<^item> \<open>A\<close> is the set of valid inputs for the data domain.
	+ One needs to show that
	+ \<^item> \<open>t\<close> is bounded by @{term "t' o m"} for valid inputs
	+ \<^item> @{prop"t' \<in> O(f)"}
	+ to conclude the overall property @{prop"t \<in> O[m going_to at_top within A](f o m)"}.
	+\<close>
	+
	+lemma bigo_measure_trans:
	+ fixes t :: "'a \<Rightarrow> real" and t' :: "nat \<Rightarrow> real" and m :: "'a \<Rightarrow> nat" and f ::"nat \<Rightarrow> real"
	+ assumes "\<And>x. x \<in> A \<Longrightarrow> t x \<le> (t' o m) x"
	+ and "t' \<in> O(f)"
	+ and "\<And>x. x \<in> A \<Longrightarrow> 0 \<le> t x"
	+ shows "t \<in> O[m going_to at_top within A](f o m)"
	+proof -
	+ have 0: "\<And>x. x \<in> A \<Longrightarrow> 0 \<le> (t' o m) x" by (meson assms(1,3) order_trans)
	+ have 1: "t \<in> O[m going_to at_top within A](t' o m)"
	+ apply(rule bigoI[where c=1]) using assms 0
	+ by (simp add: eventually_inf_principal going_to_within_def)
	+ have 2: "t' o m \<in> O[m going_to at_top](f o m)"
	+ unfolding o_def going_to_def
	+ by(rule landau_o.big.filtercomap[OF assms(2)])
	+ have 3: "t' o m \<in> O[m going_to at_top within A](f o m)"
	+ using landau_o.big.filter_mono[OF _2] going_to_mono[OF _subset_UNIV] by blast
	+ show ?thesis by(rule landau_o.big_trans[OF 1 3])
	+qed
	+
	+subsubsection "Miscellaneous Lemmas"
	+
	+lemma set_take_drop_i_le_j:
	+ "i \<le> j \<Longrightarrow> set xs = set (take j xs) \<union> set (drop i xs)"
	+proof (induction xs arbitrary: i j)
	+ case (Cons x xs)
	+ show ?case
	+ proof (cases "i = 0")
	+ case True
	+ thus ?thesis
	+ using set_take_subset by force
	+ next
	+ case False
	+ hence "set xs = set (take (j - 1) xs) \<union> set (drop (i - 1) xs)"
	+ by (simp add: Cons diff_le_mono)
	+ moreover have "set (take j (x # xs)) = insert x (set (take (j - 1) xs))"
	+ using False Cons.prems by (auto simp: take_Cons')
	+ moreover have "set (drop i (x # xs)) = set (drop (i - 1) xs)"
	+ using False Cons.prems by (auto simp: drop_Cons')
	+ ultimately show ?thesis
	+ by auto
	+ qed
	+qed simp
	+
	+lemma set_take_drop:
	+ "set xs = set (take n xs) \<union> set (drop n xs)"
	+ using set_take_drop_i_le_j by fast
	+
	+lemma
	+ assumes "sorted_wrt f xs"
	+ shows sorted_wrt_take: "sorted_wrt f (take n xs)"
	+ and sorted_wrt_drop: "sorted_wrt f (drop n xs)"
	+proof -
	+ from assms have "sorted_wrt f (take n xs @ drop n xs)" by simp
	+ then show "sorted_wrt f (take n xs)" and "sorted_wrt f (drop n xs)"
	+ unfolding sorted_wrt_append by simp_all
	+qed
	+
	+lemma sorted_wrt_filter:
	+ "sorted_wrt f xs \<Longrightarrow> sorted_wrt f (filter P xs)"
	+ by (induction xs) auto
	+
	+lemma sorted_wrt_take_drop:
	+ "sorted_wrt f xs \<Longrightarrow> \<forall>x \<in> set (take n xs). \<forall>y \<in> set (drop n xs). f x y"
	+ using sorted_wrt_append[of f "take n xs" "drop n xs"] by simp
	+
	+lemma sorted_wrt_hd_less:
	+ assumes "sorted_wrt f xs" "\<And>x. f x x"
	+ shows "\<forall>x \<in> set xs. f (hd xs) x"
	+ using assms by (cases xs) auto
	+
	+lemma sorted_wrt_hd_less_take:
	+ assumes "sorted_wrt f (x # xs)" "\<And>x. f x x"
	+ shows "\<forall>y \<in> set (take n (x # xs)). f x y"
	+ using assms sorted_wrt_hd_less in_set_takeD by fastforce
	+
	+lemma sorted_wrt_take_less_hd_drop:
	+ assumes "sorted_wrt f xs" "n < length xs"
	+ shows "\<forall>x \<in> set (take n xs). f x (hd (drop n xs))"
	+ using sorted_wrt_take_drop assms by fastforce
	+
	+lemma sorted_wrt_hd_drop_less_drop:
	+ assumes "sorted_wrt f xs" "\<And>x. f x x"
	+ shows "\<forall>x \<in> set (drop n xs). f (hd (drop n xs)) x"
	+ using assms sorted_wrt_drop sorted_wrt_hd_less by blast
	+
	+lemma length_filter_P_impl_Q:
	+ "(\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> length (filter P xs) \<le> length (filter Q xs)"
	+ by (induction xs) auto
	+
	+lemma filter_Un:
	+ "set xs = A \<union> B \<Longrightarrow> set (filter P xs) = { x \<in> A. P x } \<union> { x \<in> B. P x }"
	+ apply (induction xs)
	+ apply (auto) by (metis UnI1 UnI2 insert_iff)+
	+
	+subsubsection \<open>@{const length}\<close>
	+
	+fun t_length :: "'a list \<Rightarrow> nat" where
	+ "t_length [] = 0"
	+\| "t_length (x#xs) = 1 + t_length xs"
	+
	+lemma t_length:
	+ "t_length xs = length xs"
	+ by (induction xs) auto
	+
	+fun length_it' :: "nat \<Rightarrow> 'a list \<Rightarrow> nat" where
	+ "length_it' acc [] = acc"
	+\| "length_it' acc (x#xs) = length_it' (acc+1) xs"
	+
	+definition length_it :: "'a list \<Rightarrow> nat" where
	+ "length_it xs = length_it' 0 xs"
	+
	+lemma length_conv_length_it':
	+ "length xs + acc = length_it' acc xs"
	+ by (induction acc xs rule: length_it'.induct) auto
	+
	+lemma length_conv_length_it[code_unfold]:
	+ "length xs = length_it xs"
	+ unfolding length_it_def using length_conv_length_it' add_0_right by metis
	+
	+subsubsection \<open>@{const rev}\<close>
	+
	+fun rev_it' :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
	+ "rev_it' acc [] = acc"
	+\| "rev_it' acc (x#xs) = rev_it' (x#acc) xs"
	+
	+definition rev_it :: "'a list \<Rightarrow> 'a list" where
	+ "rev_it xs = rev_it' [] xs"
	+
	+lemma rev_conv_rev_it':
	+ "rev xs @ acc = rev_it' acc xs"
	+ by (induction acc xs rule: rev_it'.induct) auto
	+
	+lemma rev_conv_rev_it[code_unfold]:
	+ "rev xs = rev_it xs"
	+ unfolding rev_it_def using rev_conv_rev_it' append_Nil2 by metis
	+
	+subsubsection \<open>@{const take}\<close>
	+
	+fun t_take :: "nat \<Rightarrow> 'a list \<Rightarrow> nat" where
	+ "t_take n [] = 0"
	+\| "t_take n (x#xs) = 1 + (
	+ case n of
	+ 0 \<Rightarrow> 0
	+ \| Suc m \<Rightarrow> t_take m xs
	+ )"
	+
	+lemma t_take:
	+ "t_take n xs \<le> min (n + 1) (length xs)"
	+ by (induction xs arbitrary: n) (auto split: nat.split)
	+
	+subsubsection \<open>@{const filter}\<close>
	+
	+fun t_filter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat" where
	+ "t_filter P [] = 0"
	+\| "t_filter P (x#xs) = 1 + (if P x then t_filter P xs else t_filter P xs)"
	+
	+lemma t_filter:
	+ "t_filter P xs = length xs"
	+ by (induction xs) auto
	+
	+fun filter_it' :: "'a list \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
	+ "filter_it' acc P [] = rev acc"
	+\| "filter_it' acc P (x#xs) = (
	+ if P x then
	+ filter_it' (x#acc) P xs
	+ else
	+ filter_it' acc P xs
	+ )"
	+
	+definition filter_it :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
	+ "filter_it P xs = filter_it' [] P xs"
	+
	+lemma filter_conv_filter_it':
	+ "rev acc @ filter P xs = filter_it' acc P xs"
	+ by (induction acc P xs rule: filter_it'.induct) auto
	+
	+lemma filter_conv_filter_it[code_unfold]:
	+ "filter P xs = filter_it P xs"
	+ unfolding filter_it_def using filter_conv_filter_it' append_Nil rev.simps(1) by metis
	+
	+subsubsection \<open>\<open>split_at\<close>\<close>
	+
	+fun split_at :: "nat \<Rightarrow> 'a list \<Rightarrow> ('a list * 'a list)" where
	+ "split_at n [] = ([], [])"
	+\| "split_at n (x # xs) = (
	+ case n of
	+ 0 \<Rightarrow> ([], x # xs)
	+ \| Suc m \<Rightarrow>
	+ let (xs', ys') = split_at m xs in
	+ (x # xs', ys')
	+ )"
	+
	+lemma split_at_take_drop_conv:
	+ "split_at n xs = (take n xs, drop n xs)"
	+ by (induction xs arbitrary: n) (auto split: nat.split)
	+
	+fun t_split_at :: "nat \<Rightarrow> 'a list \<Rightarrow> nat" where
	+ "t_split_at n [] = 0"
	+\| "t_split_at n (x#xs) = 1 + (
	+ case n of
	+ 0 \<Rightarrow> 0
	+ \| Suc m \<Rightarrow> t_split_at m xs
	+ )"
	+
	+lemma t_split_at:
	+ "t_split_at n xs \<le> length xs"
	+ by (induction xs arbitrary: n) (auto split: nat.split)
	+
	+fun split_at_it' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> ('a list * 'a list)" where
	+ "split_at_it' acc n [] = (rev acc, [])"
	+\| "split_at_it' acc n (x#xs) = (
	+ case n of
	+ 0 \<Rightarrow> (rev acc, x#xs)
	+ \| Suc m \<Rightarrow> split_at_it' (x#acc) m xs
	+ )"
	+
	+definition split_at_it :: "nat \<Rightarrow> 'a list \<Rightarrow> ('a list * 'a list)" where
	+ "split_at_it n xs = split_at_it' [] n xs"
	+
	+lemma split_at_conv_split_at_it':
	+ assumes "(ts, ds) = split_at n xs" "(tsi, dsi) = split_at_it' acc n xs"
	+ shows "rev acc @ ts = tsi"
	+ and "ds = dsi"
	+ using assms
	+ apply (induction acc n xs arbitrary: ts rule: split_at_it'.induct)
	+ apply (auto simp: split_at.simps split: prod.splits nat.splits)
	+ done
	+
	+lemma split_at_conv_split_at_it_prod:
	+ assumes "(ts, ds) = split_at n xs" "(ts', ds') = split_at_it n xs"
	+ shows "(ts, ds) = (ts', ds')"
	+ using assms unfolding split_at_it_def
	+ using split_at_conv_split_at_it' rev.simps(1) append_Nil by fast+
	+
	+lemma split_at_conv_split_at_it[code_unfold]:
	+ "split_at n xs = split_at_it n xs"
	+ using split_at_conv_split_at_it_prod surj_pair by metis
	+
	+
	+subsection "Mergesort"
	+
	+subsubsection "Functional Correctness Proof"
	+
	+definition sorted_fst :: "point list \<Rightarrow> bool" where
	+ "sorted_fst ps = sorted_wrt (\<lambda>p\<^sub>0 p\<^sub>1. fst p\<^sub>0 \<le> fst p\<^sub>1) ps"
	+
	+definition sorted_snd :: "point list \<Rightarrow> bool" where
	+ "sorted_snd ps = sorted_wrt (\<lambda>p\<^sub>0 p\<^sub>1. snd p\<^sub>0 \<le> snd p\<^sub>1) ps"
	+
	+fun merge :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
	+ "merge f (x # xs) (y # ys) = (
	+ if f x \<le> f y then
	+ x # merge f xs (y # ys)
	+ else
	+ y # merge f (x # xs) ys
	+ )"
	+\| "merge f [] ys = ys"
	+\| "merge f xs [] = xs"
	+
	+lemma length_merge:
	+ "length (merge f xs ys) = length xs + length ys"
	+ by (induction f xs ys rule: merge.induct) auto
	+
	+lemma set_merge:
	+ "set (merge f xs ys) = set xs \<union> set ys"
	+ by (induction f xs ys rule: merge.induct) auto
	+
	+lemma distinct_merge:
	+ assumes "set xs \<inter> set ys = {}" "distinct xs" "distinct ys"
	+ shows "distinct (merge f xs ys)"
	+ using assms by (induction f xs ys rule: merge.induct) (auto simp: set_merge)
	+
	+lemma sorted_merge:
	+ assumes "P = (\<lambda>x y. f x \<le> f y)"
	+ shows "sorted_wrt P (merge f xs ys) \<longleftrightarrow> sorted_wrt P xs \<and> sorted_wrt P ys"
	+ using assms by (induction f xs ys rule: merge.induct) (auto simp: set_merge)
	+
	+function mergesort :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list" where
	+ "mergesort f [] = []"
	+\| "mergesort f [x] = [x]"
	+\| "mergesort f (x # y # xs') = (
	+ let xs = x # y # xs' in
	+ let n = length xs div 2 in
	+ let (l, r) = split_at n xs in
	+ merge f (mergesort f l) (mergesort f r)
	+ )"
	+ by pat_completeness auto
	+termination mergesort
	+ apply (relation "Wellfounded.measure (\<lambda>(_, xs). length xs)")
	+ apply (auto simp: split_at_take_drop_conv Let_def)
	+ done
	+
	+lemma sorted_wrt_mergesort:
	+ "sorted_wrt (\<lambda>x y. f x \<le> f y) (mergesort f xs)"
	+ by (induction f xs rule: mergesort.induct) (auto simp: split_at_take_drop_conv sorted_merge)
	+
	+lemma set_mergesort:
	+ "set (mergesort f xs) = set xs"
	+ apply (induction f xs rule: mergesort.induct)
	+ apply (simp_all add: set_merge split_at_take_drop_conv)
	+ using set_take_drop by (metis list.simps(15))
	+
	+lemma length_mergesort:
	+ "length (mergesort f xs) = length xs"
	+ by (induction f xs rule: mergesort.induct) (auto simp: length_merge split_at_take_drop_conv)
	+
	+lemma distinct_mergesort:
	+ "distinct xs \<Longrightarrow> distinct (mergesort f xs)"
	+proof (induction f xs rule: mergesort.induct)
	+ case (3 f x y xs)
	+ let ?xs' = "x # y # xs"
	+ obtain l r where lr_def: "(l, r) = split_at (length ?xs' div 2) ?xs'"
	+ by (metis surj_pair)
	+ have "distinct l" "distinct r"
	+ using "3.prems" split_at_take_drop_conv distinct_take distinct_drop lr_def by (metis prod.sel)+
	+ hence "distinct (mergesort f l)" "distinct (mergesort f r)"
	+ using "3.IH" lr_def by auto
	+ moreover have "set l \<inter> set r = {}"
	+ using "3.prems" split_at_take_drop_conv lr_def by (metis append_take_drop_id distinct_append prod.sel)
	+ ultimately show ?case
	+ using lr_def by (auto simp: distinct_merge set_mergesort split: prod.splits)
	+qed auto
	+
	+lemmas mergesort = sorted_wrt_mergesort set_mergesort length_mergesort distinct_mergesort
	+
	+lemma sorted_fst_take_less_hd_drop:
	+ assumes "sorted_fst ps" "n < length ps"
	+ shows "\<forall>p \<in> set (take n ps). fst p \<le> fst (hd (drop n ps))"
	+ using assms sorted_wrt_take_less_hd_drop[of "\<lambda>p\<^sub>0 p\<^sub>1. fst p\<^sub>0 \<le> fst p\<^sub>1"] sorted_fst_def by fastforce
	+
	+lemma sorted_fst_hd_drop_less_drop:
	+ assumes "sorted_fst ps"
	+ shows "\<forall>p \<in> set (drop n ps). fst (hd (drop n ps)) \<le> fst p"
	+ using assms sorted_wrt_hd_drop_less_drop[of "\<lambda>p\<^sub>0 p\<^sub>1. fst p\<^sub>0 \<le> fst p\<^sub>1"] sorted_fst_def by fastforce
	+
	+subsubsection "Time Complexity Proof"
	+
	+fun t_merge' :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> nat" where
	+ "t_merge' f (x#xs) (y#ys) = 1 + (
	+ if f x \<le> f y then
	+ t_merge' f xs (y#ys)
	+ else
	+ t_merge' f (x#xs) ys
	+ )"
	+\| "t_merge' f xs [] = 0"
	+\| "t_merge' f [] ys = 0"
	+
	+definition t_merge :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> ('b list * 'b list) \<Rightarrow> nat" where
	+ "t_merge f xys = t_merge' f (fst xys) (snd xys)"
	+
	+lemma t_merge:
	+ "t_merge f (xs, ys) \<le> length xs + length ys"
	+ unfolding t_merge_def by (induction f xs ys rule: t_merge'.induct) auto
	+
	+function t_mergesort :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> nat" where
	+ "t_mergesort f [] = 0"
	+\| "t_mergesort f [_] = 1"
	+\| "t_mergesort f (x # y # xs') = (
	+ let xs = x # y # xs' in
	+ let (l, r) = split_at (length xs div 2) xs in
	+ t_length xs + t_split_at (length xs div 2) xs +
	+ t_mergesort f l + t_mergesort f r + t_merge f (l, r)
	+ )"
	+ by pat_completeness auto
	+termination t_mergesort
	+ apply (relation "Wellfounded.measure (\<lambda>(_, xs). length xs)")
	+ apply (auto simp: split_at_take_drop_conv Let_def)
	+ done
	+
	+function mergesort_recurrence :: "nat \<Rightarrow> real" where
	+ "mergesort_recurrence 0 = 0"
	+\| "mergesort_recurrence 1 = 1"
	+\| "2 \<le> n \<Longrightarrow> mergesort_recurrence n = mergesort_recurrence (nat \<lfloor>real n / 2\<rfloor>) +
	+ mergesort_recurrence (nat \<lceil>real n / 2\<rceil>) + 3 * n"
	+ by force simp_all
	+termination by akra_bazzi_termination simp_all
	+
	+lemma mergesort_recurrence_nonneg[simp]:
	+ "0 \<le> mergesort_recurrence n"
	+ by (induction n rule: mergesort_recurrence.induct) (auto simp del: One_nat_def)
	+
	+lemma t_mergesort_conv_mergesort_recurrence:
	+ "t_mergesort f xs \<le> mergesort_recurrence (length xs)"
	+proof (induction f xs rule: t_mergesort.induct)
	+ case (2 f x)
	+ thus ?case
	+ using mergesort_recurrence.simps(2) by auto
	+next
	+ case (3 f x y xs')
	+
	+ define XS where "XS = x # y # xs'"
	+ define N where "N = length XS"
	+ obtain L R where LR_def: "(L, R) = split_at (N div 2) XS"
	+ using prod.collapse by blast
	+ note defs = XS_def N_def LR_def
	+
	+ let ?LHS = "t_length XS + t_split_at (N div 2) XS + t_mergesort f L + t_mergesort f R + t_merge f (L, R)"
	+ let ?RHS = "mergesort_recurrence (nat \<lfloor>real N / 2\<rfloor>) + mergesort_recurrence (nat \<lceil>real N / 2\<rceil>) + 3 * N"
	+
	+ have IHL: "t_mergesort f L \<le> mergesort_recurrence (length L)"
	+ using defs "3.IH"(1) prod.collapse by blast
	+ have IHR: "t_mergesort f R \<le> mergesort_recurrence (length R)"
	+ using defs "3.IH"(2) prod.collapse by blast
	+
	+ have *: "length L = N div 2" "length R = N - N div 2"
	+ using defs by (auto simp: split_at_take_drop_conv)
	+ hence "(nat \<lfloor>real N / 2\<rfloor>) = length L" "(nat \<lceil>real N / 2\<rceil>) = length R"
	+ by linarith+
	+ hence IH: "t_mergesort f L \<le> mergesort_recurrence (nat \<lfloor>real N / 2\<rfloor>)"
	+ "t_mergesort f R \<le> mergesort_recurrence (nat \<lceil>real N / 2\<rceil>)"
	+ using IHL IHR by simp_all
	+
	+ have "N = length L + length R"
	+ using * by linarith
	+ hence "t_merge f (L, R) \<le> N"
	+ using t_merge by simp
	+ moreover have "t_length XS = N"
	+ using t_length N_def by blast
	+ moreover have "t_split_at (N div 2) XS \<le> N"
	+ using t_split_at N_def by blast
	+ ultimately have *: "?LHS \<le> ?RHS"
	+ using IH by simp
	+ moreover have "t_mergesort f XS = ?LHS"
	+ using defs by (auto simp: Let_def split: prod.split)
	+ moreover have "mergesort_recurrence N = ?RHS"
	+ by (simp add: defs)
	+ ultimately have "t_mergesort f XS \<le> mergesort_recurrence N"
	+ by presburger
	+ thus ?case
	+ using XS_def N_def by blast
	+qed auto
	+
	+theorem mergesort_recurrence:
	+ "mergesort_recurrence \<in> \<Theta>(\<lambda>n. n * ln n)"
	+ by (master_theorem) auto
	+
	+theorem t_mergesort_bigo:
	+ "t_mergesort f \<in> O[length going_to at_top]((\<lambda>n. n * ln n) o length)"
	+proof -
	+ have 0: "\<And>xs. t_mergesort f xs \<le> (mergesort_recurrence o length) xs"
	+ unfolding comp_def using t_mergesort_conv_mergesort_recurrence by blast
	+ show ?thesis
	+ using bigo_measure_trans[OF 0] by (simp add: bigthetaD1 mergesort_recurrence)
	+qed
	+
	+subsubsection "Code Export"
	+
	+lemma merge_xs_Nil[simp]:
	+ "merge f xs [] = xs"
	+ by (cases xs) auto
	+
	+fun merge_it' :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
	+ "merge_it' f acc [] [] = rev acc"
	+\| "merge_it' f acc (x#xs) [] = merge_it' f (x#acc) xs []"
	+\| "merge_it' f acc [] (y#ys) = merge_it' f (y#acc) ys []"
	+\| "merge_it' f acc (x#xs) (y#ys) = (
	+ if f x \<le> f y then
	+ merge_it' f (x#acc) xs (y#ys)
	+ else
	+ merge_it' f (y#acc) (x#xs) ys
	+ )"
	+
	+definition merge_it :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
	+ "merge_it f xs ys = merge_it' f [] xs ys"
	+
	+lemma merge_conv_merge_it':
	+ "rev acc @ merge f xs ys = merge_it' f acc xs ys"
	+ by (induction f acc xs ys rule: merge_it'.induct) auto
	+
	+lemma merge_conv_merge_it[code_unfold]:
	+ "merge f xs ys = merge_it f xs ys"
	+ unfolding merge_it_def using merge_conv_merge_it' rev.simps(1) append_Nil by metis
	+
	+
	+subsection "Minimal Distance"
	+
	+definition sparse :: "real \<Rightarrow> point set \<Rightarrow> bool" where
	+ "sparse \<delta> ps \<longleftrightarrow> (\<forall>p\<^sub>0 \<in> ps. \<forall>p\<^sub>1 \<in> ps. p\<^sub>0 \<noteq> p\<^sub>1 \<longrightarrow> \<delta> \<le> dist p\<^sub>0 p\<^sub>1)"
	+
	+lemma sparse_identity:
	+ assumes "sparse \<delta> (set ps)" "\<forall>p \<in> set ps. \<delta> \<le> dist p\<^sub>0 p"
	+ shows "sparse \<delta> (set (p\<^sub>0 # ps))"
	+ using assms by (simp add: dist_commute sparse_def)
	+
	+lemma sparse_update:
	+ assumes "sparse \<delta> (set ps)"
	+ assumes "dist p\<^sub>0 p\<^sub>1 \<le> \<delta>" "\<forall>p \<in> set ps. dist p\<^sub>0 p\<^sub>1 \<le> dist p\<^sub>0 p"
	+ shows "sparse (dist p\<^sub>0 p\<^sub>1) (set (p\<^sub>0 # ps))"
	+ using assms apply (auto simp: dist_commute sparse_def) by force+
	+
	+lemma sparse_mono:
	+ "sparse \<Delta> P \<Longrightarrow> \<delta> \<le> \<Delta> \<Longrightarrow> sparse \<delta> P"
	+ unfolding sparse_def by fastforce
	+
	+
	+subsection "Distance"
	+
	+lemma dist_transform:
	+ fixes p :: point and \<delta> :: real and l :: int
	+ shows "dist p (l, snd p) < \<delta> \<longleftrightarrow> l - \<delta> < fst p \<and> fst p < l + \<delta>"
	+proof -
	+ have "dist p (l, snd p) = sqrt ((real_of_int (fst p) - l)\<^sup>2)"
	+ by (auto simp add: dist_prod_def dist_real_def prod.case_eq_if)
	+ thus ?thesis
	+ by auto
	+qed
	+
	+fun dist_code :: "point \<Rightarrow> point \<Rightarrow> int" where
	+ "dist_code p\<^sub>0 p\<^sub>1 = (fst p\<^sub>0 - fst p\<^sub>1)\<^sup>2 + (snd p\<^sub>0 - snd p\<^sub>1)\<^sup>2"
	+
	+lemma dist_eq_sqrt_dist_code:
	+ fixes p\<^sub>0 :: point
	+ shows "dist p\<^sub>0 p\<^sub>1 = sqrt (dist_code p\<^sub>0 p\<^sub>1)"
	+ by (auto simp: dist_prod_def dist_real_def split: prod.splits)
	+
	+lemma dist_eq_dist_code_lt:
	+ fixes p\<^sub>0 :: point
	+ shows "dist p\<^sub>0 p\<^sub>1 < dist p\<^sub>2 p\<^sub>3 \<longleftrightarrow> dist_code p\<^sub>0 p\<^sub>1 < dist_code p\<^sub>2 p\<^sub>3"
	+ using dist_eq_sqrt_dist_code real_sqrt_less_iff by presburger
	+
	+lemma dist_eq_dist_code_le:
	+ fixes p\<^sub>0 :: point
	+ shows "dist p\<^sub>0 p\<^sub>1 \<le> dist p\<^sub>2 p\<^sub>3 \<longleftrightarrow> dist_code p\<^sub>0 p\<^sub>1 \<le> dist_code p\<^sub>2 p\<^sub>3"
	+ using dist_eq_sqrt_dist_code real_sqrt_le_iff by presburger
	+
	+lemma dist_eq_dist_code_abs_lt:
	+ fixes p\<^sub>0 :: point
	+ shows "\<bar>c\<bar> < dist p\<^sub>0 p\<^sub>1 \<longleftrightarrow> c\<^sup>2 < dist_code p\<^sub>0 p\<^sub>1"
	+ using dist_eq_sqrt_dist_code
	+ by (metis of_int_less_of_int_power_cancel_iff real_sqrt_abs real_sqrt_less_iff)
	+
	+lemma dist_eq_dist_code_abs_le:
	+ fixes p\<^sub>0 :: point
	+ shows "dist p\<^sub>0 p\<^sub>1 \<le> \<bar>c\<bar> \<longleftrightarrow> dist_code p\<^sub>0 p\<^sub>1 \<le> c\<^sup>2"
	+ using dist_eq_sqrt_dist_code
	+ by (metis of_int_power_le_of_int_cancel_iff real_sqrt_abs real_sqrt_le_iff)
	+
	+lemma dist_fst_abs:
	+ fixes p :: point and l :: int
	+ shows "dist p (l, snd p) = \<bar>fst p - l\<bar>"
	+proof -
	+ have "dist p (l, snd p) = sqrt ((real_of_int (fst p) - l)\<^sup>2)"
	+ by (simp add: dist_prod_def dist_real_def prod.case_eq_if)
	+ thus ?thesis
	+ by simp
	+qed
	+
	+declare dist_code.simps [simp del]
	+
	+
	+subsection "Brute Force Closest Pair Algorithm"
	+
	+subsubsection "Functional Correctness Proof"
	+
	+fun find_closest_bf :: "point \<Rightarrow> point list \<Rightarrow> point" where
	+ "find_closest_bf _ [] = undefined"
	+\| "find_closest_bf _ [p] = p"
	+\| "find_closest_bf p (p\<^sub>0 # ps) = (
	+ let p\<^sub>1 = find_closest_bf p ps in
	+ if dist p p\<^sub>0 < dist p p\<^sub>1 then
	+ p\<^sub>0
	+ else
	+ p\<^sub>1
	+ )"
	+
	+lemma find_closest_bf_set:
	+ "0 < length ps \<Longrightarrow> find_closest_bf p ps \<in> set ps"
	+ by (induction p ps rule: find_closest_bf.induct)
	+ (auto simp: Let_def split: prod.splits if_splits)
	+
	+lemma find_closest_bf_dist:
	+ "\<forall>q \<in> set ps. dist p (find_closest_bf p ps) \<le> dist p q"
	+ by (induction p ps rule: find_closest_bf.induct)
	+ (auto split: prod.splits)
	+
	+fun closest_pair_bf :: "point list \<Rightarrow> (point * point)" where
	+ "closest_pair_bf [] = undefined"
	+\| "closest_pair_bf [_] = undefined"
	+\| "closest_pair_bf [p\<^sub>0, p\<^sub>1] = (p\<^sub>0, p\<^sub>1)"
	+\| "closest_pair_bf (p\<^sub>0 # ps) = (
	+ let (c\<^sub>0, c\<^sub>1) = closest_pair_bf ps in
	+ let p\<^sub>1 = find_closest_bf p\<^sub>0 ps in
	+ if dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1 then
	+ (c\<^sub>0, c\<^sub>1)
	+ else
	+ (p\<^sub>0, p\<^sub>1)
	+ )"
	+
	+lemma closest_pair_bf_c0:
	+ "1 < length ps \<Longrightarrow> (c\<^sub>0, c\<^sub>1) = closest_pair_bf ps \<Longrightarrow> c\<^sub>0 \<in> set ps"
	+ by (induction ps arbitrary: c\<^sub>0 c\<^sub>1 rule: closest_pair_bf.induct)
	+ (auto simp: Let_def find_closest_bf_set split: if_splits prod.splits)
	+
	+lemma closest_pair_bf_c1:
	+ "1 < length ps \<Longrightarrow> (c\<^sub>0, c\<^sub>1) = closest_pair_bf ps \<Longrightarrow> c\<^sub>1 \<in> set ps"
	+proof (induction ps arbitrary: c\<^sub>0 c\<^sub>1 rule: closest_pair_bf.induct)
	+ case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
	+ let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
	+ obtain c\<^sub>0 c\<^sub>1 where c\<^sub>0_def: "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ?ps"
	+ using prod.collapse by blast
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 ?ps"
	+ note defs = c\<^sub>0_def p\<^sub>1_def
	+ have "c\<^sub>1 \<in> set ?ps"
	+ using "4.IH" defs by simp
	+ moreover have "p\<^sub>1 \<in> set ?ps"
	+ using find_closest_bf_set defs by blast
	+ ultimately show ?case
	+ using "4.prems"(2) defs by (auto simp: Let_def split: prod.splits if_splits)
	+qed auto
	+
	+lemma closest_pair_bf_c0_ne_c1:
	+ "1 < length ps \<Longrightarrow> distinct ps \<Longrightarrow> (c\<^sub>0, c\<^sub>1) = closest_pair_bf ps \<Longrightarrow> c\<^sub>0 \<noteq> c\<^sub>1"
	+proof (induction ps arbitrary: c\<^sub>0 c\<^sub>1 rule: closest_pair_bf.induct)
	+ case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
	+ let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
	+ obtain c\<^sub>0 c\<^sub>1 where c\<^sub>0_def: "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ?ps"
	+ using prod.collapse by blast
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 ?ps"
	+ note defs = c\<^sub>0_def p\<^sub>1_def
	+ have "c\<^sub>0 \<noteq> c\<^sub>1"
	+ using "4.IH" "4.prems"(2) defs by simp
	+ moreover have "p\<^sub>0 \<noteq> p\<^sub>1"
	+ using find_closest_bf_set "4.prems"(2) defs
	+ by (metis distinct.simps(2) length_pos_if_in_set list.set_intros(1))
	+ ultimately show ?case
	+ using "4.prems"(3) defs by (auto simp: Let_def split: prod.splits if_splits)
	+qed auto
	+
	+lemmas closest_pair_bf_c0_c1 = closest_pair_bf_c0 closest_pair_bf_c1 closest_pair_bf_c0_ne_c1
	+
	+lemma closest_pair_bf_dist:
	+ assumes "1 < length ps" "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ps"
	+ shows "sparse (dist c\<^sub>0 c\<^sub>1) (set ps)"
	+ using assms
	+proof (induction ps arbitrary: c\<^sub>0 c\<^sub>1 rule: closest_pair_bf.induct)
	+ case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
	+ let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
	+ obtain c\<^sub>0 c\<^sub>1 where c\<^sub>0_def: "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ?ps"
	+ using prod.collapse by blast
	+ define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 ?ps"
	+ note defs = c\<^sub>0_def p\<^sub>1_def
	+ hence IH: "sparse (dist c\<^sub>0 c\<^sub>1) (set ?ps)"
	+ using 4 c\<^sub>0_def by simp
	+ have *: "\<forall>p \<in> set ?ps. (dist p\<^sub>0 p\<^sub>1) \<le> dist p\<^sub>0 p"
	+ using find_closest_bf_dist defs by blast
	+ show ?case
	+ proof (cases "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1")
	+ case True
	+ hence "\<forall>p \<in> set ?ps. dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p"
	+ using * by auto
	+ hence "sparse (dist c\<^sub>0 c\<^sub>1) (set (p\<^sub>0 # ?ps))"
	+ using sparse_identity IH by blast
	+ thus ?thesis
	+ using True "4.prems" defs by (auto split: prod.splits)
	+ next
	+ case False
	+ hence "sparse (dist p\<^sub>0 p\<^sub>1) (set (p\<^sub>0 # ?ps))"
	+ using sparse_update[of "dist c\<^sub>0 c\<^sub>1" ?ps p\<^sub>0 p\<^sub>1] IH * defs by argo
	+ thus ?thesis
	+ using False "4.prems" defs by (auto split: prod.splits)
	+ qed
	+qed (auto simp: dist_commute sparse_def)
	+
	+subsubsection "Time Complexity Proof"
	+
	+fun t_find_closest_bf :: "point \<Rightarrow> point list \<Rightarrow> nat" where
	+ "t_find_closest_bf _ [] = 0"
	+\| "t_find_closest_bf _ [_] = 1"
	+\| "t_find_closest_bf p (p\<^sub>0 # ps) = 1 + (
	+ let p\<^sub>1 = find_closest_bf p ps in
	+ t_find_closest_bf p ps + (
	+ if dist p p\<^sub>0 < dist p p\<^sub>1 then 0 else 0
	+ )
	+ )"
	+
	+lemma t_find_closest_bf:
	+ "t_find_closest_bf p ps = length ps"
	+ by (induction p ps rule: t_find_closest_bf.induct) auto
	+
	+fun t_closest_pair_bf :: "point list \<Rightarrow> nat" where
	+ "t_closest_pair_bf [] = 0"
	+\| "t_closest_pair_bf [_] = 1"
	+\| "t_closest_pair_bf [_, _] = 2"
	+\| "t_closest_pair_bf (p\<^sub>0 # ps) = 1 + (
	+ let (c\<^sub>0, c\<^sub>1) = closest_pair_bf ps in
	+ t_closest_pair_bf ps + (
	+ let p\<^sub>1 = find_closest_bf p\<^sub>0 ps in
	+ t_find_closest_bf p\<^sub>0 ps + (
	+ if dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1 then 0 else 0
	+ ))
	+ )"
	+
	+lemma t_closest_pair_bf:
	+ "t_closest_pair_bf ps \<le> length ps * length ps"
	+proof (induction rule: t_closest_pair_bf.induct)
	+ case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
	+ let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
	+ have "t_closest_pair_bf ?ps \<le> length ?ps * length ?ps"
	+ using 4 prod_cases3 by metis
	+ thus ?case
	+ using "4.prems" t_find_closest_bf by simp
	+qed auto
	+
	+subsubsection "Code Export"
	+
	+fun find_closest_bf_code :: "point \<Rightarrow> point list \<Rightarrow> (int * point)" where
	+ "find_closest_bf_code p [] = undefined"
	+\| "find_closest_bf_code p [p\<^sub>0] = (dist_code p p\<^sub>0, p\<^sub>0)"
	+\| "find_closest_bf_code p (p\<^sub>0 # ps) = (
	+ let (\<delta>\<^sub>1, p\<^sub>1) = find_closest_bf_code p ps in
	+ let \<delta>\<^sub>0 = dist_code p p\<^sub>0 in
	+ if \<delta>\<^sub>0 < \<delta>\<^sub>1 then
	+ (\<delta>\<^sub>0, p\<^sub>0)
	+ else
	+ (\<delta>\<^sub>1, p\<^sub>1)
	+ )"
	+
	+lemma find_closest_bf_code_dist_eq:
	+ "0 < length ps \<Longrightarrow> (\<delta>, c) = find_closest_bf_code p ps \<Longrightarrow> \<delta> = dist_code p c"
	+ by (induction p ps rule: find_closest_bf_code.induct)
	+ (auto simp: Let_def split: prod.splits if_splits)
	+
	+lemma find_closest_bf_code_eq:
	+ "0 < length ps \<Longrightarrow> c = find_closest_bf p ps \<Longrightarrow> (\<delta>', c') = find_closest_bf_code p ps \<Longrightarrow> c = c'"
	+proof (induction p ps arbitrary: c \<delta>' c' rule: find_closest_bf.induct)
	+ case (3 p p\<^sub>0 p\<^sub>2 ps)
	+ define \<delta>\<^sub>0 \<delta>\<^sub>0' where \<delta>\<^sub>0_def: "\<delta>\<^sub>0 = dist p p\<^sub>0" "\<delta>\<^sub>0' = dist_code p p\<^sub>0"
	+ obtain \<delta>\<^sub>1 p\<^sub>1 \<delta>\<^sub>1' p\<^sub>1' where \<delta>\<^sub>1_def: "\<delta>\<^sub>1 = dist p p\<^sub>1" "p\<^sub>1 = find_closest_bf p (p\<^sub>2 # ps)"
	+ "(\<delta>\<^sub>1', p\<^sub>1') = find_closest_bf_code p (p\<^sub>2 # ps)"
	+ using prod.collapse by blast+
	+ note defs = \<delta>\<^sub>0_def \<delta>\<^sub>1_def
	+ have *: "p\<^sub>1 = p\<^sub>1'"
	+ using "3.IH" defs by simp
	+ hence "\<delta>\<^sub>0 < \<delta>\<^sub>1 \<longleftrightarrow> \<delta>\<^sub>0' < \<delta>\<^sub>1'"
	+ using find_closest_bf_code_dist_eq[of "p\<^sub>2 # ps" \<delta>\<^sub>1' p\<^sub>1' p]
	+ dist_eq_dist_code_lt defs
	+ by simp
	+ thus ?case
	+ using "3.prems"(2,3) * defs by (auto split: prod.splits)
	+qed auto
	+
	+declare find_closest_bf_code.simps [simp del]
	+
	+fun closest_pair_bf_code :: "point list \<Rightarrow> (int * point * point)" where
	+ "closest_pair_bf_code [] = undefined"
	+\| "closest_pair_bf_code [p\<^sub>0] = undefined"
	+\| "closest_pair_bf_code [p\<^sub>0, p\<^sub>1] = (dist_code p\<^sub>0 p\<^sub>1, p\<^sub>0, p\<^sub>1)"
	+\| "closest_pair_bf_code (p\<^sub>0 # ps) = (
	+ let (\<delta>\<^sub>c, c\<^sub>0, c\<^sub>1) = closest_pair_bf_code ps in
	+ let (\<delta>\<^sub>p, p\<^sub>1) = find_closest_bf_code p\<^sub>0 ps in
	+ if \<delta>\<^sub>c \<le> \<delta>\<^sub>p then
	+ (\<delta>\<^sub>c, c\<^sub>0, c\<^sub>1)
	+ else
	+ (\<delta>\<^sub>p, p\<^sub>0, p\<^sub>1)
	+ )"
	+
	+lemma closest_pair_bf_code_dist_eq:
	+ "1 < length ps \<Longrightarrow> (\<delta>, c\<^sub>0, c\<^sub>1) = closest_pair_bf_code ps \<Longrightarrow> \<delta> = dist_code c\<^sub>0 c\<^sub>1"
	+proof (induction ps arbitrary: \<delta> c\<^sub>0 c\<^sub>1 rule: closest_pair_bf_code.induct)
	+ case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
	+ let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
	+ obtain \<delta>\<^sub>c c\<^sub>0 c\<^sub>1 where \<delta>\<^sub>c_def: "(\<delta>\<^sub>c, c\<^sub>0, c\<^sub>1) = closest_pair_bf_code ?ps"
	+ by (metis prod_cases3)
	+ obtain \<delta>\<^sub>p p\<^sub>1 where \<delta>\<^sub>p_def: "(\<delta>\<^sub>p, p\<^sub>1) = find_closest_bf_code p\<^sub>0 ?ps"
	+ using prod.collapse by blast
	+ note defs = \<delta>\<^sub>c_def \<delta>\<^sub>p_def
	+ have "\<delta>\<^sub>c = dist_code c\<^sub>0 c\<^sub>1"
	+ using "4.IH" defs by simp
	+ moreover have "\<delta>\<^sub>p = dist_code p\<^sub>0 p\<^sub>1"
	+ using find_closest_bf_code_dist_eq defs by blast
	+ ultimately show ?case
	+ using "4.prems"(2) defs by (auto split: prod.splits if_splits)
	+qed auto
	+
	+lemma closest_pair_bf_code_eq:
	+ assumes "1 < length ps"
	+ assumes "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ps" "(\<delta>', c\<^sub>0', c\<^sub>1') = closest_pair_bf_code ps"
	+ shows "c\<^sub>0 = c\<^sub>0' \<and> c\<^sub>1 = c\<^sub>1'"
	+ using assms
	+proof (induction ps arbitrary: c\<^sub>0 c\<^sub>1 \<delta>' c\<^sub>0' c\<^sub>1' rule: closest_pair_bf_code.induct)
	+ case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
	+ let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
	+ obtain c\<^sub>0 c\<^sub>1 \<delta>\<^sub>c' c\<^sub>0' c\<^sub>1' where \<delta>\<^sub>c_def: "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ?ps"
	+ "(\<delta>\<^sub>c', c\<^sub>0', c\<^sub>1') = closest_pair_bf_code ?ps"
	+ by (metis prod_cases3)
	+ obtain p\<^sub>1 \<delta>\<^sub>p' p\<^sub>1' where \<delta>\<^sub>p_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 ?ps"
	+ "(\<delta>\<^sub>p', p\<^sub>1') = find_closest_bf_code p\<^sub>0 ?ps"
	+ using prod.collapse by blast
	+ note defs = \<delta>\<^sub>c_def \<delta>\<^sub>p_def
	+ have A: "c\<^sub>0 = c\<^sub>0' \<and> c\<^sub>1 = c\<^sub>1'"
	+ using "4.IH" defs by simp
	+ moreover have B: "p\<^sub>1 = p\<^sub>1'"
	+ using find_closest_bf_code_eq defs by blast
	+ moreover have "\<delta>\<^sub>c' = dist_code c\<^sub>0' c\<^sub>1'"
	+ using defs closest_pair_bf_code_dist_eq[of ?ps] by simp
	+ moreover have "\<delta>\<^sub>p' = dist_code p\<^sub>0 p\<^sub>1'"
	+ using defs find_closest_bf_code_dist_eq by blast
	+ ultimately have "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1 \<longleftrightarrow> \<delta>\<^sub>c' \<le> \<delta>\<^sub>p'"
	+ by (simp add: dist_eq_dist_code_le)
	+ thus ?case
	+ using "4.prems"(2,3) defs A B by (auto simp: Let_def split: prod.splits)
	+qed auto
	+
	+
	+subsection "Geometry"
	+
	+subsubsection "Band Filter"
	+
	+lemma set_band_filter_aux:
	+ fixes \<delta> :: real and ps :: "point list"
	+ assumes "p\<^sub>0 \<in> ps\<^sub>L" "p\<^sub>1 \<in> ps\<^sub>R" "p\<^sub>0 \<noteq> p\<^sub>1" "dist p\<^sub>0 p\<^sub>1 < \<delta>" "set ps = ps\<^sub>L \<union> ps\<^sub>R"
	+ assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
	+ assumes "ps' = filter (\<lambda>p. l - \<delta> < fst p \<and> fst p < l + \<delta>) ps"
	+ shows "p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<in> set ps'"
	+proof (rule ccontr)
	+ assume "\<not> (p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<in> set ps')"
	+ then consider (A) "p\<^sub>0 \<notin> set ps' \<and> p\<^sub>1 \<notin> set ps'"
	+ \| (B) "p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<notin> set ps'"
	+ \| (C) "p\<^sub>0 \<notin> set ps' \<and> p\<^sub>1 \<in> set ps'"
	+ by blast
	+ thus False
	+ proof cases
	+ case A
	+ hence "fst p\<^sub>0 \<le> l - \<delta> \<or> l + \<delta> \<le> fst p\<^sub>0" "fst p\<^sub>1 \<le> l - \<delta> \<or> l + \<delta> \<le> fst p\<^sub>1"
	+ using assms(1,2,5,8) by auto
	+ hence "fst p\<^sub>0 \<le> l - \<delta>" "l + \<delta> \<le> fst p\<^sub>1"
	+ using assms(1,2,6,7) by force+
	+ hence "\<delta> \<le> dist (fst p\<^sub>0) (fst p\<^sub>1)"
	+ using dist_real_def by simp
	+ hence "\<delta> \<le> dist p\<^sub>0 p\<^sub>1"
	+ using dist_fst_le[of p\<^sub>0 p\<^sub>1] by (auto split: prod.splits)
	+ then show ?thesis
	+ using assms(4) by fastforce
	+ next
	+ case B
	+ hence "fst p\<^sub>1 \<le> l - \<delta> \<or> l + \<delta> \<le> fst p\<^sub>1"
	+ using assms(2,5,8) by auto
	+ hence "l + \<delta> \<le> fst p\<^sub>1"
	+ using assms(2,7) by auto
	+ moreover have "fst p\<^sub>0 \<le> l"
	+ using assms(1,6) by simp
	+ ultimately have "\<delta> \<le> dist (fst p\<^sub>0) (fst p\<^sub>1)"
	+ using dist_real_def by simp
	+ hence "\<delta> \<le> dist p\<^sub>0 p\<^sub>1"
	+ using dist_fst_le[of p\<^sub>0 p\<^sub>1] less_le_trans by (auto split: prod.splits)
	+ thus ?thesis
	+ using assms(4) by simp
	+ next
	+ case C
	+ hence "fst p\<^sub>0 \<le> l - \<delta> \<or> l + \<delta> \<le> fst p\<^sub>0"
	+ using assms(1,2,5,8) by auto
	+ hence "fst p\<^sub>0 \<le> l - \<delta>"
	+ using assms(1,6) by auto
	+ moreover have "l \<le> fst p\<^sub>1"
	+ using assms(2,7) by simp
	+ ultimately have "\<delta> \<le> dist (fst p\<^sub>0) (fst p\<^sub>1)"
	+ using dist_real_def by simp
	+ hence "\<delta> \<le> dist p\<^sub>0 p\<^sub>1"
	+ using dist_fst_le[of p\<^sub>0 p\<^sub>1] less_le_trans by (auto split: prod.splits)
	+ thus ?thesis
	+ using assms(4) by simp
	+ qed
	+qed
	+
	+lemma set_band_filter:
	+ fixes \<delta> :: real and ps :: "point list"
	+ assumes "p\<^sub>0 \<in> set ps" "p\<^sub>1 \<in> set ps" "p\<^sub>0 \<noteq> p\<^sub>1" "dist p\<^sub>0 p\<^sub>1 < \<delta>" "set ps = ps\<^sub>L \<union> ps\<^sub>R"
	+ assumes "sparse \<delta> ps\<^sub>L" "sparse \<delta> ps\<^sub>R"
	+ assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
	+ assumes "ps' = filter (\<lambda>p. l - \<delta> < fst p \<and> fst p < l + \<delta>) ps"
	+ shows "p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<in> set ps'"
	+proof -
	+ have "p\<^sub>0 \<notin> ps\<^sub>L \<or> p\<^sub>1 \<notin> ps\<^sub>L" "p\<^sub>0 \<notin> ps\<^sub>R \<or> p\<^sub>1 \<notin> ps\<^sub>R"
	+ using assms(3,4,6,7) sparse_def by force+
	+ then consider (A) "p\<^sub>0 \<in> ps\<^sub>L \<and> p\<^sub>1 \<in> ps\<^sub>R" \| (B) "p\<^sub>0 \<in> ps\<^sub>R \<and> p\<^sub>1 \<in> ps\<^sub>L"
	+ using assms(1,2,5) by auto
	+ thus ?thesis
	+ proof cases
	+ case A
	+ thus ?thesis
	+ using set_band_filter_aux assms(3,4,5,8,9,10) by (auto split: prod.splits)
	+ next
	+ case B
	+ moreover have "dist p\<^sub>1 p\<^sub>0 < \<delta>"
	+ using assms(4) dist_commute by metis
	+ ultimately show ?thesis
	+ using set_band_filter_aux assms(3)[symmetric] assms(5,8,9,10) by (auto split: prod.splits)
	+ qed
	+qed
	+
	+subsubsection "2D-Boxes and Points"
	+
	+lemma cbox_2D:
	+ fixes x\<^sub>0 :: real and y\<^sub>0 :: real
	+ shows "cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1) = { (x, y). x\<^sub>0 \<le> x \<and> x \<le> x\<^sub>1 \<and> y\<^sub>0 \<le> y \<and> y \<le> y\<^sub>1 }"
	+ by fastforce
	+
	+lemma mem_cbox_2D:
	+ fixes x :: real and y :: real
	+ shows "x\<^sub>0 \<le> x \<and> x \<le> x\<^sub>1 \<and> y\<^sub>0 \<le> y \<and> y \<le> y\<^sub>1 \<longleftrightarrow> (x, y) \<in> cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1)"
	+ by fastforce
	+
	+lemma cbox_top_un:
	+ fixes x\<^sub>0 :: real and y\<^sub>0 :: real
	+ assumes "y\<^sub>0 \<le> y\<^sub>1" "y\<^sub>1 \<le> y\<^sub>2"
	+ shows "cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1) \<union> cbox (x\<^sub>0, y\<^sub>1) (x\<^sub>1, y\<^sub>2) = cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>2)"
	+ using assms by auto
	+
	+lemma cbox_right_un:
	+ fixes x\<^sub>0 :: real and y\<^sub>0 :: real
	+ assumes "x\<^sub>0 \<le> x\<^sub>1" "x\<^sub>1 \<le> x\<^sub>2"
	+ shows "cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1) \<union> cbox (x\<^sub>1, y\<^sub>0) (x\<^sub>2, y\<^sub>1) = cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>2, y\<^sub>1)"
	+ using assms by auto
	+
	+lemma cbox_max_dist:
	+ assumes "p\<^sub>0 = (x, y)" "p\<^sub>1 = (x + \<delta>, y + \<delta>)"
	+ assumes "(x\<^sub>0, y\<^sub>0) \<in> cbox p\<^sub>0 p\<^sub>1" "(x\<^sub>1, y\<^sub>1) \<in> cbox p\<^sub>0 p\<^sub>1" "0 \<le> \<delta>"
	+ shows "dist (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1) \<le> sqrt 2 * \<delta>"
	+proof -
	+ have X: "dist x\<^sub>0 x\<^sub>1 \<le> \<delta>"
	+ using assms dist_real_def by auto
	+ have Y: "dist y\<^sub>0 y\<^sub>1 \<le> \<delta>"
	+ using assms dist_real_def by auto
	+
	+ have "dist (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1) = sqrt ((dist x\<^sub>0 x\<^sub>1)\<^sup>2 + (dist y\<^sub>0 y\<^sub>1)\<^sup>2)"
	+ using dist_Pair_Pair by auto
	+ also have "... \<le> sqrt (\<delta>\<^sup>2 + (dist y\<^sub>0 y\<^sub>1)\<^sup>2)"
	+ using X power_mono by fastforce
	+ also have "... \<le> sqrt (\<delta>\<^sup>2 + \<delta>\<^sup>2)"
	+ using Y power_mono by fastforce
	+ also have "... = sqrt 2 * sqrt (\<delta>\<^sup>2)"
	+ using real_sqrt_mult by simp
	+ also have "... = sqrt 2 * \<delta>"
	+ using assms(5) by simp
	+ finally show ?thesis .
	+qed
	+
	+subsubsection "Pigeonhole Argument"
	+
	+lemma card_le_1_if_pairwise_eq:
	+ assumes "\<forall>x \<in> S. \<forall>y \<in> S. x = y"
	+ shows "card S \<le> 1"
	+proof (rule ccontr)
	+ assume "\<not> card S \<le> 1"
	+ hence "2 \<le> card S"
	+ by simp
	+ then obtain T where *: "T \<subseteq> S \<and> card T = 2"
	+ using ex_card by metis
	+ then obtain x y where "x \<in> T \<and> y \<in> T \<and> x \<noteq> y"
	+ using card_2_exists by metis
	+ then show False
	+ using * assms by blast
	+qed
	+
	+lemma card_Int_if_either_in:
	+ assumes "\<forall>x \<in> S. \<forall>y \<in> S. x = y \<or> x \<notin> T \<or> y \<notin> T"
	+ shows "card (S \<inter> T) \<le> 1"
	+proof (rule ccontr)
	+ assume "\<not> (card (S \<inter> T) \<le> 1)"
	+ then obtain x y where *: "x \<in> S \<inter> T \<and> y \<in> S \<inter> T \<and> x \<noteq> y"
	+ by (meson card_le_1_if_pairwise_eq)
	+ hence "x \<in> T" "y \<in> T"
	+ by simp_all
	+ moreover have "x \<notin> T \<or> y \<notin> T"
	+ using assms * by auto
	+ ultimately show False
	+ by blast
	+qed
	+
	+lemma card_Int_Un_le_Sum_card_Int:
	+ assumes "finite S"
	+ shows "card (A \<inter> \<Union>S) \<le> (\<Sum>B \<in> S. card (A \<inter> B))"
	+ using assms
	+proof (induction "card S" arbitrary: S)
	+ case (Suc n)
	+ then obtain B T where *: "S = { B } \<union> T" "card T = n" "B \<notin> T"
	+ by (metis card_Suc_eq Suc_eq_plus1 insert_is_Un)
	+ hence "card (A \<inter> \<Union>S) = card (A \<inter> \<Union>({ B } \<union> T))"
	+ by blast
	+ also have "... \<le> card (A \<inter> B) + card (A \<inter> \<Union>T)"
	+ by (simp add: card_Un_le inf_sup_distrib1)
	+ also have "... \<le> card (A \<inter> B) + (\<Sum>B \<in> T. card (A \<inter> B))"
	+ using Suc * by simp
	+ also have "... \<le> (\<Sum>B \<in> S. card (A \<inter> B))"
	+ using Suc.prems * by simp
	+ finally show ?case .
	+qed simp
	+
	+lemma pigeonhole:
	+ assumes "finite T" "S \<subseteq> \<Union>T" "card T < card S"
	+ shows "\<exists>x \<in> S. \<exists>y \<in> S. \<exists>X \<in> T. x \<noteq> y \<and> x \<in> X \<and> y \<in> X"
	+proof (rule ccontr)
	+ assume "\<not> (\<exists>x \<in> S. \<exists>y \<in> S. \<exists>X \<in> T. x \<noteq> y \<and> x \<in> X \<and> y \<in> X)"
	+ hence *: "\<forall>X \<in> T. card (S \<inter> X) \<le> 1"
	+ using card_Int_if_either_in by metis
	+ have "card T < card (S \<inter> \<Union>T)"
	+ using Int_absorb2 assms by fastforce
	+ also have "... \<le> (\<Sum>X \<in> T. card (S \<inter> X))"
	+ using assms(1) card_Int_Un_le_Sum_card_Int by blast
	+ also have "... \<le> card T"
	+ using * sum_mono by fastforce
	+ finally show False by simp
	+qed
	+
	+subsubsection "Delta Sparse Points within a Square"
	+
	+lemma max_points_square:
	+ assumes "\<forall>p \<in> ps. p \<in> cbox (x, y) (x + \<delta>, y + \<delta>)" "sparse \<delta> ps" "0 \<le> \<delta>"
	+ shows "card ps \<le> 4"
	+proof (cases "\<delta> = 0")
	+ case True
	+ hence "{ (x, y) } = cbox (x, y) (x + \<delta>, y + \<delta>)"
	+ using cbox_def by simp
	+ hence "\<forall>p \<in> ps. p = (x, y)"
	+ using assms(1) by blast
	+ hence "\<forall>p \<in> ps. \<forall>q \<in> ps. p = q"
	+ apply (auto split: prod.splits) by (metis of_int_eq_iff)+
	+ thus ?thesis
	+ using card_le_1_if_pairwise_eq by force
	+next
	+ case False
	+ hence \<delta>: "0 < \<delta>"
	+ using assms(3) by simp
	+ show ?thesis
	+ proof (rule ccontr)
	+ assume A: "\<not> (card ps \<le> 4)"
	+ define PS where PS_def: "PS = (\<lambda>(x, y). (real_of_int x, real_of_int y)) ` ps"
	+ have "inj_on (\<lambda>(x, y). (real_of_int x, real_of_int y)) ps"
	+ using inj_on_def by fastforce
	+ hence *: "\<not> (card PS \<le> 4)"
	+ using A PS_def by (simp add: card_image)
	+
	+ let ?x' = "x + \<delta> / 2"
	+ let ?y' = "y + \<delta> / 2"
	+
	+ let ?ll = "cbox ( x , y ) (?x' , ?y' )"
	+ let ?lu = "cbox ( x , ?y') (?x' , y + \<delta>)"
	+ let ?rl = "cbox (?x', y ) ( x + \<delta>, ?y' )"
	+ let ?ru = "cbox (?x', ?y') ( x + \<delta>, y + \<delta>)"
	+
	+ let ?sq = "{ ?ll, ?lu, ?rl, ?ru }"
	+
	+ have card_le_4: "card ?sq \<le> 4"
	+ by (simp add: card_insert_le_m1)
	+
	+ have "cbox (x, y) (?x', y + \<delta>) = ?ll \<union> ?lu"
	+ using cbox_top_un assms(3) by auto
	+ moreover have "cbox (?x', y) (x + \<delta>, y + \<delta>) = ?rl \<union> ?ru"
	+ using cbox_top_un assms(3) by auto
	+ moreover have "cbox (x, y) (?x', y + \<delta>) \<union> cbox (?x', y) (x + \<delta>, y + \<delta>) = cbox (x, y) (x + \<delta>, y + \<delta>)"
	+ using cbox_right_un assms(3) by simp
	+ ultimately have "?ll \<union> ?lu \<union> ?rl \<union> ?ru = cbox (x, y) (x + \<delta>, y + \<delta>)"
	+ by blast
	+
	+ hence "PS \<subseteq> \<Union>(?sq)"
	+ using assms(1) PS_def by (auto split: prod.splits)
	+ moreover have "card ?sq < card PS"
	+ using * card_insert_le_m1 card_le_4 by linarith
	+ moreover have "finite ?sq"
	+ by simp
	+ ultimately have "\<exists>p\<^sub>0 \<in> PS. \<exists>p\<^sub>1 \<in> PS. \<exists>S \<in> ?sq. (p\<^sub>0 \<noteq> p\<^sub>1 \<and> p\<^sub>0 \<in> S \<and> p\<^sub>1 \<in> S)"
	+ using pigeonhole[of ?sq PS] by blast
	+ then obtain S p\<^sub>0 p\<^sub>1 where #: "p\<^sub>0 \<in> PS" "p\<^sub>1 \<in> PS" "S \<in> ?sq" "p\<^sub>0 \<noteq> p\<^sub>1" "p\<^sub>0 \<in> S" "p\<^sub>1 \<in> S"
	+ by blast
	+
	+ have D: "0 \<le> \<delta> / 2"
	+ using assms(3) by simp
	+ have LL: "\<forall>p\<^sub>0 \<in> ?ll. \<forall>p\<^sub>1 \<in> ?ll. dist p\<^sub>0 p\<^sub>1 \<le> sqrt 2 * (\<delta> / 2)"
	+ using cbox_max_dist[of "(x, y)" x y "(?x', ?y')" "\<delta> / 2"] D by auto
	+ have LU: "\<forall>p\<^sub>0 \<in> ?lu. \<forall>p\<^sub>1 \<in> ?lu. dist p\<^sub>0 p\<^sub>1 \<le> sqrt 2 * (\<delta> / 2)"
	+ using cbox_max_dist[of "(x, ?y')" x ?y' "(?x', y + \<delta>)" "\<delta> / 2"] D by auto
	+ have RL: "\<forall>p\<^sub>0 \<in> ?rl. \<forall>p\<^sub>1 \<in> ?rl. dist p\<^sub>0 p\<^sub>1 \<le> sqrt 2 * (\<delta> / 2)"
	+ using cbox_max_dist[of "(?x', y)" ?x' y "(x + \<delta>, ?y')" "\<delta> / 2"] D by auto
	+ have RU: "\<forall>p\<^sub>0 \<in> ?ru. \<forall>p\<^sub>1 \<in> ?ru. dist p\<^sub>0 p\<^sub>1 \<le> sqrt 2 * (\<delta> / 2)"
	+ using cbox_max_dist[of "(?x', ?y')" ?x' ?y' "(x + \<delta>, y + \<delta>)" "\<delta> / 2"] D by auto
	+
	+ have "\<forall>p\<^sub>0 \<in> S. \<forall>p\<^sub>1 \<in> S. dist p\<^sub>0 p\<^sub>1 \<le> sqrt 2 * (\<delta> / 2)"
	+ using # LL LU RL RU by blast
	+ hence "dist p\<^sub>0 p\<^sub>1 \<le> (sqrt 2 / 2) * \<delta>"
	+ using # by simp
	+ moreover have "(sqrt 2 / 2) * \<delta> < \<delta>"
	+ using sqrt2_less_2 \<delta> by simp
	+ ultimately have "dist p\<^sub>0 p\<^sub>1 < \<delta>"
	+ by simp
	+ moreover have "\<delta> \<le> dist p\<^sub>0 p\<^sub>1"
	+ using assms(2) # sparse_def PS_def by auto
	+ ultimately show False
	+ by simp
	+ qed
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Closest_Pair_Points/ROOT b/thys/Closest_Pair_Points/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Closest_Pair_Points/ROOT
	@@ -0,0 +1,10 @@
	+chapter AFP
	+
	+session Closest_Pair_Points (AFP) = Akra_Bazzi +
	+ options [timeout = 600]
	+ theories
	+ "Closest_Pair"
	+ "Closest_Pair_Alternative"
	+ document_files
	+ "root.bib"
	+ "root.tex"
	diff --git a/thys/Closest_Pair_Points/document/root.bib b/thys/Closest_Pair_Points/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Closest_Pair_Points/document/root.bib
	@@ -0,0 +1,20 @@
	+@string{Springer="Springer"}
	+@string{LNCS="LNCS"}
	+
	+@book{Algorithm-Design:2005,
	+ author = {Kleinberg, Jon and Tardos, Eva},
	+ title = {Algorithm Design},
	+ year = {2005},
	+ isbn = {0321295358},
	+ publisher = {Addison-Wesley Longman Publishing Co., Inc.},
	+ address = {Boston, MA, USA}
	+}
	+
	+@book{Introduction-to-Algorithms:2009,
	+ author = {Cormen, Thomas H. and Leiserson, Charles E. and Rivest, Ronald L. and Stein, Clifford},
	+ title = {Introduction to Algorithms, Third Edition},
	+ year = {2009},
	+ isbn = {0262033844, 9780262033848},
	+ edition = {3rd},
	+ publisher = {The MIT Press}
	+}
	diff --git a/thys/Closest_Pair_Points/document/root.tex b/thys/Closest_Pair_Points/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Closest_Pair_Points/document/root.tex
	@@ -0,0 +1,35 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage{isabelle,isabellesym}
	+
	+% this should be the last package used
	+\usepackage{pdfsetup}
	+
	+% urls in roman style, theory text in math-similar italics
	+\urlstyle{rm}
	+\isabellestyle{it}
	+
	+
	+\begin{document}
	+
	+\title{Closest Pair of Points Algorithms}
	+\author{Martin Rau and Tobias Nipkow}
	+\maketitle
	+
	+\begin{abstract}
	+This entry provides two related verified divide-and-conquer algorithms solving
	+the fundamental \textit{Closest Pair of Points} problem in Computational Geometry.
	+Functional correctness and the optimal running time of $\mathcal{O}(n \log n)$ are proved.
	+Executable code is generated which is empirically competitive with handwritten
	+reference implementations.
	+\end{abstract}
	+
	+\tableofcontents
	+\newpage
	+
	+% include generated text of all theories
	+\input{session}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	diff --git a/thys/Complex_Geometry/Angles.thy b/thys/Complex_Geometry/Angles.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Angles.thy
	@@ -0,0 +1,510 @@
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Angle between two vectors\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>In this section we introduce different measures of angle between two vectors (represented by complex numbers).\<close>
	+
	+theory Angles
	+imports More_Transcendental Canonical_Angle More_Complex
	+begin
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Oriented angle\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Oriented angle between two vectors (it is always in the interval $(-\pi, \pi]$).\<close>
	+definition ang_vec ("\<angle>") where
	+ [simp]: "\<angle> z1 z2 \<equiv> \<downharpoonright>arg z2 - arg z1\<downharpoonleft>"
	+
	+lemma ang_vec_bounded:
	+ shows "-pi < \<angle> z1 z2 \<and> \<angle> z1 z2 \<le> pi"
	+ by (simp add: canon_ang(1) canon_ang(2))
	+
	+lemma ang_vec_sym:
	+ assumes "\<angle> z1 z2 \<noteq> pi"
	+ shows "\<angle> z1 z2 = - \<angle> z2 z1"
	+ using assms
	+ unfolding ang_vec_def
	+ using canon_ang_uminus[of "arg z2 - arg z1"]
	+ by simp
	+
	+lemma ang_vec_sym_pi:
	+ assumes "\<angle> z1 z2 = pi"
	+ shows "\<angle> z1 z2 = \<angle> z2 z1"
	+ using assms
	+ unfolding ang_vec_def
	+ using canon_ang_uminus_pi[of "arg z2 - arg z1"]
	+ by simp
	+
	+lemma ang_vec_plus_pi1:
	+ assumes "\<angle> z1 z2 > 0"
	+ shows "\<downharpoonright>\<angle> z1 z2 + pi\<downharpoonleft> = \<angle> z1 z2 - pi"
	+proof (rule canon_ang_eqI)
	+ show "\<exists> x::int. \<angle> z1 z2 - pi - (\<angle> z1 z2 + pi) = 2 * real_of_int x * pi"
	+ by (rule_tac x="-1" in exI) auto
	+next
	+ show "- pi < \<angle> z1 z2 - pi \<and> \<angle> z1 z2 - pi \<le> pi"
	+ using assms
	+ unfolding ang_vec_def
	+ using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
	+ by auto
	+qed
	+
	+lemma ang_vec_plus_pi2:
	+ assumes "\<angle> z1 z2 \<le> 0"
	+ shows "\<downharpoonright>\<angle> z1 z2 + pi\<downharpoonleft> = \<angle> z1 z2 + pi"
	+proof (rule canon_ang_id)
	+ show "- pi < \<angle> z1 z2 + pi \<and> \<angle> z1 z2 + pi \<le> pi"
	+ using assms
	+ unfolding ang_vec_def
	+ using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
	+ by auto
	+qed
	+
	+lemma ang_vec_opposite1:
	+ assumes "z1 \<noteq> 0"
	+ shows "\<angle> (-z1) z2 = \<downharpoonright>\<angle> z1 z2 - pi\<downharpoonleft>"
	+proof-
	+ have "\<angle> (-z1) z2 = \<downharpoonright>arg z2 - (arg z1 + pi)\<downharpoonleft>"
	+ unfolding ang_vec_def
	+ using arg_uminus[OF assms]
	+ using canon_ang_arg[of z2, symmetric]
	+ using canon_ang_diff[of "arg z2" "arg z1 + pi", symmetric]
	+ by simp
	+ moreover
	+ have "\<downharpoonright>\<angle> z1 z2 - pi\<downharpoonleft> = \<downharpoonright>arg z2 - arg z1 - pi\<downharpoonleft>"
	+ using canon_ang_id[of pi, symmetric]
	+ using canon_ang_diff[of "arg z2 - arg z1" "pi", symmetric]
	+ by simp_all
	+ ultimately
	+ show ?thesis
	+ by (simp add: field_simps)
	+qed
	+
	+lemma ang_vec_opposite2:
	+ assumes "z2 \<noteq> 0"
	+ shows "\<angle> z1 (-z2) = \<downharpoonright>\<angle> z1 z2 + pi\<downharpoonleft>"
	+ unfolding ang_vec_def
	+ using arg_mult[of "-1" "z2"] assms
	+ using arg_complex_of_real_negative[of "-1"]
	+ using canon_ang_diff[of "arg (-1) + arg z2" "arg z1", symmetric]
	+ using canon_ang_sum[of "arg z2 - arg z1" "pi", symmetric]
	+ using canon_ang_id[of pi] canon_ang_arg[of z1]
	+ by (auto simp: algebra_simps)
	+
	+
	+lemma ang_vec_opposite_opposite:
	+ assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
	+ shows "\<angle> (-z1) (-z2) = \<angle> z1 z2"
	+proof-
	+ have "\<angle> (-z1) (-z2) = \<downharpoonright>\<downharpoonright>\<angle> z1 z2 + pi\<downharpoonleft> - \<downharpoonright>pi\<downharpoonleft>\<downharpoonleft>"
	+ using ang_vec_opposite1[OF assms(1)]
	+ using ang_vec_opposite2[OF assms(2)]
	+ using canon_ang_id[of pi, symmetric]
	+ by simp_all
	+ also have "... = \<downharpoonright>\<angle> z1 z2\<downharpoonleft>"
	+ by (subst canon_ang_diff[symmetric], simp)
	+ finally
	+ show ?thesis
	+ by (metis ang_vec_def canon_ang(1) canon_ang(2) canon_ang_id)
	+qed
	+
	+lemma ang_vec_opposite_opposite':
	+ assumes "z1 \<noteq> z" and "z2 \<noteq> z"
	+ shows "\<angle> (z - z1) (z - z2) = \<angle> (z1 - z) (z2 - z)"
	+using ang_vec_opposite_opposite[of "z - z1" "z - z2"] assms
	+by (simp add: field_simps del: ang_vec_def)
	+
	+text \<open>Cosine, scalar product and the law of cosines\<close>
	+
	+lemma cos_cmod_scalprod:
	+ shows "cmod z1 * cmod z2 * (cos (\<angle> z1 z2)) = Re (scalprod z1 z2)"
	+proof (cases "z1 = 0 \<or> z2 = 0")
	+ case True
	+ thus ?thesis
	+ by auto
	+next
	+ case False
	+ thus ?thesis
	+ by (simp add: cos_diff cos_arg sin_arg field_simps)
	+qed
	+
	+lemma cos0_scalprod0:
	+ assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
	+ shows "cos (\<angle> z1 z2) = 0 \<longleftrightarrow> scalprod z1 z2 = 0"
	+ using assms
	+ using cnj_mix_real[of z1 z2]
	+ using cos_cmod_scalprod[of z1 z2]
	+ by (auto simp add: complex_eq_if_Re_eq)
	+
	+lemma ortho_scalprod0:
	+ assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
	+ shows "\<angle> z1 z2 = pi/2 \<or> \<angle> z1 z2 = -pi/2 \<longleftrightarrow> scalprod z1 z2 = 0"
	+ using cos0_scalprod0[OF assms]
	+ using ang_vec_bounded[of z1 z2]
	+ using cos_0_iff_canon[of "\<angle> z1 z2"]
	+ by (metis cos_minus cos_pi_half divide_minus_left)
	+
	+lemma law_of_cosines:
	+ shows "(cdist B C)\<^sup>2 = (cdist A C)\<^sup>2 + (cdist A B)\<^sup>2 - 2(cdist A C)(cdist A B)*(cos (\<angle> (C-A) (B-A)))"
	+proof-
	+ let ?a = "C-B" and ?b = "C-A" and ?c = "B-A"
	+ have "?a = ?b - ?c"
	+ by simp
	+ hence "(cmod ?a)\<^sup>2 = (cmod (?b - ?c))\<^sup>2"
	+ by metis
	+ also have "... = Re (scalprod (?b-?c) (?b-?c))"
	+ by (simp add: cmod_square)
	+ also have "... = (cmod ?b)\<^sup>2 + (cmod ?c)\<^sup>2 - 2*Re (scalprod ?b ?c)"
	+ by (simp add: cmod_square field_simps)
	+ finally
	+ show ?thesis
	+ using cos_cmod_scalprod[of ?b ?c]
	+ by simp
	+qed
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Unoriented angle\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Convex unoriented angle between two vectors (it is always in the interval $[0, pi]$).\<close>
	+definition ang_vec_c ("\<angle>c") where
	+ [simp]:"\<angle>c z1 z2 \<equiv> abs (\<angle> z1 z2)"
	+
	+lemma ang_vec_c_sym:
	+ shows "\<angle>c z1 z2 = \<angle>c z2 z1"
	+ unfolding ang_vec_c_def
	+ using ang_vec_sym_pi[of z1 z2] ang_vec_sym[of z1 z2]
	+ by (cases "\<angle> z1 z2 = pi") auto
	+
	+lemma ang_vec_c_bounded: "0 \<le> \<angle>c z1 z2 \<and> \<angle>c z1 z2 \<le> pi"
	+ using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
	+ by auto
	+
	+text \<open>Cosine and scalar product\<close>
	+
	+lemma cos_c_: "cos (\<angle>c z1 z2) = cos (\<angle> z1 z2)"
	+ unfolding ang_vec_c_def
	+ by (smt cos_minus)
	+
	+lemma ortho_c_scalprod0:
	+ assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
	+ shows "\<angle>c z1 z2 = pi/2 \<longleftrightarrow> scalprod z1 z2 = 0"
	+proof-
	+ have "\<angle> z1 z2 = pi / 2 \<or> \<angle> z1 z2 = - pi / 2 \<longleftrightarrow> \<angle>c z1 z2 = pi/2"
	+ unfolding ang_vec_c_def
	+ using arctan
	+ by force
	+ thus ?thesis
	+ using ortho_scalprod0[OF assms]
	+ by simp
	+qed
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Acute angle\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Acute or right angle (non-obtuse) between two vectors (it is always in the interval $[0, \frac{\pi}{2}$]).
	+We will use this to measure angle between two circles, since it can always be acute (or right).\<close>
	+
	+definition acute_ang where
	+ [simp]: "acute_ang \<alpha> = (if \<alpha> > pi / 2 then pi - \<alpha> else \<alpha>)"
	+
	+definition ang_vec_a ("\<angle>a") where
	+ [simp]: "\<angle>a z1 z2 \<equiv> acute_ang (\<angle>c z1 z2)"
	+
	+lemma ang_vec_a_sym:
	+ "\<angle>a z1 z2 = \<angle>a z2 z1"
	+ unfolding ang_vec_a_def
	+ using ang_vec_c_sym
	+ by auto
	+
	+lemma ang_vec_a_opposite2:
	+ "\<angle>a z1 z2 = \<angle>a z1 (-z2)"
	+proof(cases "z2 = 0")
	+ case True
	+ thus ?thesis
	+ by (metis minus_zero)
	+next
	+ case False
	+ thus ?thesis
	+ proof(cases "\<angle> z1 z2 < -pi / 2")
	+ case True
	+ hence "\<angle> z1 z2 < 0"
	+ using pi_not_less_zero
	+ by linarith
	+ have "\<angle>a z1 z2 = pi + \<angle> z1 z2"
	+ using True \<open>\<angle> z1 z2 < 0\<close>
	+ unfolding ang_vec_a_def ang_vec_c_def ang_vec_a_def abs_real_def
	+ by auto
	+ moreover
	+ have "\<angle>a z1 (-z2) = pi + \<angle> z1 z2"
	+ unfolding ang_vec_a_def ang_vec_c_def abs_real_def
	+ using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
	+ using ang_vec_plus_pi2[of z1 z2] True \<open>\<angle> z1 z2 < 0\<close> \<open>z2 \<noteq> 0\<close>
	+ using ang_vec_opposite2[of z2 z1]
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by auto
	+ next
	+ case False
	+ show ?thesis
	+ proof (cases "\<angle> z1 z2 \<le> 0")
	+ case True
	+ have "\<angle>a z1 z2 = - \<angle> z1 z2"
	+ using \<open>\<not> \<angle> z1 z2 < - pi / 2\<close> True
	+ unfolding ang_vec_a_def ang_vec_c_def ang_vec_a_def abs_real_def
	+ by auto
	+ moreover
	+ have "\<angle>a z1 (-z2) = - \<angle> z1 z2"
	+ using \<open>\<not> \<angle> z1 z2 < - pi / 2\<close> True
	+ unfolding ang_vec_a_def ang_vec_c_def abs_real_def
	+ using ang_vec_plus_pi2[of z1 z2]
	+ using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
	+ using \<open>z2 \<noteq> 0\<close> ang_vec_opposite2[of z2 z1]
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by simp
	+ next
	+ case False
	+ show ?thesis
	+ proof (cases "\<angle> z1 z2 < pi / 2")
	+ case True
	+ have "\<angle>a z1 z2 = \<angle> z1 z2"
	+ using \<open>\<not> \<angle> z1 z2 \<le> 0\<close> True
	+ unfolding ang_vec_a_def ang_vec_c_def ang_vec_a_def abs_real_def
	+ by auto
	+ moreover
	+ have "\<angle>a z1 (-z2) = \<angle> z1 z2"
	+ using \<open>\<not> \<angle> z1 z2 \<le> 0\<close> True
	+ unfolding ang_vec_a_def ang_vec_c_def abs_real_def
	+ using ang_vec_plus_pi1[of z1 z2]
	+ using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
	+ using \<open>z2 \<noteq> 0\<close> ang_vec_opposite2[of z2 z1]
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by simp
	+ next
	+ case False
	+ have "\<angle> z1 z2 > 0"
	+ using False
	+ by (metis less_linear less_trans pi_half_gt_zero)
	+ have "\<angle>a z1 z2 = pi - \<angle> z1 z2"
	+ using False \<open>\<angle> z1 z2 > 0\<close>
	+ unfolding ang_vec_a_def ang_vec_c_def ang_vec_a_def abs_real_def
	+ by auto
	+ moreover
	+ have "\<angle>a z1 (-z2) = pi - \<angle> z1 z2"
	+ unfolding ang_vec_a_def ang_vec_c_def abs_real_def
	+ using False \<open>\<angle> z1 z2 > 0\<close>
	+ using ang_vec_plus_pi1[of z1 z2]
	+ using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
	+ using \<open>z2 \<noteq> 0\<close> ang_vec_opposite2[of z2 z1]
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by auto
	+ qed
	+ qed
	+ qed
	+qed
	+
	+lemma ang_vec_a_opposite1:
	+ shows "\<angle>a z1 z2 = \<angle>a (-z1) z2"
	+ using ang_vec_a_sym[of "-z1" z2] ang_vec_a_opposite2[of z2 z1] ang_vec_a_sym[of z2 z1]
	+ by auto
	+
	+lemma ang_vec_a_scale1:
	+ assumes "k \<noteq> 0"
	+ shows "\<angle>a (cor k * z1) z2 = \<angle>a z1 z2"
	+proof (cases "k > 0")
	+ case True
	+ thus ?thesis
	+ unfolding ang_vec_a_def ang_vec_c_def ang_vec_def
	+ using arg_mult_real_positive[of k z1]
	+ by auto
	+next
	+ case False
	+ hence "k < 0"
	+ using assms
	+ by auto
	+ thus ?thesis
	+ using arg_mult_real_negative[of k z1]
	+ using ang_vec_a_opposite1[of z1 z2]
	+ unfolding ang_vec_a_def ang_vec_c_def ang_vec_def
	+ by simp
	+qed
	+
	+lemma ang_vec_a_scale2:
	+ assumes "k \<noteq> 0"
	+ shows "\<angle>a z1 (cor k * z2) = \<angle>a z1 z2"
	+ using ang_vec_a_sym[of z1 "complex_of_real k * z2"]
	+ using ang_vec_a_scale1[OF assms, of z2 z1]
	+ using ang_vec_a_sym[of z1 z2]
	+ by auto
	+
	+lemma ang_vec_a_scale:
	+ assumes "k1 \<noteq> 0" and "k2 \<noteq> 0"
	+ shows "\<angle>a (cor k1 * z1) (cor k2 * z2) = \<angle>a z1 z2"
	+ using ang_vec_a_scale1[OF assms(1)] ang_vec_a_scale2[OF assms(2)]
	+ by auto
	+
	+lemma ang_a_cnj_cnj:
	+ shows "\<angle>a z1 z2 = \<angle>a (cnj z1) (cnj z2)"
	+unfolding ang_vec_a_def ang_vec_c_def ang_vec_def
	+proof(cases "arg z1 \<noteq> pi \<and> arg z2 \<noteq> pi")
	+ case True
	+ thus "acute_ang \<bar>\<downharpoonright>arg z2 - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg (cnj z2) - arg (cnj z1)\<downharpoonleft>\<bar>"
	+ using arg_cnj_not_pi[of z1] arg_cnj_not_pi[of z2]
	+ apply (auto simp del:acute_ang_def)
	+ proof(cases "\<downharpoonright>arg z2 - arg z1\<downharpoonleft> = pi")
	+ case True
	+ thus "acute_ang \<bar>\<downharpoonright>arg z2 - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg z1 - arg z2\<downharpoonleft>\<bar>"
	+ using canon_ang_uminus_pi[of "arg z2 - arg z1"]
	+ by (auto simp add:field_simps)
	+ next
	+ case False
	+ thus "acute_ang \<bar>\<downharpoonright>arg z2 - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg z1 - arg z2\<downharpoonleft>\<bar>"
	+ using canon_ang_uminus[of "arg z2 - arg z1"]
	+ by (auto simp add:field_simps)
	+ qed
	+ next
	+ case False
	+ thus "acute_ang \<bar>\<downharpoonright>arg z2 - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg (cnj z2) - arg (cnj z1)\<downharpoonleft>\<bar>"
	+ proof(cases "arg z1 = pi")
	+ case False
	+ hence "arg z2 = pi"
	+ using \<open> \<not> (arg z1 \<noteq> pi \<and> arg z2 \<noteq> pi)\<close>
	+ by auto
	+ thus ?thesis
	+ using False
	+ using arg_cnj_not_pi[of z1] arg_cnj_pi[of z2]
	+ apply (auto simp del:acute_ang_def)
	+ proof(cases "arg z1 > 0")
	+ case True
	+ hence "-arg z1 \<le> 0"
	+ by auto
	+ thus "acute_ang \<bar>\<downharpoonright>pi - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>pi + arg z1\<downharpoonleft>\<bar>"
	+ using True canon_ang_plus_pi1[of "arg z1"]
	+ using arg_bounded[of z1] canon_ang_plus_pi2[of "-arg z1"]
	+ by (auto simp add:field_simps)
	+ next
	+ case False
	+ hence "-arg z1 \<ge> 0"
	+ by simp
	+ thus "acute_ang \<bar>\<downharpoonright>pi - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>pi + arg z1\<downharpoonleft>\<bar>"
	+ proof(cases "arg z1 = 0")
	+ case True
	+ thus ?thesis
	+ by (auto simp del:acute_ang_def)
	+ next
	+ case False
	+ hence "-arg z1 > 0"
	+ using \<open>-arg z1 \<ge> 0\<close>
	+ by auto
	+ thus ?thesis
	+ using False canon_ang_plus_pi1[of "-arg z1"]
	+ using arg_bounded[of z1] canon_ang_plus_pi2[of "arg z1"]
	+ by (auto simp add:field_simps)
	+ qed
	+ qed
	+ next
	+ case True
	+ thus ?thesis
	+ using arg_cnj_pi[of z1]
	+ apply (auto simp del:acute_ang_def)
	+ proof(cases "arg z2 = pi")
	+ case True
	+ thus "acute_ang \<bar>\<downharpoonright>arg z2 - pi\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg (cnj z2) - pi\<downharpoonleft>\<bar>"
	+ using arg_cnj_pi[of z2]
	+ by auto
	+ next
	+ case False
	+ thus "acute_ang \<bar>\<downharpoonright>arg z2 - pi\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg (cnj z2) - pi\<downharpoonleft>\<bar>"
	+ using arg_cnj_not_pi[of z2]
	+ apply (auto simp del:acute_ang_def)
	+ proof(cases "arg z2 > 0")
	+ case True
	+ hence "-arg z2 \<le> 0"
	+ by auto
	+ thus "acute_ang \<bar>\<downharpoonright>arg z2 - pi\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>- arg z2 - pi\<downharpoonleft>\<bar>"
	+ using True canon_ang_minus_pi1[of "arg z2"]
	+ using arg_bounded[of z2] canon_ang_minus_pi2[of "-arg z2"]
	+ by (auto simp add: field_simps)
	+ next
	+ case False
	+ hence "-arg z2 \<ge> 0"
	+ by simp
	+ thus "acute_ang \<bar>\<downharpoonright>arg z2 - pi\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>- arg z2 - pi\<downharpoonleft>\<bar>"
	+ proof(cases "arg z2 = 0")
	+ case True
	+ thus ?thesis
	+ by (auto simp del:acute_ang_def)
	+ next
	+ case False
	+ hence "-arg z2 > 0"
	+ using \<open>-arg z2 \<ge> 0\<close>
	+ by auto
	+ thus ?thesis
	+ using False canon_ang_minus_pi1[of "-arg z2"]
	+ using arg_bounded[of z2] canon_ang_minus_pi2[of "arg z2"]
	+ by (auto simp add:field_simps)
	+ qed
	+ qed
	+ qed
	+ qed
	+qed
	+
	+text \<open>Cosine and scalar product\<close>
	+
	+lemma ortho_a_scalprod0:
	+ assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
	+ shows "\<angle>a z1 z2 = pi/2 \<longleftrightarrow> scalprod z1 z2 = 0"
	+ unfolding ang_vec_a_def
	+ using assms ortho_c_scalprod0[of z1 z2]
	+ by auto
	+
	+declare ang_vec_c_def[simp del]
	+
	+lemma cos_a_c: "cos (\<angle>a z1 z2) = abs (cos (\<angle>c z1 z2))"
	+proof-
	+ have "0 \<le> \<angle>c z1 z2" "\<angle>c z1 z2 \<le> pi"
	+ using ang_vec_c_bounded[of z1 z2]
	+ by auto
	+ show ?thesis
	+ proof (cases "\<angle>c z1 z2 = pi/2")
	+ case True
	+ thus ?thesis
	+ unfolding ang_vec_a_def acute_ang_def
	+ by (smt cos_pi_half pi_def pi_half)
	+ next
	+ case False
	+ show ?thesis
	+ proof (cases "\<angle>c z1 z2 < pi / 2")
	+ case True
	+ thus ?thesis
	+ using `0 \<le> \<angle>c z1 z2`
	+ using cos_gt_zero_pi[of "\<angle>c z1 z2"]
	+ unfolding ang_vec_a_def
	+ by simp
	+ next
	+ case False
	+ hence "\<angle>c z1 z2 > pi/2"
	+ using `\<angle>c z1 z2 \<noteq> pi/2`
	+ by simp
	+ hence "cos (\<angle>c z1 z2) < 0"
	+ using `\<angle>c z1 z2 \<le> pi`
	+ using cos_lt_zero_on_pi2_pi[of "\<angle>c z1 z2"]
	+ by simp
	+ thus ?thesis
	+ using `\<angle>c z1 z2 > pi/2`
	+ unfolding ang_vec_a_def
	+ by simp
	+ qed
	+ qed
	+qed
	+
	+end
	diff --git a/thys/Complex_Geometry/Canonical_Angle.thy b/thys/Complex_Geometry/Canonical_Angle.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Canonical_Angle.thy
	@@ -0,0 +1,361 @@
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Canonical angle\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Canonize any angle to $(-\pi, \pi]$ (taking account of $2\pi$ periodicity of @{term sin} and
	+@{term cos}). With this function, for example, multiplicative properties of @{term arg} for complex
	+numbers can easily be expressed and proved.\<close>
	+
	+theory Canonical_Angle
	+imports More_Transcendental
	+begin
	+
	+
	+abbreviation canon_ang_P where
	+ "canon_ang_P \<alpha> \<alpha>' \<equiv> (-pi < \<alpha>' \<and> \<alpha>' \<le> pi) \<and> (\<exists> k::int. \<alpha> - \<alpha>' = 2kpi)"
	+
	+definition canon_ang :: "real \<Rightarrow> real" ("\<downharpoonright>_\<downharpoonleft>") where
	+ "\<downharpoonright>\<alpha>\<downharpoonleft> = (THE \<alpha>'. canon_ang_P \<alpha> \<alpha>')"
	+
	+text \<open>There is a canonical angle for every angle.\<close>
	+lemma canon_ang_ex:
	+ shows "\<exists> \<alpha>'. canon_ang_P \<alpha> \<alpha>'"
	+proof-
	+ have ***: "\<forall> \<alpha>::real. \<exists> \<alpha>'. 0 < \<alpha>' \<and> \<alpha>' \<le> 1 \<and> (\<exists> k::int. \<alpha>' = \<alpha> - k)"
	+ proof
	+ fix \<alpha>::real
	+ show "\<exists>\<alpha>'>0. \<alpha>' \<le> 1 \<and> (\<exists>k::int. \<alpha>' = \<alpha> - k)"
	+ proof (cases "\<alpha> = floor \<alpha>")
	+ case True
	+ thus ?thesis
	+ by (rule_tac x="\<alpha> - floor \<alpha> + 1" in exI, auto) (rule_tac x="floor \<alpha> - 1" in exI, auto)
	+ next
	+ case False
	+ thus ?thesis
	+ using real_of_int_floor_ge_diff_one[of "\<alpha>"]
	+ using of_int_floor_le[of "\<alpha>"]
	+ by (rule_tac x="\<alpha> - floor \<alpha>" in exI) smt
	+ qed
	+ qed
	+
	+ have *: "\<forall> \<alpha>::real. \<exists> \<alpha>'. 0 < \<alpha>' \<and> \<alpha>' \<le> 2 \<and> (\<exists> k::int. \<alpha> - \<alpha>' = 2k - 1)"
	+ proof
	+ fix \<alpha>::real
	+ from ***[rule_format, of "(\<alpha> + 1) /2"]
	+ obtain \<alpha>' and k::int where "0 < \<alpha>'" "\<alpha>' \<le> 1" "\<alpha>' = (\<alpha> + 1)/2 - k"
	+ by force
	+ hence "0 < \<alpha>'" "\<alpha>' \<le> 1" "\<alpha>' = \<alpha>/2 - k + 1/2"
	+ by auto
	+ thus "\<exists>\<alpha>'>0. \<alpha>' \<le> 2 \<and> (\<exists>k::int. \<alpha> - \<alpha>' = real_of_int (2 * k - 1))"
	+ by (rule_tac x="2*\<alpha>'" in exI) auto
	+ qed
	+ have : "\<forall> \<alpha>::real. \<exists> \<alpha>'. -1 < \<alpha>' \<and> \<alpha>' \<le> 1 \<and> (\<exists> k::int. \<alpha> - \<alpha>' = 2k)"
	+ proof
	+ fix \<alpha>::real
	+ from ** obtain \<alpha>' and k :: int where
	+ "0 < \<alpha>' \<and> \<alpha>' \<le> 2 \<and> \<alpha> - \<alpha>' = 2*k - 1"
	+ by force
	+ thus "\<exists>\<alpha>'>-1. \<alpha>' \<le> 1 \<and> (\<exists>k. \<alpha> - \<alpha>' = real_of_int (2 * (k::int)))"
	+ by (rule_tac x="\<alpha>' - 1" in exI) (auto simp add: field_simps)
	+ qed
	+ obtain \<alpha>' k where 1: "\<alpha>' >- 1 \<and> \<alpha>' \<le> 1" and 2: "\<alpha> / pi - \<alpha>' = real_of_int (2 * k)"
	+ using *[rule_format, of "\<alpha> / pi"]
	+ by auto
	+ have "\<alpha>'pi > -pi \<and> \<alpha>'pi \<le> pi"
	+ using 1
	+ by (smt mult.commute mult_le_cancel_left1 mult_minus_right pi_gt_zero)
	+ moreover
	+ have "\<alpha> - \<alpha>'pi = 2 real_of_int k * pi"
	+ using 2
	+ by (auto simp add: field_simps)
	+ ultimately
	+ show ?thesis
	+ by auto
	+qed
	+
	+text \<open>Canonical angle of any angle is unique.\<close>
	+lemma canon_ang_unique:
	+ assumes "canon_ang_P \<alpha> \<alpha>\<^sub>1" and "canon_ang_P \<alpha> \<alpha>\<^sub>2"
	+ shows "\<alpha>\<^sub>1 = \<alpha>\<^sub>2"
	+proof-
	+ obtain k1::int where "\<alpha> - \<alpha>\<^sub>1 = 2k1pi"
	+ using assms(1)
	+ by auto
	+ obtain k2::int where "\<alpha> - \<alpha>\<^sub>2 = 2k2pi"
	+ using assms(2)
	+ by auto
	+ hence : "-\<alpha>\<^sub>1 + \<alpha>\<^sub>2 = 2(k1 - k2)*pi"
	+ using \<open>\<alpha> - \<alpha>\<^sub>1 = 2k1pi\<close>
	+ by (simp add:field_simps)
	+ moreover
	+ have "-\<alpha>\<^sub>1 + \<alpha>\<^sub>2 < 2 * pi" "-\<alpha>\<^sub>1 + \<alpha>\<^sub>2 > -2*pi"
	+ using assms
	+ by auto
	+ ultimately
	+ have "-\<alpha>\<^sub>1 + \<alpha>\<^sub>2 = 0"
	+ using mult_less_cancel_right[of "-2" pi "real_of_int(2 * (k1 - k2))"]
	+ by auto
	+ thus ?thesis
	+ by auto
	+qed
	+
	+text \<open>Canonical angle is always in $(-\pi, \pi]$ and differs from the starting angle by $2k\pi$.\<close>
	+lemma canon_ang:
	+ shows "-pi < \<downharpoonright>\<alpha>\<downharpoonleft>" and "\<downharpoonright>\<alpha>\<downharpoonleft> \<le> pi" and "\<exists> k::int. \<alpha> - \<downharpoonright>\<alpha>\<downharpoonleft> = 2kpi"
	+proof-
	+ obtain \<alpha>' where "canon_ang_P \<alpha> \<alpha>'"
	+ using canon_ang_ex[of \<alpha>]
	+ by auto
	+ have "canon_ang_P \<alpha> \<downharpoonright>\<alpha>\<downharpoonleft>"
	+ unfolding canon_ang_def
	+ proof (rule theI[where a="\<alpha>'"])
	+ show "canon_ang_P \<alpha> \<alpha>'"
	+ by fact
	+ next
	+ fix \<alpha>''
	+ assume "canon_ang_P \<alpha> \<alpha>''"
	+ thus "\<alpha>'' = \<alpha>'"
	+ using \<open>canon_ang_P \<alpha> \<alpha>'\<close>
	+ using canon_ang_unique[of \<alpha>' \<alpha> \<alpha>'']
	+ by simp
	+ qed
	+ thus "-pi < \<downharpoonright>\<alpha>\<downharpoonleft>" "\<downharpoonright>\<alpha>\<downharpoonleft> \<le> pi" "\<exists> k::int. \<alpha> - \<downharpoonright>\<alpha>\<downharpoonleft> = 2kpi"
	+ by auto
	+qed
	+
	+text \<open>Angles in $(-\pi, \pi]$ are already canonical.\<close>
	+lemma canon_ang_id:
	+ assumes "-pi < \<alpha> \<and> \<alpha> \<le> pi"
	+ shows "\<downharpoonright>\<alpha>\<downharpoonleft> = \<alpha>"
	+ using assms
	+ using canon_ang_unique[of "canon_ang \<alpha>" \<alpha> \<alpha>] canon_ang[of \<alpha>]
	+ by auto
	+
	+text \<open>Angles that differ by $2k\pi$ have equal canonical angles.\<close>
	+lemma canon_ang_eq:
	+ assumes "\<exists> k::int. \<alpha>\<^sub>1 - \<alpha>\<^sub>2 = 2kpi"
	+ shows "\<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft> = \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft>"
	+proof-
	+ obtain k'::int where : "- pi < \<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft>" "\<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft> \<le> pi" "\<alpha>\<^sub>1 - \<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft> = 2 k' * pi"
	+ using canon_ang[of \<alpha>\<^sub>1]
	+ by auto
	+
	+ obtain k''::int where *: "- pi < \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft>" "\<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft> \<le> pi" "\<alpha>\<^sub>2 - \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft> = 2 k'' * pi"
	+ using canon_ang[of \<alpha>\<^sub>2]
	+ by auto
	+
	+ obtain k::int where **: "\<alpha>\<^sub>1 - \<alpha>\<^sub>2 = 2k*pi"
	+ using assms
	+ by auto
	+
	+ have "\<exists>m::int. \<alpha>\<^sub>1 - \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft> = 2 * m * pi"
	+ using (3) *
	+ by (rule_tac x="k+k''" in exI) (auto simp add: field_simps)
	+
	+ thus ?thesis
	+ using canon_ang_unique[of "\<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft>" \<alpha>\<^sub>1 "\<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft>"] * **
	+ by auto
	+qed
	+
	+text \<open>Introduction and elimination rules\<close>
	+lemma canon_ang_eqI:
	+ assumes "\<exists>k::int. \<alpha>' - \<alpha> = 2 * k * pi" and "- pi < \<alpha>' \<and> \<alpha>' \<le> pi"
	+ shows "\<downharpoonright>\<alpha>\<downharpoonleft> = \<alpha>'"
	+ using assms
	+ using canon_ang_eq[of \<alpha>' \<alpha>]
	+ using canon_ang_id[of \<alpha>']
	+ by auto
	+
	+lemma canon_ang_eqE:
	+ assumes "\<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft> = \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft>"
	+ shows "\<exists> (k::int). \<alpha>\<^sub>1 - \<alpha>\<^sub>2 = 2 k pi"
	+proof-
	+ obtain k1 k2 :: int where
	+ "\<alpha>\<^sub>1 - \<downharpoonright>\<alpha>\<^sub>1\<downharpoonleft> = 2 * k1 * pi"
	+ "\<alpha>\<^sub>2 - \<downharpoonright>\<alpha>\<^sub>2\<downharpoonleft> = 2 * k2 * pi"
	+ using canon_ang[of \<alpha>\<^sub>1] canon_ang[of \<alpha>\<^sub>2]
	+ by auto
	+ thus ?thesis
	+ using assms
	+ by (rule_tac x="k1 - k2" in exI) (auto simp add: field_simps)
	+qed
	+
	+text \<open>Canonical angle of opposite angle\<close>
	+
	+lemma canon_ang_uminus:
	+ assumes "\<downharpoonright>\<alpha>\<downharpoonleft> \<noteq> pi"
	+ shows "\<downharpoonright>-\<alpha>\<downharpoonleft> = -\<downharpoonright>\<alpha>\<downharpoonleft>"
	+proof (rule canon_ang_eqI)
	+ show "\<exists>x::int. - \<downharpoonright>\<alpha>\<downharpoonleft> - - \<alpha> = 2 * x * pi"
	+ using canon_ang(3)[of \<alpha>]
	+ by (metis minus_diff_eq minus_diff_minus)
	+next
	+ show "- pi < - \<downharpoonright>\<alpha>\<downharpoonleft> \<and> - \<downharpoonright>\<alpha>\<downharpoonleft> \<le> pi"
	+ using canon_ang(1)[of \<alpha>] canon_ang(2)[of \<alpha>] assms
	+ by auto
	+qed
	+
	+lemma canon_ang_uminus_pi:
	+ assumes "\<downharpoonright>\<alpha>\<downharpoonleft> = pi"
	+ shows "\<downharpoonright>-\<alpha>\<downharpoonleft> = \<downharpoonright>\<alpha>\<downharpoonleft>"
	+proof (rule canon_ang_eqI)
	+ obtain k::int where "\<alpha> - \<downharpoonright>\<alpha>\<downharpoonleft> = 2 * k * pi"
	+ using canon_ang(3)[of \<alpha>]
	+ by auto
	+ thus "\<exists>x::int. \<downharpoonright>\<alpha>\<downharpoonleft> - - \<alpha> = 2 * x * pi"
	+ using assms
	+ by (rule_tac x="k+(1::int)" in exI) (auto simp add: field_simps)
	+next
	+ show "- pi < \<downharpoonright>\<alpha>\<downharpoonleft> \<and> \<downharpoonright>\<alpha>\<downharpoonleft> \<le> pi"
	+ using assms
	+ by auto
	+qed
	+
	+text \<open>Canonical angle of difference of two angles\<close>
	+lemma canon_ang_diff:
	+ shows "\<downharpoonright>\<alpha> - \<beta>\<downharpoonleft> = \<downharpoonright>\<downharpoonright>\<alpha>\<downharpoonleft> - \<downharpoonright>\<beta>\<downharpoonleft>\<downharpoonleft>"
	+proof (rule canon_ang_eq)
	+ show "\<exists>x::int. \<alpha> - \<beta> - (\<downharpoonright>\<alpha>\<downharpoonleft> - \<downharpoonright>\<beta>\<downharpoonleft>) = 2 * x * pi"
	+ proof-
	+ obtain k1::int where "\<alpha> - \<downharpoonright>\<alpha>\<downharpoonleft> = 2k1pi"
	+ using canon_ang(3)
	+ by auto
	+ moreover
	+ obtain k2::int where "\<beta> - \<downharpoonright>\<beta>\<downharpoonleft> = 2k2pi"
	+ using canon_ang(3)
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by (rule_tac x="k1 - k2" in exI) (auto simp add: field_simps)
	+ qed
	+qed
	+
	+text \<open>Canonical angle of sum of two angles\<close>
	+lemma canon_ang_sum:
	+ shows "\<downharpoonright>\<alpha> + \<beta>\<downharpoonleft> = \<downharpoonright>\<downharpoonright>\<alpha>\<downharpoonleft> + \<downharpoonright>\<beta>\<downharpoonleft>\<downharpoonleft>"
	+proof (rule canon_ang_eq)
	+ show "\<exists>x::int. \<alpha> + \<beta> - (\<downharpoonright>\<alpha>\<downharpoonleft> + \<downharpoonright>\<beta>\<downharpoonleft>) = 2 * x * pi"
	+ proof-
	+ obtain k1::int where "\<alpha> - \<downharpoonright>\<alpha>\<downharpoonleft> = 2k1pi"
	+ using canon_ang(3)
	+ by auto
	+ moreover
	+ obtain k2::int where "\<beta> - \<downharpoonright>\<beta>\<downharpoonleft> = 2k2pi"
	+ using canon_ang(3)
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by (rule_tac x="k1 + k2" in exI) (auto simp add: field_simps)
	+ qed
	+qed
	+
	+text \<open>Canonical angle of angle from $(0, 2\pi]$ shifted by $\pi$\<close>
	+
	+lemma canon_ang_plus_pi1:
	+ assumes "0 < \<alpha>" and "\<alpha> \<le> 2*pi"
	+ shows "\<downharpoonright>\<alpha> + pi\<downharpoonleft> = \<alpha> - pi"
	+proof (rule canon_ang_eqI)
	+ show "\<exists> x::int. \<alpha> - pi - (\<alpha> + pi) = 2 * x * pi"
	+ by (rule_tac x="-1" in exI) auto
	+next
	+ show "- pi < \<alpha> - pi \<and> \<alpha> - pi \<le> pi"
	+ using assms
	+ by auto
	+qed
	+
	+lemma canon_ang_minus_pi1:
	+ assumes "0 < \<alpha>" and "\<alpha> \<le> 2*pi"
	+ shows "\<downharpoonright>\<alpha> - pi\<downharpoonleft> = \<alpha> - pi"
	+proof (rule canon_ang_id)
	+ show "- pi < \<alpha> - pi \<and> \<alpha> - pi \<le> pi"
	+ using assms
	+ by auto
	+qed
	+
	+text \<open>Canonical angle of angles from $(-2\pi, 0]$ shifted by $\pi$\<close>
	+
	+lemma canon_ang_plus_pi2:
	+ assumes "-2*pi < \<alpha>" and "\<alpha> \<le> 0"
	+ shows "\<downharpoonright>\<alpha> + pi\<downharpoonleft> = \<alpha> + pi"
	+proof (rule canon_ang_id)
	+ show "- pi < \<alpha> + pi \<and> \<alpha> + pi \<le> pi"
	+ using assms
	+ by auto
	+qed
	+
	+lemma canon_ang_minus_pi2:
	+ assumes "-2*pi < \<alpha>" and "\<alpha> \<le> 0"
	+ shows "\<downharpoonright>\<alpha> - pi\<downharpoonleft> = \<alpha> + pi"
	+proof (rule canon_ang_eqI)
	+ show "\<exists> x::int. \<alpha> + pi - (\<alpha> - pi) = 2 * x * pi"
	+ by (rule_tac x="1" in exI) auto
	+next
	+ show "- pi < \<alpha> + pi \<and> \<alpha> + pi \<le> pi"
	+ using assms
	+ by auto
	+qed
	+
	+text \<open>Canonical angle of angle in $(\pi, 3\pi]$.\<close>
	+lemma canon_ang_pi_3pi:
	+ assumes "pi < \<alpha>" and "\<alpha> \<le> 3 * pi"
	+ shows "\<downharpoonright>\<alpha>\<downharpoonleft> = \<alpha> - 2*pi"
	+proof-
	+ have "\<exists>x. - pi = pi * real_of_int x"
	+ by (rule_tac x="-1" in exI, simp)
	+ thus ?thesis
	+ using assms canon_ang_eqI[of "\<alpha> - 2*pi" "\<alpha>"]
	+ by auto
	+qed
	+
	+text \<open>Canonical angle of angle in $(-3\pi, -\pi]$.\<close>
	+lemma canon_ang_minus_3pi_minus_pi:
	+ assumes "-3*pi < \<alpha>" and "\<alpha> \<le> -pi"
	+ shows "\<downharpoonright>\<alpha>\<downharpoonleft> = \<alpha> + 2*pi"
	+proof-
	+ have "\<exists>x. pi = pi * real_of_int x"
	+ by (rule_tac x="1" in exI, simp)
	+ thus ?thesis
	+ using assms canon_ang_eqI[of "\<alpha> + 2*pi" "\<alpha>"]
	+ by auto
	+qed
	+
	+text \<open>Canonical angles for some special angles\<close>
	+
	+lemma zero_canonical [simp]:
	+ shows "\<downharpoonright>0\<downharpoonleft> = 0"
	+ using canon_ang_eqI[of 0 0]
	+ by simp
	+
	+lemma pi_canonical [simp]:
	+ shows "\<downharpoonright>pi\<downharpoonleft> = pi"
	+ by (simp add: canon_ang_id)
	+
	+lemma two_pi_canonical [simp]:
	+ shows "\<downharpoonright>2 * pi\<downharpoonleft> = 0"
	+ using canon_ang_plus_pi1[of "pi"]
	+ by simp
	+
	+text \<open>Canonization preserves sine and cosine\<close>
	+lemma canon_ang_sin [simp]:
	+ shows "sin \<downharpoonright>\<alpha>\<downharpoonleft> = sin \<alpha>"
	+proof-
	+ obtain x::int where "\<alpha> = \<downharpoonright>\<alpha>\<downharpoonleft> + pi * (x * 2)"
	+ using canon_ang(3)[of \<alpha>]
	+ by (auto simp add: field_simps)
	+ thus ?thesis
	+ using sin_periodic_int[of "\<downharpoonright>\<alpha>\<downharpoonleft>" x]
	+ by (simp add: field_simps)
	+qed
	+
	+lemma canon_ang_cos [simp]:
	+ shows "cos \<downharpoonright>\<alpha>\<downharpoonleft> = cos \<alpha>"
	+proof-
	+ obtain x::int where "\<alpha> = \<downharpoonright>\<alpha>\<downharpoonleft> + pi * (x * 2)"
	+ using canon_ang(3)[of \<alpha>]
	+ by (auto simp add: field_simps)
	+ thus ?thesis
	+ using cos_periodic_int[of "\<downharpoonright>\<alpha>\<downharpoonleft>" x]
	+ by (simp add: field_simps)
	+qed
	+
	+end
	diff --git a/thys/Complex_Geometry/Chordal_Metric.thy b/thys/Complex_Geometry/Chordal_Metric.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Chordal_Metric.thy
	@@ -0,0 +1,1725 @@
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Chordal Metric\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Riemann sphere can be made a metric space. We are going to introduce distance on Riemann sphere
	+and to prove that it is a metric space. The distance between two points on the sphere is defined as
	+the length of the chord that connects them. This metric can be used in formalization of elliptic
	+geometry.\<close>
	+
	+theory Chordal_Metric
	+ imports Homogeneous_Coordinates Riemann_Sphere Oriented_Circlines "HOL-Analysis.Inner_Product" "HOL-Analysis.Euclidean_Space"
	+begin
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Inner product and norm\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+definition inprod_cvec :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex" where
	+ [simp]: "inprod_cvec z w =
	+ (let (z1, z2) = z;
	+ (w1, w2) = w
	+ in vec_cnj (z1, z2) *\<^sub>v\<^sub>v (w1, w2))"
	+syntax
	+ "_inprod_cvec" :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex" ("\<langle>_,_\<rangle>")
	+translations
	+ "\<langle>z,w\<rangle>" == "CONST inprod_cvec z w"
	+
	+lemma real_inprod_cvec [simp]:
	+ shows "is_real \<langle>z,z\<rangle>"
	+ by (cases z, simp add: vec_cnj_def)
	+
	+lemma inprod_cvec_ge_zero [simp]:
	+ shows "Re \<langle>z,z\<rangle> \<ge> 0"
	+ by (cases z, simp add: vec_cnj_def)
	+
	+lemma inprod_cvec_bilinear1 [simp]:
	+ assumes "z' = k *\<^sub>s\<^sub>v z"
	+ shows "\<langle>z',w\<rangle> = cnj k * \<langle>z,w\<rangle>"
	+ using assms
	+ by (cases z, cases z', cases w) (simp add: vec_cnj_def field_simps)
	+
	+lemma inprod_cvec_bilinear2 [simp]:
	+ assumes "z' = k *\<^sub>s\<^sub>v z"
	+ shows "\<langle>w, z'\<rangle> = k * \<langle>w, z\<rangle>"
	+ using assms
	+ by (cases z, cases z', cases w) (simp add: vec_cnj_def field_simps)
	+
	+lemma inprod_cvec_g_zero [simp]:
	+ assumes "z \<noteq> vec_zero"
	+ shows "Re \<langle>z, z\<rangle> > 0"
	+proof-
	+ have "\<forall> a b. a \<noteq> 0 \<or> b \<noteq> 0 \<longrightarrow> 0 < (Re a * Re a + Im a * Im a) + (Re b * Re b + Im b * Im b)"
	+ by (smt complex_eq_0 not_sum_squares_lt_zero power2_eq_square)
	+ thus ?thesis
	+ using assms
	+ by (cases z, simp add: vec_cnj_def)
	+qed
	+
	+definition norm_cvec :: "complex_vec \<Rightarrow> real" where
	+ [simp]: "norm_cvec z = sqrt (Re \<langle>z,z\<rangle>)"
	+syntax
	+ "_norm_cvec" :: "complex_vec \<Rightarrow> complex" ("\<langle>_\<rangle>")
	+translations
	+ "\<langle>z\<rangle>" == "CONST norm_cvec z"
	+
	+lemma norm_cvec_square:
	+ shows "\<langle>z\<rangle>\<^sup>2 = Re (\<langle>z,z\<rangle>)"
	+ by (simp del: inprod_cvec_def)
	+
	+lemma norm_cvec_gt_0:
	+ assumes "z \<noteq> vec_zero"
	+ shows "\<langle>z\<rangle> > 0"
	+ using assms
	+ by (simp del: inprod_cvec_def)
	+
	+lemma norm_cvec_scale:
	+ assumes "z' = k *\<^sub>s\<^sub>v z"
	+ shows "\<langle>z'\<rangle>\<^sup>2 = Re (cnj k * k) * \<langle>z\<rangle>\<^sup>2"
	+ unfolding norm_cvec_square
	+ using inprod_cvec_bilinear1[OF assms, of z']
	+ using inprod_cvec_bilinear2[OF assms, of z]
	+ by (simp del: inprod_cvec_def add: field_simps)
	+
	+lift_definition inprod_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex" is inprod_cvec
	+ done
	+
	+lift_definition norm_hcoords :: "complex_homo_coords \<Rightarrow> real" is norm_cvec
	+ done
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Distance in $\mathbb{C}P^1$ - defined by Fubini-Study metric.\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Formula for the chordal distance between the two points can be given directly based
	+on the homogenous coordinates of their stereographic projections in the plane. This is
	+called the Fubini-Study metric.\<close>
	+
	+definition dist_fs_cvec :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> real" where [simp]:
	+ "dist_fs_cvec z1 z2 =
	+ (let (z1x, z1y) = z1;
	+ (z2x, z2y) = z2;
	+ num = (z1xz2y - z2xz1y) * (cnj z1xcnj z2y - cnj z2xcnj z1y);
	+ den = (z1xcnj z1x + z1ycnj z1y) * (z2xcnj z2x + z2ycnj z2y)
	+ in 2*sqrt(Re num / Re den))"
	+
	+lemma dist_fs_cvec_iff:
	+ assumes "z \<noteq> vec_zero" and "w \<noteq> vec_zero"
	+ shows "dist_fs_cvec z w = 2sqrt(1 - (cmod \<langle>z,w\<rangle>)\<^sup>2 / (\<langle>z\<rangle>\<^sup>2 \<langle>w\<rangle>\<^sup>2))"
	+proof-
	+ obtain z1 z2 w1 w2 where *: "z = (z1, z2)" "w = (w1, w2)"
	+ by (cases "z", cases "w") auto
	+ have 1: "2sqrt(1 - (cmod \<langle>z,w\<rangle>)\<^sup>2 / (\<langle>z\<rangle>\<^sup>2 \<langle>w\<rangle>\<^sup>2)) = 2sqrt((\<langle>z\<rangle>\<^sup>2 \<langle>w\<rangle>\<^sup>2 - (cmod \<langle>z,w\<rangle>)\<^sup>2) / (\<langle>z\<rangle>\<^sup>2 * \<langle>w\<rangle>\<^sup>2))"
	+ using norm_cvec_gt_0[of z] norm_cvec_gt_0[of w] assms
	+ by (simp add: field_simps)
	+
	+ have 2: "\<langle>z\<rangle>\<^sup>2 * \<langle>w\<rangle>\<^sup>2 = Re ((z1cnj z1 + z2cnj z2) * (w1cnj w1 + w2cnj w2))"
	+ using assms *
	+ by (simp add: vec_cnj_def)
	+
	+ have 3: "\<langle>z\<rangle>\<^sup>2 * \<langle>w\<rangle>\<^sup>2 - (cmod \<langle>z,w\<rangle>)\<^sup>2 = Re ((z1w2 - w1z2) * (cnj z1cnj w2 - cnj w1cnj z2))"
	+ apply (subst cmod_square, (subst norm_cvec_square)+)
	+ using *
	+ by (simp add: vec_cnj_def field_simps)
	+
	+ thus ?thesis
	+ using 1 2 3
	+ using *
	+ unfolding dist_fs_cvec_def Let_def
	+ by simp
	+qed
	+
	+lift_definition dist_fs_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> real" is dist_fs_cvec
	+ done
	+
	+lift_definition dist_fs :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> real" is dist_fs_hcoords
	+proof transfer
	+ fix z1 z2 z1' z2' :: complex_vec
	+ obtain z1x z1y z2x z2y z1'x z1'y z2'x z2'y where
	+ zz: "z1 = (z1x, z1y)" "z2 = (z2x, z2y)" "z1' = (z1'x, z1'y)" "z2' = (z2'x, z2'y)"
	+ by (cases "z1", cases "z2", cases "z1'", cases "z2'") blast
	+
	+ assume 1: "z1 \<noteq> vec_zero" "z2 \<noteq> vec_zero" "z1' \<noteq> vec_zero" "z2' \<noteq> vec_zero" "z1 \<approx>\<^sub>v z1'" "z2 \<approx>\<^sub>v z2'"
	+ then obtain k1 k2 where
	+ : "k1 \<noteq> 0" "z1' = k1 \<^sub>s\<^sub>v z1" and
	+ *: "k2 \<noteq> 0" "z2' = k2 \<^sub>s\<^sub>v z2"
	+ by auto
	+ have "(cmod \<langle>z1,z2\<rangle>)\<^sup>2 / (\<langle>z1\<rangle>\<^sup>2 * \<langle>z2\<rangle>\<^sup>2) = (cmod \<langle>z1',z2'\<rangle>)\<^sup>2 / (\<langle>z1'\<rangle>\<^sup>2 * \<langle>z2'\<rangle>\<^sup>2)"
	+ using \<open>k1 \<noteq> 0\<close> \<open>k2 \<noteq> 0\<close>
	+ using cmod_square[symmetric, of k1] cmod_square[symmetric, of k2]
	+ apply (subst norm_cvec_scale[OF *(2)])
	+ apply (subst norm_cvec_scale[OF **(2)])
	+ apply (subst inprod_cvec_bilinear1[OF *(2)])
	+ apply (subst inprod_cvec_bilinear2[OF **(2)])
	+ by (simp add: power2_eq_square)
	+ thus "dist_fs_cvec z1 z2 = dist_fs_cvec z1' z2'"
	+ using 1 dist_fs_cvec_iff
	+ by simp
	+qed
	+
	+lemma dist_fs_finite:
	+ shows "dist_fs (of_complex z1) (of_complex z2) = 2 * cmod(z1 - z2) / (sqrt (1+(cmod z1)\<^sup>2) * sqrt (1+(cmod z2)\<^sup>2))"
	+ apply transfer
	+ apply transfer
	+ apply (subst cmod_square)+
	+ apply (simp add: real_sqrt_divide cmod_def power2_eq_square)
	+ apply (subst real_sqrt_mult[symmetric])
	+ apply (simp add: field_simps)
	+ done
	+
	+lemma dist_fs_infinite1:
	+ shows "dist_fs (of_complex z1) \<infinity>\<^sub>h = 2 / sqrt (1+(cmod z1)\<^sup>2)"
	+ by (transfer, transfer) (subst cmod_square, simp add: real_sqrt_divide)
	+
	+lemma dist_fs_infinite2:
	+ shows "dist_fs \<infinity>\<^sub>h (of_complex z1) = 2 / sqrt (1+(cmod z1)\<^sup>2)"
	+ by (transfer, transfer) (subst cmod_square, simp add: real_sqrt_divide)
	+
	+lemma dist_fs_cvec_zero:
	+ assumes "z \<noteq> vec_zero" and "w \<noteq> vec_zero"
	+ shows "dist_fs_cvec z w = 0 \<longleftrightarrow> (cmod \<langle>z,w\<rangle>)\<^sup>2 = (\<langle>z\<rangle>\<^sup>2 * \<langle>w\<rangle>\<^sup>2)"
	+ using assms norm_cvec_gt_0[of z] norm_cvec_gt_0[of w]
	+ by (subst dist_fs_cvec_iff) auto
	+
	+lemma dist_fs_zero1 [simp]:
	+ shows "dist_fs z z = 0"
	+ by (transfer, transfer)
	+ (subst dist_fs_cvec_zero, simp, (subst norm_cvec_square)+, subst cmod_square, simp del: inprod_cvec_def)
	+
	+lemma dist_fs_zero2 [simp]:
	+ assumes "dist_fs z1 z2 = 0"
	+ shows "z1 = z2"
	+ using assms
	+proof (transfer, transfer)
	+ fix z w :: complex_vec
	+ obtain z1 z2 w1 w2 where *: "z = (z1, z2)" "w = (w1, w2)"
	+ by (cases "z", cases "w", auto)
	+ let ?x = "(z1w2 - w1z2) * (cnj z1cnj w2 - cnj w1cnj z2)"
	+ assume "z \<noteq> vec_zero" "w \<noteq> vec_zero" "dist_fs_cvec z w = 0"
	+ hence "(cmod \<langle>z,w\<rangle>)\<^sup>2 = \<langle>z\<rangle>\<^sup>2 * \<langle>w\<rangle>\<^sup>2"
	+ by (subst (asm) dist_fs_cvec_zero, simp_all)
	+ hence "Re ?x = 0"
	+ using *
	+ by (subst (asm) cmod_square) ((subst (asm) norm_cvec_square)+, simp add: vec_cnj_def field_simps)
	+ hence "?x = 0"
	+ using complex_mult_cnj_cmod[of "z1w2 - w1z2"] zero_complex.simps
	+ by (subst complex_eq_if_Re_eq[of ?x 0]) (simp add: power2_eq_square, simp, linarith)
	+ moreover
	+ have "z1 * w2 - w1 * z2 = 0 \<longleftrightarrow> cnj z1 * cnj w2 - cnj w1 * cnj z2 = 0"
	+ by (metis complex_cnj_diff complex_cnj_mult complex_cnj_zero_iff)
	+ ultimately
	+ show "z \<approx>\<^sub>v w"
	+ using * \<open>z \<noteq> vec_zero\<close> \<open>w \<noteq> vec_zero\<close>
	+ using complex_cvec_eq_mix[of z1 z2 w1 w2]
	+ by auto
	+qed
	+
	+lemma dist_fs_sym:
	+ shows "dist_fs z1 z2 = dist_fs z2 z1"
	+ by (transfer, transfer) (simp add: split_def field_simps)
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Triangle inequality for Fubini-Study metric\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+lemma dist_fs_triangle_finite:
	+ shows "cmod(a - b) / (sqrt (1+(cmod a)\<^sup>2) * sqrt (1+(cmod b)\<^sup>2)) \<le> cmod (a - c) / (sqrt (1+(cmod a)\<^sup>2) * sqrt (1+(cmod c)\<^sup>2)) + cmod (c - b) / (sqrt (1+(cmod b)\<^sup>2) * sqrt (1+(cmod c)\<^sup>2))"
	+proof-
	+ let ?cc = "1+(cmod c)\<^sup>2" and ?bb = "1+(cmod b)\<^sup>2" and ?aa = "1+(cmod a)\<^sup>2"
	+ have "sqrt ?cc > 0" "sqrt ?aa > 0" "sqrt ?bb > 0"
	+ by (smt real_sqrt_gt_zero zero_compare_simps(12))+
	+ have "(a - b)(1+cnj cc) = (a-c)(1+cnj cb) + (c-b)(1 + cnj ca)"
	+ by (simp add: field_simps)
	+ moreover
	+ have "1 + cnj c * c = 1 + (cmod c)\<^sup>2"
	+ using complex_norm_square
	+ by auto
	+ hence "cmod ((a - b)(1+cnj cc)) = cmod(a - b) * (1+(cmod c)\<^sup>2)"
	+ by (smt norm_mult norm_of_real zero_compare_simps(12))
	+ ultimately
	+ have "cmod(a - b) * (1+(cmod c)\<^sup>2) \<le> cmod (a-c) * cmod (1+cnj cb) + cmod (c-b) cmod(1 + cnj c*a)"
	+ using complex_mod_triangle_ineq2[of "(a-c)(1+cnj cb)" "(c-b)(1 + cnj ca)"]
	+ by simp
	+ moreover
	+ have : "\<And> a b c d b' d'. \<lbrakk>b \<le> b'; d \<le> d'; a \<ge> (0::real); c \<ge> 0\<rbrakk> \<Longrightarrow> ab + cd \<le> ab' + c*d'"
	+ by (smt mult_left_mono)
	+ have "cmod (a-c) * cmod (1+cnj cb) + cmod (c-b) cmod(1 + cnj ca) \<le> cmod (a - c) (sqrt (1+(cmod c)\<^sup>2) * sqrt (1+(cmod b)\<^sup>2)) + cmod (c - b) * (sqrt (1+(cmod c)\<^sup>2) * sqrt (1+(cmod a)\<^sup>2))"
	+ using *[OF cmod_1_plus_mult_le[of "cnj c" b] cmod_1_plus_mult_le[of "cnj c" a], of "cmod (a-c)" "cmod (c-b)"]
	+ by (simp add: field_simps real_sqrt_mult[symmetric])
	+ ultimately
	+ have "cmod(a - b) * ?cc \<le> cmod (a - c) * sqrt ?cc * sqrt ?bb + cmod (c - b) * sqrt ?cc * sqrt ?aa"
	+ by simp
	+ moreover
	+ hence "0 \<le> ?cc * sqrt ?aa * sqrt ?bb"
	+ using mult_right_mono[of 0 "sqrt ?aa" "sqrt ?bb"]
	+ using mult_right_mono[of 0 "?cc" "sqrt ?aa * sqrt ?bb"]
	+ by simp
	+ moreover
	+ have "sqrt ?cc / ?cc = 1 / sqrt ?cc"
	+ using \<open>sqrt ?cc > 0\<close>
	+ by (simp add: field_simps)
	+ hence "sqrt ?cc / (?cc * sqrt ?aa) = 1 / (sqrt ?aa * sqrt ?cc)"
	+ using times_divide_eq_right[of "1/sqrt ?aa" "sqrt ?cc" "?cc"]
	+ using \<open>sqrt ?aa > 0\<close>
	+ by simp
	+ hence "cmod (a - c) * sqrt ?cc / (?cc * sqrt ?aa) = cmod (a - c) / (sqrt ?aa * sqrt ?cc)"
	+ using times_divide_eq_right[of "cmod (a - c)" "sqrt ?cc" "(?cc * sqrt ?aa)"]
	+ by simp
	+ moreover
	+ have "sqrt ?cc / ?cc = 1 / sqrt ?cc"
	+ using \<open>sqrt ?cc > 0\<close>
	+ by (simp add: field_simps)
	+ hence "sqrt ?cc / (?cc * sqrt ?bb) = 1 / (sqrt ?bb * sqrt ?cc)"
	+ using times_divide_eq_right[of "1/sqrt ?bb" "sqrt ?cc" "?cc"]
	+ using \<open>sqrt ?bb > 0\<close>
	+ by simp
	+ hence "cmod (c - b) * sqrt ?cc / (?cc * sqrt ?bb) = cmod (c - b) / (sqrt ?bb * sqrt ?cc)"
	+ using times_divide_eq_right[of "cmod (c - b)" "sqrt ?cc" "?cc * sqrt ?bb"]
	+ by simp
	+ ultimately
	+ show ?thesis
	+ using divide_right_mono[of "cmod (a - b) * ?cc" "cmod (a - c) * sqrt ?cc * sqrt ?bb + cmod (c - b) * sqrt ?cc * sqrt ?aa" "?cc * sqrt ?aa * sqrt ?bb"] \<open>sqrt ?aa > 0\<close> \<open>sqrt ?bb > 0\<close> \<open>sqrt ?cc > 0\<close>
	+ by (simp add: add_divide_distrib)
	+qed
	+
	+lemma dist_fs_triangle_infinite1:
	+ shows "1 / sqrt(1 + (cmod b)\<^sup>2) \<le> 1 / sqrt(1 + (cmod c)\<^sup>2) + cmod (b - c) / (sqrt(1 + (cmod b)\<^sup>2) * sqrt(1 + (cmod c)\<^sup>2))"
	+proof-
	+ let ?bb = "sqrt (1 + (cmod b)\<^sup>2)" and ?cc = "sqrt (1 + (cmod c)\<^sup>2)"
	+ have "?bb > 0" "?cc > 0"
	+ by (metis add_strict_increasing real_sqrt_gt_0_iff zero_le_power2 zero_less_one)+
	+ hence : "?bb ?cc \<ge> 0"
	+ by simp
	+ have *: "(?cc - ?bb) / (?bb ?cc) = 1 / ?bb - 1 / ?cc"
	+ using \<open>sqrt (1 + (cmod b)\<^sup>2) > 0\<close> \<open>sqrt (1 + (cmod c)\<^sup>2) > 0\<close>
	+ by (simp add: field_simps)
	+ show "1 / ?bb \<le> 1 / ?cc + cmod (b - c) / (?bb * ?cc)"
	+ using divide_right_mono[OF cmod_diff_ge[of c b] *]
	+ by (subst (asm) **) (simp add: field_simps norm_minus_commute)
	+qed
	+
	+lemma dist_fs_triangle_infinite2:
	+ shows "1 / sqrt(1 + (cmod a)\<^sup>2) \<le> cmod (a - c) / (sqrt (1+(cmod a)\<^sup>2) * sqrt (1+(cmod c)\<^sup>2)) + 1 / sqrt(1 + (cmod c)\<^sup>2)"
	+ using dist_fs_triangle_infinite1[of a c]
	+ by simp
	+
	+lemma dist_fs_triangle_infinite3:
	+ shows "cmod(a - b) / (sqrt (1+(cmod a)\<^sup>2) * sqrt (1+(cmod b)\<^sup>2)) \<le> 1 / sqrt(1 + (cmod a)\<^sup>2) + 1 / sqrt(1 + (cmod b)\<^sup>2)"
	+proof-
	+ let ?aa = "sqrt (1 + (cmod a)\<^sup>2)" and ?bb = "sqrt (1 + (cmod b)\<^sup>2)"
	+ have "?aa > 0" "?bb > 0"
	+ by (metis add_strict_increasing real_sqrt_gt_0_iff zero_le_power2 zero_less_one)+
	+ hence : "?aa ?bb \<ge> 0"
	+ by simp
	+ have *: "(?aa + ?bb) / (?aa ?bb) = 1 / ?aa + 1 / ?bb"
	+ using \<open>?aa > 0\<close> \<open>?bb > 0\<close>
	+ by (simp add: field_simps)
	+ show "cmod (a - b) / (?aa * ?bb) \<le> 1 / ?aa + 1 / ?bb"
	+ using divide_right_mono[OF cmod_diff_le[of a b] *]
	+ by (subst (asm) **) (simp add: field_simps norm_minus_commute)
	+qed
	+
	+lemma dist_fs_triangle:
	+ shows "dist_fs A B \<le> dist_fs A C + dist_fs C B"
	+proof (cases "A = \<infinity>\<^sub>h")
	+ case True
	+ show ?thesis
	+ proof (cases "B = \<infinity>\<^sub>h")
	+ case True
	+ show ?thesis
	+ proof (cases "C = \<infinity>\<^sub>h")
	+ case True
	+ show ?thesis
	+ using \<open>A = \<infinity>\<^sub>h\<close> \<open>B = \<infinity>\<^sub>h\<close> \<open>C = \<infinity>\<^sub>h\<close>
	+ by simp
	+ next
	+ case False
	+ then obtain c where "C = of_complex c"
	+ using inf_or_of_complex[of C]
	+ by auto
	+ show ?thesis
	+ using \<open>A = \<infinity>\<^sub>h\<close> \<open>B = \<infinity>\<^sub>h\<close> \<open>C = of_complex c\<close>
	+ by (simp add: dist_fs_infinite2 dist_fs_sym)
	+ qed
	+ next
	+ case False
	+ then obtain b where "B = of_complex b"
	+ using inf_or_of_complex[of B]
	+ by auto
	+ show ?thesis
	+ proof (cases "C = \<infinity>\<^sub>h")
	+ case True
	+ show ?thesis
	+ using \<open>A = \<infinity>\<^sub>h\<close> \<open>C = \<infinity>\<^sub>h\<close> \<open>B = of_complex b\<close>
	+ by simp
	+ next
	+ case False
	+ then obtain c where "C = of_complex c"
	+ using inf_or_of_complex[of C]
	+ by auto
	+ show ?thesis
	+ using \<open>A = \<infinity>\<^sub>h\<close> \<open>B = of_complex b\<close> \<open>C = of_complex c\<close>
	+ using mult_left_mono[OF dist_fs_triangle_infinite1[of b c], of 2]
	+ by (simp add: dist_fs_finite dist_fs_infinite1 dist_fs_infinite2 dist_fs_sym)
	+ qed
	+ qed
	+next
	+ case False
	+ then obtain a where "A = of_complex a"
	+ using inf_or_of_complex[of A]
	+ by auto
	+ show ?thesis
	+ proof (cases "B = \<infinity>\<^sub>h")
	+ case True
	+ show ?thesis
	+ proof (cases "C = \<infinity>\<^sub>h")
	+ case True
	+ show ?thesis
	+ using \<open>B = \<infinity>\<^sub>h\<close> \<open>C = \<infinity>\<^sub>h\<close> \<open>A = of_complex a\<close>
	+ by (simp add: dist_fs_infinite2)
	+ next
	+ case False
	+ then obtain c where "C = of_complex c"
	+ using inf_or_of_complex[of C]
	+ by auto
	+ show ?thesis
	+ using \<open>B = \<infinity>\<^sub>h\<close> \<open>C = of_complex c\<close> \<open>A = of_complex a\<close>
	+ using mult_left_mono[OF dist_fs_triangle_infinite2[of a c], of 2]
	+ by (simp add: dist_fs_finite dist_fs_infinite1 dist_fs_infinite2)
	+ qed
	+ next
	+ case False
	+ then obtain b where "B = of_complex b"
	+ using inf_or_of_complex[of B]
	+ by auto
	+ show ?thesis
	+ proof (cases "C = \<infinity>\<^sub>h")
	+ case True
	+ thus ?thesis
	+ using \<open>C = \<infinity>\<^sub>h\<close> \<open>B = of_complex b\<close> \<open>A = of_complex a\<close>
	+ using mult_left_mono[OF dist_fs_triangle_infinite3[of a b], of 2]
	+ by (simp add: dist_fs_finite dist_fs_infinite1 dist_fs_infinite2)
	+ next
	+ case False
	+ then obtain c where "C = of_complex c"
	+ using inf_or_of_complex[of C]
	+ by auto
	+ show ?thesis
	+ using \<open>A = of_complex a\<close> \<open>B = of_complex b\<close> \<open>C = of_complex c\<close>
	+ using mult_left_mono[OF dist_fs_triangle_finite[of a b c], of 2]
	+ by (simp add: dist_fs_finite norm_minus_commute dist_fs_sym)
	+ qed
	+ qed
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>$\mathbb{C}P^1$ with Fubini-Study metric is a metric space\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Using the (already available) fact that $\mathbb{R}^3$ is a metric space (under the distance
	+function $\lambda\ x\ y.\ @{term norm}(x - y)$), it was not difficult to show that the type @{term
	+complex_homo} equipped with @{term dist_fs} is a metric space, i.e., an instantiation of the @{term
	+metric_space} locale.\<close>
	+
	+instantiation complex_homo :: metric_space
	+begin
	+definition "dist_complex_homo = dist_fs"
	+definition "(uniformity_complex_homo :: (complex_homo \<times> complex_homo) filter) = (INF e:{0<..}. principal {(x, y). dist_class.dist x y < e})"
	+definition "open_complex_homo (U :: complex_homo set) = (\<forall> x \<in> U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"
	+instance
	+proof
	+ fix x y :: complex_homo
	+ show "(dist_class.dist x y = 0) = (x = y)"
	+ unfolding dist_complex_homo_def
	+ using dist_fs_zero1[of x] dist_fs_zero2[of x y]
	+ by auto
	+next
	+ fix x y z :: complex_homo
	+ show "dist_class.dist x y \<le> dist_class.dist x z + dist_class.dist y z"
	+ unfolding dist_complex_homo_def
	+ using dist_fs_triangle[of x y z]
	+ by (simp add: dist_fs_sym)
	+qed (simp_all add: open_complex_homo_def uniformity_complex_homo_def)
	+end
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Chordal distance on the Riemann sphere\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Distance of the two points is given by the length of the chord. We show that it corresponds to
	+the Fubini-Study metric in the plane.\<close>
	+
	+definition dist_riemann_sphere_r3 :: "R3 \<Rightarrow> R3 \<Rightarrow> real" where [simp]:
	+ "dist_riemann_sphere_r3 M1 M2 =
	+ (let (x1, y1, z1) = M1;
	+ (x2, y2, z2) = M2
	+ in norm (x1 - x2, y1 - y2, z1 - z2))"
	+
	+lemma dist_riemann_sphere_r3_inner:
	+ assumes "M1 \<in> unit_sphere" and "M2 \<in> unit_sphere"
	+ shows "(dist_riemann_sphere_r3 M1 M2)\<^sup>2 = 2 - 2 * inner M1 M2"
	+ using assms
	+ apply (cases M1, cases M2)
	+ apply (auto simp add: norm_prod_def)
	+ apply (simp add: power2_eq_square field_simps)
	+ done
	+
	+
	+lift_definition dist_riemann_sphere' :: "riemann_sphere \<Rightarrow> riemann_sphere \<Rightarrow> real" is dist_riemann_sphere_r3
	+ done
	+
	+lemma dist_riemann_sphere_ge_0 [simp]:
	+ shows "dist_riemann_sphere' M1 M2 \<ge> 0"
	+ apply transfer
	+ using norm_ge_zero
	+ by (simp add: split_def Let_def)
	+
	+text \<open>Using stereographic projection we prove the connection between chordal metric on the spehere
	+and Fubini-Study metric in the plane.\<close>
	+
	+lemma dist_stereographic_finite:
	+ assumes "stereographic M1 = of_complex m1" and "stereographic M2 = of_complex m2"
	+ shows "dist_riemann_sphere' M1 M2 = 2 * cmod (m1 - m2) / (sqrt (1 + (cmod m1)\<^sup>2) * sqrt (1 + (cmod m2)\<^sup>2))"
	+ using assms
	+proof-
	+ have *: "M1 = inv_stereographic (of_complex m1)" "M2 = inv_stereographic (of_complex m2)"
	+ using inv_stereographic_is_inv assms
	+ by (metis inv_stereographic_stereographic)+
	+ have "(1 + (cmod m1)\<^sup>2) \<noteq> 0" "(1 + (cmod m2)\<^sup>2) \<noteq> 0"
	+ by (smt power2_less_0)+
	+ have "(1 + (cmod m1)\<^sup>2) > 0" "(1 + (cmod m2)\<^sup>2) > 0"
	+ by (smt realpow_square_minus_le)+
	+ hence "(1 + (cmod m1)\<^sup>2) * (1 + (cmod m2)\<^sup>2) > 0"
	+ by (metis norm_mult_less norm_zero power2_eq_square zero_power2)
	+ hence ++: "sqrt ((1 + cmod m1 * cmod m1) * (1 + cmod m2 * cmod m2)) > 0"
	+ using real_sqrt_gt_0_iff
	+ by (simp add: power2_eq_square)
	+ hence *: "(2 cmod (m1 - m2) / sqrt ((1 + cmod m1 * cmod m1) * (1 + cmod m2 * cmod m2))) \<ge> 0 \<longleftrightarrow> cmod (m1 - m2) \<ge> 0"
	+ by (metis diff_self divide_nonneg_pos mult_2 norm_ge_zero norm_triangle_ineq4 norm_zero)
	+
	+ have "(dist_riemann_sphere' M1 M2)\<^sup>2 * (1 + (cmod m1)\<^sup>2) * (1 + (cmod m2)\<^sup>2) = 4 * (cmod (m1 - m2))\<^sup>2"
	+ using *
	+ proof (transfer, transfer)
	+ fix m1 m2 M1 M2
	+ assume us: "M1 \<in> unit_sphere" "M2 \<in> unit_sphere" and
	+ *: "M1 = inv_stereographic_cvec_r3 (of_complex_cvec m1)" "M2 = inv_stereographic_cvec_r3 (of_complex_cvec m2)"
	+ have "(1 + (cmod m1)\<^sup>2) \<noteq> 0" "(1 + (cmod m2)\<^sup>2) \<noteq> 0"
	+ by (smt power2_less_0)+
	+ thus "(dist_riemann_sphere_r3 M1 M2)\<^sup>2 * (1 + (cmod m1)\<^sup>2) * (1 + (cmod m2)\<^sup>2) =
	+ 4 * (cmod (m1 - m2))\<^sup>2"
	+ apply (subst dist_riemann_sphere_r3_inner[OF us])
	+ apply (subst *)+
	+ apply (simp add: dist_riemann_sphere_r3_inner[OF us] complex_mult_cnj_cmod)
	+ apply (subst left_diff_distrib[of 2])
	+ apply (subst left_diff_distrib[of "2*(1+(cmod m1)\<^sup>2)"])
	+ apply (subst distrib_right[of _ _ "(1 + (cmod m1)\<^sup>2)"])
	+ apply (subst distrib_right[of _ _ "(1 + (cmod m1)\<^sup>2)"])
	+ apply simp
	+ apply (subst distrib_right[of _ _ "(1 + (cmod m2)\<^sup>2)"])
	+ apply (subst distrib_right[of _ _ "(1 + (cmod m2)\<^sup>2)"])
	+ apply (subst distrib_right[of _ _ "(1 + (cmod m2)\<^sup>2)"])
	+ apply simp
	+ apply (subst (asm) cmod_square)+
	+ apply (subst cmod_square)+
	+ apply (simp add: field_simps)
	+ done
	+ qed
	+ hence "(dist_riemann_sphere' M1 M2)\<^sup>2 = 4 * (cmod (m1 - m2))\<^sup>2 / ((1 + (cmod m1)\<^sup>2) * (1 + (cmod m2)\<^sup>2))"
	+ using \<open>(1 + (cmod m1)\<^sup>2) \<noteq> 0\<close> \<open>(1 + (cmod m2)\<^sup>2) \<noteq> 0\<close>
	+ using eq_divide_imp[of "(1 + (cmod m1)\<^sup>2) * (1 + (cmod m2)\<^sup>2)" "(dist_riemann_sphere' M1 M2)\<^sup>2" "4 * (cmod (m1 - m2))\<^sup>2"]
	+ by simp
	+ thus "dist_riemann_sphere' M1 M2 = 2 * cmod (m1 - m2) / (sqrt (1 + (cmod m1)\<^sup>2) * sqrt (1 + (cmod m2)\<^sup>2))"
	+ using power2_eq_iff[of "dist_riemann_sphere' M1 M2" "2 * (cmod (m1 - m2)) / sqrt ((1 + (cmod m1)\<^sup>2) * (1 + (cmod m2)\<^sup>2))"]
	+ using \<open>(1 + (cmod m1)\<^sup>2) * (1 + (cmod m2)\<^sup>2) > 0\<close> \<open>(1 + (cmod m1)\<^sup>2) > 0\<close> \<open>(1 + (cmod m2)\<^sup>2) > 0\<close>
	+ apply (auto simp add: power2_eq_square real_sqrt_mult[symmetric])
	+ using dist_riemann_sphere_ge_0[of M1 M2] **
	+ using ++ divide_le_0_iff by force
	+qed
	+
	+
	+lemma dist_stereographic_infinite:
	+ assumes "stereographic M1 = \<infinity>\<^sub>h" and "stereographic M2 = of_complex m2"
	+ shows "dist_riemann_sphere' M1 M2 = 2 / sqrt (1 + (cmod m2)\<^sup>2)"
	+proof-
	+ have *: "M1 = inv_stereographic \<infinity>\<^sub>h" "M2 = inv_stereographic (of_complex m2)"
	+ using inv_stereographic_is_inv assms
	+ by (metis inv_stereographic_stereographic)+
	+ have "(1 + (cmod m2)\<^sup>2) \<noteq> 0"
	+ by (smt power2_less_0)
	+ have "(1 + (cmod m2)\<^sup>2) > 0"
	+ by (smt realpow_square_minus_le)+
	+ hence "sqrt (1 + cmod m2 * cmod m2) > 0"
	+ using real_sqrt_gt_0_iff
	+ by (simp add: power2_eq_square)
	+ hence *: "2 / sqrt (1 + cmod m2 cmod m2) > 0"
	+ by simp
	+
	+ have "(dist_riemann_sphere' M1 M2)\<^sup>2 * (1 + (cmod m2)\<^sup>2) = 4"
	+ using *
	+ apply transfer
	+ apply transfer
	+ proof-
	+ fix M1 M2 m2
	+ assume us: "M1 \<in> unit_sphere" "M2 \<in> unit_sphere" and
	+ *: "M1 = inv_stereographic_cvec_r3 \<infinity>\<^sub>v" "M2 = inv_stereographic_cvec_r3 (of_complex_cvec m2)"
	+ have "(1 + (cmod m2)\<^sup>2) \<noteq> 0"
	+ by (smt power2_less_0)
	+ thus "(dist_riemann_sphere_r3 M1 M2)\<^sup>2 * (1 + (cmod m2)\<^sup>2) = 4"
	+ apply (subst dist_riemann_sphere_r3_inner[OF us])
	+ apply (subst *)+
	+ apply (simp add: complex_mult_cnj_cmod)
	+ apply (subst left_diff_distrib[of 2], simp)
	+ done
	+ qed
	+ hence "(dist_riemann_sphere' M1 M2)\<^sup>2 = 4 / (1 + (cmod m2)\<^sup>2)"
	+ using \<open>(1 + (cmod m2)\<^sup>2) \<noteq> 0\<close>
	+ by (simp add: field_simps)
	+ thus "dist_riemann_sphere' M1 M2 = 2 / sqrt (1 + (cmod m2)\<^sup>2)"
	+ using power2_eq_iff[of "dist_riemann_sphere' M1 M2" "2 / sqrt (1 + (cmod m2)\<^sup>2)"]
	+ using \<open>(1 + (cmod m2)\<^sup>2) > 0\<close>
	+ apply (auto simp add: power2_eq_square real_sqrt_mult[symmetric])
	+ using dist_riemann_sphere_ge_0[of M1 M2] **
	+ by simp
	+qed
	+
	+lemma dist_rieman_sphere_zero [simp]:
	+ shows "dist_riemann_sphere' M M = 0"
	+ by transfer auto
	+
	+lemma dist_riemann_sphere_sym:
	+ shows "dist_riemann_sphere' M1 M2 = dist_riemann_sphere' M2 M1"
	+proof transfer
	+ fix M1 M2 :: R3
	+ obtain x1 y1 z1 x2 y2 z2 where MM: "(x1, y1, z1) = M1" "(x2, y2, z2) = M2"
	+ by (cases "M1", cases "M2", auto)
	+ show "dist_riemann_sphere_r3 M1 M2 = dist_riemann_sphere_r3 M2 M1"
	+ using norm_minus_cancel[of "(x1 - x2, y1 - y2, z1 - z2)"] MM[symmetric]
	+ by simp
	+qed
	+
	+text \<open>Central theorem that connects the two metrics.\<close>
	+lemma dist_stereographic:
	+ shows "dist_riemann_sphere' M1 M2 = dist_fs (stereographic M1) (stereographic M2)"
	+proof (cases "M1 = North")
	+ case True
	+ hence "stereographic M1 = \<infinity>\<^sub>h"
	+ by (simp add: stereographic_North)
	+ show ?thesis
	+ proof (cases "M2 = North")
	+ case True
	+ show ?thesis
	+ using \<open>M1 = North\<close> \<open>M2 = North\<close>
	+ by auto
	+ next
	+ case False
	+ hence "stereographic M2 \<noteq> \<infinity>\<^sub>h"
	+ using stereographic_North[of M2]
	+ by simp
	+ then obtain m2 where "stereographic M2 = of_complex m2"
	+ using inf_or_of_complex[of "stereographic M2"]
	+ by auto
	+ show ?thesis
	+ using \<open>stereographic M2 = of_complex m2\<close> \<open>stereographic M1 = \<infinity>\<^sub>h\<close>
	+ using dist_fs_infinite1 dist_stereographic_infinite
	+ by (simp add: dist_fs_sym)
	+ qed
	+next
	+ case False
	+ hence "stereographic M1 \<noteq> \<infinity>\<^sub>h"
	+ by (simp add: stereographic_North)
	+ then obtain m1 where "stereographic M1 = of_complex m1"
	+ using inf_or_of_complex[of "stereographic M1"]
	+ by auto
	+ show ?thesis
	+ proof (cases "M2 = North")
	+ case True
	+ hence "stereographic M2 = \<infinity>\<^sub>h"
	+ by (simp add: stereographic_North)
	+ show ?thesis
	+ using \<open>stereographic M1 = of_complex m1\<close> \<open>stereographic M2 = \<infinity>\<^sub>h\<close>
	+ using dist_fs_infinite2 dist_stereographic_infinite
	+ by (subst dist_riemann_sphere_sym, simp add: dist_fs_sym)
	+ next
	+ case False
	+ hence "stereographic M2 \<noteq> \<infinity>\<^sub>h"
	+ by (simp add: stereographic_North)
	+ then obtain m2 where "stereographic M2 = of_complex m2"
	+ using inf_or_of_complex[of "stereographic M2"]
	+ by auto
	+ show ?thesis
	+ using \<open>stereographic M1 = of_complex m1\<close> \<open>stereographic M2 = of_complex m2\<close>
	+ using dist_fs_finite dist_stereographic_finite
	+ by simp
	+ qed
	+qed
	+
	+text \<open>Other direction\<close>
	+lemma dist_stereographic':
	+ shows "dist_fs A B = dist_riemann_sphere' (inv_stereographic A) (inv_stereographic B)"
	+ by (subst dist_stereographic) (metis stereographic_inv_stereographic)
	+
	+text \<open>The @{term riemann_sphere} equipped with @{term dist_riemann_sphere'} is a metric space, i.e.,
	+an instantiation of the @{term metric_space} locale.\<close>
	+
	+instantiation riemann_sphere :: metric_space
	+begin
	+definition "dist_riemann_sphere = dist_riemann_sphere'"
	+definition "(uniformity_riemann_sphere :: (riemann_sphere \<times> riemann_sphere) filter) = (INF e:{0<..}. principal {(x, y). dist_class.dist x y < e})"
	+definition "open_riemann_sphere (U :: riemann_sphere set) = (\<forall> x \<in> U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"
	+instance
	+proof
	+ fix x y :: riemann_sphere
	+ show "(dist_class.dist x y = 0) = (x = y)"
	+ unfolding dist_riemann_sphere_def
	+ proof transfer
	+ fix x y :: R3
	+ obtain x1 y1 z1 x2 y2 z2 where *: "(x1, y1, z1) = x" "(x2, y2, z2) = y"
	+ by (cases x, cases y, auto)
	+ assume "x \<in> unit_sphere" "y \<in> unit_sphere"
	+ thus "(dist_riemann_sphere_r3 x y = 0) = (x = y)"
	+ using norm_eq_zero[of "(x1 - y2, y1 - y2, z1 - z2)"] using *[symmetric]
	+ by (simp add: zero_prod_def)
	+ qed
	+next
	+ fix x y z :: riemann_sphere
	+ show "dist_class.dist x y \<le> dist_class.dist x z + dist_class.dist y z"
	+ unfolding dist_riemann_sphere_def
	+ proof transfer
	+ fix x y z :: R3
	+ obtain x1 y1 z1 x2 y2 z2 x3 y3 z3 where MM: "(x1, y1, z1) = x" "(x2, y2, z2) = y" "(x3, y3, z3) = z"
	+ by (cases "x", cases "y", cases "z", auto)
	+
	+ assume "x \<in> unit_sphere" "y \<in> unit_sphere" "z \<in> unit_sphere"
	+ thus "dist_riemann_sphere_r3 x y \<le> dist_riemann_sphere_r3 x z + dist_riemann_sphere_r3 y z"
	+ using MM[symmetric] norm_minus_cancel[of "(x3 - x2, y3 - y2, z3 - z2)"] norm_triangle_ineq[of "(x1 - x3, y1 - y3, z1 - z3)" "(x3 - x2, y3 - y2, z3 - z2)"]
	+ by simp
	+ qed
	+qed (simp_all add: uniformity_riemann_sphere_def open_riemann_sphere_def)
	+end
	+
	+text \<open>The @{term riemann_sphere} metric space is perfect, i.e., it does not have isolated points.\<close>
	+instantiation riemann_sphere :: perfect_space
	+begin
	+instance proof
	+ fix M :: riemann_sphere
	+ show "\<not> open {M}"
	+ unfolding open_dist dist_riemann_sphere_def
	+ apply (subst dist_riemann_sphere_sym)
	+ proof transfer
	+ fix M
	+ assume "M \<in> unit_sphere"
	+ obtain x y z where MM: "M = (x, y, z)"
	+ by (cases "M") auto
	+ then obtain \<alpha> \<beta> where : "x = cos \<alpha> cos \<beta>" "y = cos \<alpha> * sin \<beta>" "z = sin \<alpha>" "-pi / 2 \<le> \<alpha> \<and> \<alpha> \<le> pi / 2"
	+ using \<open>M \<in> unit_sphere\<close>
	+ using ex_sphere_params[of x y z]
	+ by auto
	+ have "\<And> e. e > 0 \<Longrightarrow> (\<exists>y. y \<in> unit_sphere \<and> dist_riemann_sphere_r3 M y < e \<and> y \<noteq> M)"
	+ proof-
	+ fix e :: real
	+ assume "e > 0"
	+ then obtain \<alpha>' where "1 - (e*e/2) < cos (\<alpha> - \<alpha>')" "\<alpha> \<noteq> \<alpha>'" "-pi/2 \<le> \<alpha>'" "\<alpha>' \<le> pi/2"
	+ using ex_cos_gt[of \<alpha> "1 - (e*e/2)"] \<open>- pi / 2 \<le> \<alpha> \<and> \<alpha> \<le> pi / 2\<close>
	+ by auto
	+ hence "sin \<alpha> \<noteq> sin \<alpha>'"
	+ using \<open>-pi / 2 \<le> \<alpha> \<and> \<alpha> \<le> pi / 2\<close> sin_inj[of \<alpha> \<alpha>']
	+ by auto
	+
	+ have "2 - 2 * cos (\<alpha> - \<alpha>') < e*e"
	+ using mult_strict_right_mono[OF \<open>1 - (e*e/2) < cos (\<alpha> - \<alpha>')\<close>, of 2]
	+ by (simp add: field_simps)
	+ have "2 - 2 * cos (\<alpha> - \<alpha>') \<ge> 0"
	+ using cos_le_one[of "\<alpha> - \<alpha>'"]
	+ by (simp add: sign_simps)
	+ let ?M' = "(cos \<alpha>' * cos \<beta>, cos \<alpha>' * sin \<beta>, sin \<alpha>')"
	+ have "dist_riemann_sphere_r3 M ?M' = sqrt ((cos \<alpha> - cos \<alpha>')\<^sup>2 + (sin \<alpha> - sin \<alpha>')\<^sup>2)"
	+ using MM * sphere_params_on_sphere[of _ \<alpha>' \<beta>]
	+ using sin_cos_squared_add[of \<beta>]
	+ apply (simp add: dist_riemann_sphere'_def Abs_riemann_sphere_inverse norm_prod_def)
	+ apply (subst left_diff_distrib[symmetric])+
	+ apply (subst power_mult_distrib)+
	+ apply (subst distrib_left[symmetric])
	+ apply simp
	+ done
	+ also have "... = sqrt (2 - 2*cos (\<alpha> - \<alpha>'))"
	+ by (simp add: power2_eq_square field_simps cos_diff)
	+ finally
	+ have "(dist_riemann_sphere_r3 M ?M')\<^sup>2 = 2 - 2*cos (\<alpha> - \<alpha>')"
	+ using \<open>2 - 2 * cos (\<alpha> - \<alpha>') \<ge> 0\<close>
	+ by simp
	+ hence "(dist_riemann_sphere_r3 M ?M')\<^sup>2 < e\<^sup>2"
	+ using \<open>2 - 2 * cos (\<alpha> - \<alpha>') < e*e\<close>
	+ by (simp add: power2_eq_square)
	+ hence "dist_riemann_sphere_r3 M ?M' < e"
	+ apply (rule power2_less_imp_less)
	+ using \<open>e > 0\<close>
	+ by simp
	+ moreover
	+ have "M \<noteq> ?M'"
	+ using MM \<open>sin \<alpha> \<noteq> sin \<alpha>'\<close> *
	+ by simp
	+ moreover
	+ have "?M' \<in> unit_sphere"
	+ using sphere_params_on_sphere by auto
	+ ultimately
	+ show "\<exists>y. y \<in> unit_sphere \<and> dist_riemann_sphere_r3 M y < e \<and> y \<noteq> M"
	+ unfolding dist_riemann_sphere_def
	+ by (rule_tac x="?M'" in exI, simp)
	+ qed
	+ thus "\<not> (\<forall>x\<in>{M}. \<exists>e>0. \<forall>y\<in>{x. x \<in> unit_sphere}. dist_riemann_sphere_r3 x y < e \<longrightarrow> y \<in> {M})"
	+ by auto
	+ qed
	+qed
	+end
	+
	+text \<open>The @{term complex_homo} metric space is perfect, i.e., it does not have isolated points.\<close>
	+instantiation complex_homo :: perfect_space
	+begin
	+instance proof
	+ fix x::complex_homo
	+ show "\<not> open {x}"
	+ unfolding open_dist
	+ proof (auto)
	+ fix e::real
	+ assume "e > 0"
	+ thus "\<exists> y. dist_class.dist y x < e \<and> y \<noteq> x"
	+ using not_open_singleton[of "inv_stereographic x"]
	+ unfolding open_dist
	+ unfolding dist_complex_homo_def dist_riemann_sphere_def
	+ apply (subst dist_stereographic', auto)
	+ apply (erule_tac x=e in allE, auto)
	+ apply (rule_tac x="stereographic y" in exI, auto)
	+ done
	+ qed
	+qed
	+
	+end
	+
	+lemma Lim_within:
	+ shows "(f \<longlongrightarrow> l) (at a within S) \<longleftrightarrow>
	+ (\<forall>e >0. \<exists>d>0. \<forall>x \<in> S. 0 < dist_class.dist x a \<and> dist_class.dist x a < d \<longrightarrow> dist_class.dist (f x) l < e)"
	+ by (auto simp: tendsto_iff eventually_at)
	+
	+lemma continuous_on_iff:
	+ shows "continuous_on s f \<longleftrightarrow>
	+ (\<forall>x\<in>s. \<forall>e>0. \<exists>d>0. \<forall>x'\<in>s. dist_class.dist x' x < d \<longrightarrow> dist_class.dist (f x') (f x) < e)"
	+ unfolding continuous_on_def Lim_within
	+ by (metis dist_pos_lt dist_self)
	+
	+text \<open>Using the chordal metric in the extended plane, and the Euclidean metric on the sphere in
	+$\mathbb{R}^3$, the stereographic and inverse stereographic projections are proved to be
	+continuous.\<close>
	+
	+lemma "continuous_on UNIV stereographic"
	+unfolding continuous_on_iff
	+unfolding dist_complex_homo_def dist_riemann_sphere_def
	+by (subst dist_stereographic', auto)
	+
	+lemma "continuous_on UNIV inv_stereographic"
	+unfolding continuous_on_iff
	+unfolding dist_complex_homo_def dist_riemann_sphere_def
	+by (subst dist_stereographic, auto)
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Chordal circles\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Real circlines are sets of points that are equidistant from some given point in the chordal
	+metric. There are exactly two such points (two chordal centers). On the Riemann sphere, these two
	+points are obtained as intersections of the sphere and a line that goes trough center of the circle,
	+and its orthogonal to its plane.\<close>
	+
	+text \<open>The circline for the given chordal center and radius.\<close>
	+definition chordal_circle_cvec_cmat :: "complex_vec \<Rightarrow> real \<Rightarrow> complex_mat" where
	+ [simp]: "chordal_circle_cvec_cmat a r =
	+ (let (a1, a2) = a
	+ in ((4a2cnj a2 - (cor r)\<^sup>2(a1cnj a1 + a2cnj a2)), (-4a1cnj a2), (-4cnj a1a2), (4a1cnj a1 - (cor r)\<^sup>2(a1cnj a1 + a2cnj a2))))"
	+
	+lemma chordal_circle_cmat_hermitean_nonzero [simp]:
	+ assumes "a \<noteq> vec_zero"
	+ shows "chordal_circle_cvec_cmat a r \<in> hermitean_nonzero"
	+ using assms
	+ by (cases a) (auto simp add: hermitean_def mat_adj_def mat_cnj_def Let_def)
	+
	+lift_definition chordal_circle_hcoords_clmat :: "complex_homo_coords \<Rightarrow> real \<Rightarrow> circline_mat" is chordal_circle_cvec_cmat
	+ using chordal_circle_cmat_hermitean_nonzero
	+ by (simp del: chordal_circle_cvec_cmat_def)
	+
	+lift_definition chordal_circle :: "complex_homo \<Rightarrow> real \<Rightarrow> circline" is chordal_circle_hcoords_clmat
	+proof transfer
	+ fix a b :: complex_vec and r :: real
	+ assume *: "a \<noteq> vec_zero" "b \<noteq> vec_zero"
	+ obtain a1 a2 where aa: "a = (a1, a2)"
	+ by (cases a, auto)
	+ obtain b1 b2 where bb: "b = (b1, b2)"
	+ by (cases b, auto)
	+ assume "a \<approx>\<^sub>v b"
	+ then obtain k where "b = (k * a1, k * a2)" "k \<noteq> 0"
	+ using aa bb
	+ by auto
	+ moreover
	+ have "cor (Re (k * cnj k)) = k * cnj k"
	+ by (metis complex_In_mult_cnj_zero complex_of_real_Re)
	+ ultimately
	+ show "circline_eq_cmat (chordal_circle_cvec_cmat a r) (chordal_circle_cvec_cmat b r)"
	+ using * aa bb
	+ by simp (rule_tac x="Re (k*cnj k)" in exI, auto simp add: Let_def field_simps)
	+qed
	+
	+lemma sqrt_1_plus_square:
	+ shows "sqrt (1 + a\<^sup>2) \<noteq> 0"
	+ by (smt real_sqrt_less_mono real_sqrt_zero realpow_square_minus_le)
	+
	+lemma
	+ assumes "dist_fs z a = r"
	+ shows "z \<in> circline_set (chordal_circle a r)"
	+proof (cases "a \<noteq> \<infinity>\<^sub>h")
	+ case True
	+ then obtain a' where "a = of_complex a'"
	+ using inf_or_of_complex
	+ by auto
	+ let ?A = "4 - (cor r)\<^sup>2 * (1 + (a'cnj a'))" and ?B = "-4a'" and ?C="-4cnj a'" and ?D = "4a'cnj a' - (cor r)\<^sup>2 (1 + (a'*cnj a'))"
	+ have hh: "(?A, ?B, ?C, ?D) \<in> {H. hermitean H \<and> H \<noteq> mat_zero}"
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def power2_eq_square)
	+ hence *: "chordal_circle (of_complex a') r = mk_circline ?A ?B ?C ?D"
	+ by (transfer, transfer, simp, rule_tac x=1 in exI, simp)
	+
	+ show ?thesis
	+ proof (cases "z \<noteq> \<infinity>\<^sub>h")
	+ case True
	+ then obtain z' where "z = of_complex z'"
	+ using inf_or_of_complex[of z] inf_or_of_complex[of a]
	+ by auto
	+ have "2 * cmod (z' - a') / (sqrt (1 + (cmod z')\<^sup>2) * sqrt (1 + (cmod a')\<^sup>2)) = r"
	+ using dist_fs_finite[of z' a'] assms \<open>z = of_complex z'\<close> \<open>a = of_complex a'\<close>
	+ by auto
	+ hence "4 * (cmod (z' - a'))\<^sup>2 / ((1 + (cmod z')\<^sup>2) * (1 + (cmod a')\<^sup>2)) = r\<^sup>2 "
	+ by (auto simp add: field_simps)
	+ moreover
	+ have "sqrt (1 + (cmod z')\<^sup>2) \<noteq> 0" "sqrt (1 + (cmod a')\<^sup>2) \<noteq> 0"
	+ using sqrt_1_plus_square
	+ by simp+
	+ hence "(1 + (cmod z')\<^sup>2) * (1 + (cmod a')\<^sup>2) \<noteq> 0"
	+ by simp
	+ ultimately
	+ have "4 * (cmod (z' - a'))\<^sup>2 = r\<^sup>2 * ((1 + (cmod z')\<^sup>2) * (1 + (cmod a')\<^sup>2))"
	+ by (simp add: field_simps)
	+ hence "4 * Re ((z' - a')cnj (z' - a')) = r\<^sup>2 (1 + Re (z'cnj z')) (1 + Re (a'*cnj a'))"
	+ by ((subst cmod_square[symmetric])+, simp)
	+ hence "4 * (Re(z'cnj z') - Re(a'cnj z') - Re(cnj a'z') + Re(a'cnj a')) = r\<^sup>2 * (1 + Re (z'cnj z')) (1 + Re (a'*cnj a'))"
	+ by (simp add: field_simps)
	+ hence "Re (?A * z' * cnj z' + ?B * cnj z' + ?C * z' + ?D) = 0"
	+ by (simp add: power2_eq_square field_simps)
	+ hence "?A * z' * cnj z' + ?B * cnj z' + ?C * z' + ?D = 0"
	+ by (subst complex_eq_if_Re_eq) (auto simp add: power2_eq_square)
	+ hence "(cnj z' * ?A + ?C) * z' + (cnj z' * ?B + ?D) = 0"
	+ by algebra
	+ hence "z \<in> circline_set (mk_circline ?A ?B ?C ?D)"
	+ using \<open>z = of_complex z'\<close> hh
	+ unfolding circline_set_def
	+ by simp (transfer, transfer, simp add: vec_cnj_def)
	+ thus ?thesis
	+ using *
	+ by (subst \<open>a = of_complex a'\<close>) simp
	+ next
	+ case False
	+ hence "2 / sqrt (1 + (cmod a')\<^sup>2) = r"
	+ using assms \<open>a = of_complex a'\<close>
	+ using dist_fs_infinite2[of a']
	+ by simp
	+ moreover
	+ have "sqrt (1 + (cmod a')\<^sup>2) \<noteq> 0"
	+ using sqrt_1_plus_square
	+ by simp
	+ ultimately
	+ have "2 = r * sqrt (1 + (cmod a')\<^sup>2)"
	+ by (simp add: field_simps)
	+ hence "4 = (r * sqrt (1 + (cmod a')\<^sup>2))\<^sup>2"
	+ by simp
	+ hence "4 = r\<^sup>2 * (1 + (cmod a')\<^sup>2)"
	+ by (simp add: power_mult_distrib)
	+ hence "Re (4 - (cor r)\<^sup>2 * (1 + (a' * cnj a'))) = 0"
	+ by (subst (asm) cmod_square) (simp add: field_simps power2_eq_square)
	+ hence "4 - (cor r)\<^sup>2 * (1 + (a'*cnj a')) = 0"
	+ by (subst complex_eq_if_Re_eq) (auto simp add: power2_eq_square)
	+ hence "circline_A0 (mk_circline ?A ?B ?C ?D)"
	+ using hh
	+ by (simp, transfer, transfer, simp)
	+ hence "z \<in> circline_set (mk_circline ?A ?B ?C ?D)"
	+ using inf_in_circline_set[of "mk_circline ?A ?B ?C ?D"]
	+ using \<open>\<not> z \<noteq> \<infinity>\<^sub>h\<close>
	+ by simp
	+ thus ?thesis
	+ using *
	+ by (subst \<open>a = of_complex a'\<close>) simp
	+ qed
	+next
	+ case False
	+ let ?A = "-(cor r)\<^sup>2" and ?B = "0" and ?C = "0" and ?D = "4 -(cor r)\<^sup>2"
	+ have hh: "(?A, ?B, ?C, ?D) \<in> {H. hermitean H \<and> H \<noteq> mat_zero}"
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def power2_eq_square)
	+ hence *: "chordal_circle a r = mk_circline ?A ?B ?C ?D"
	+ using \<open>\<not> a \<noteq> \<infinity>\<^sub>h\<close>
	+ by simp (transfer, transfer, simp, rule_tac x=1 in exI, simp)
	+
	+ show ?thesis
	+ proof (cases "z = \<infinity>\<^sub>h")
	+ case True
	+ show ?thesis
	+ using assms \<open>z = \<infinity>\<^sub>h\<close> \<open>\<not> a \<noteq> \<infinity>\<^sub>h\<close>
	+ using * hh
	+ by (simp, subst inf_in_circline_set, transfer, transfer, simp)
	+ next
	+ case False
	+ then obtain z' where "z = of_complex z'"
	+ using inf_or_of_complex[of z]
	+ by auto
	+ have "2 / sqrt (1 + (cmod z')\<^sup>2) = r"
	+ using assms \<open>z = of_complex z'\<close>\<open>\<not> a \<noteq> \<infinity>\<^sub>h\<close>
	+ using dist_fs_infinite2[of z']
	+ by (simp add: dist_fs_sym)
	+ moreover
	+ have "sqrt (1 + (cmod z')\<^sup>2) \<noteq> 0"
	+ using sqrt_1_plus_square
	+ by simp
	+ ultimately
	+ have "2 = r * sqrt (1 + (cmod z')\<^sup>2)"
	+ by (simp add: field_simps)
	+ hence "4 = (r * sqrt (1 + (cmod z')\<^sup>2))\<^sup>2"
	+ by simp
	+ hence "4 = r\<^sup>2 * (1 + (cmod z')\<^sup>2)"
	+ by (simp add: power_mult_distrib)
	+ hence "Re (4 - (cor r)\<^sup>2 * (1 + (z' * cnj z'))) = 0"
	+ by (subst (asm) cmod_square) (simp add: field_simps power2_eq_square)
	+ hence "- (cor r)\<^sup>2 * z'*cnj z' + 4 - (cor r)\<^sup>2 = 0"
	+ by (subst complex_eq_if_Re_eq) (auto simp add: power2_eq_square field_simps)
	+ hence "z \<in> circline_set (mk_circline ?A ?B ?C ?D)"
	+ using hh
	+ unfolding circline_set_def
	+ by (subst \<open>z = of_complex z'\<close>, simp) (transfer, transfer, auto simp add: vec_cnj_def field_simps)
	+ thus ?thesis
	+ using *
	+ by simp
	+ qed
	+qed
	+
	+lemma
	+ assumes "z \<in> circline_set (chordal_circle a r)" and "r \<ge> 0"
	+ shows "dist_fs z a = r"
	+proof (cases "a = \<infinity>\<^sub>h")
	+ case False
	+ then obtain a' where "a = of_complex a'"
	+ using inf_or_of_complex
	+ by auto
	+
	+ let ?A = "4 - (cor r)\<^sup>2 * (1 + (a'cnj a'))" and ?B = "-4a'" and ?C="-4cnj a'" and ?D = "4a'cnj a' - (cor r)\<^sup>2 (1 + (a'*cnj a'))"
	+ have hh: "(?A, ?B, ?C, ?D) \<in> {H. hermitean H \<and> H \<noteq> mat_zero}"
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def power2_eq_square)
	+ hence *: "chordal_circle (of_complex a') r = mk_circline ?A ?B ?C ?D"
	+ by (transfer, transfer, simp, rule_tac x=1 in exI, simp)
	+
	+ show ?thesis
	+ proof (cases "z = \<infinity>\<^sub>h")
	+ case False
	+ then obtain z' where "z = of_complex z'"
	+ using inf_or_of_complex[of z] inf_or_of_complex[of a]
	+ by auto
	+ hence "z \<in> circline_set (mk_circline ?A ?B ?C ?D)"
	+ using assms \<open>a = of_complex a'\<close> *
	+ by simp
	+ hence "(cnj z' * ?A + ?C) * z' + (cnj z' * ?B + ?D) = 0"
	+ using hh
	+ unfolding circline_set_def
	+ by (subst (asm) \<open>z = of_complex z'\<close>, simp) (transfer, transfer, simp add: vec_cnj_def)
	+ hence "?A * z' * cnj z' + ?B * cnj z' + ?C * z' + ?D = 0"
	+ by algebra
	+ hence "Re (?A * z' * cnj z' + ?B * cnj z' +?C * z' +?D) = 0"
	+ by (simp add: power2_eq_square field_simps)
	+ hence "4 * Re ((z' - a')cnj (z' - a')) = r\<^sup>2 (1 + Re (z'cnj z')) (1 + Re (a'*cnj a'))"
	+ by (simp add: field_simps power2_eq_square)
	+ hence "4 * (cmod (z' - a'))\<^sup>2 = r\<^sup>2 * ((1 + (cmod z')\<^sup>2) * (1 + (cmod a')\<^sup>2))"
	+ by (subst cmod_square)+ simp
	+ moreover
	+ have "sqrt (1 + (cmod z')\<^sup>2) \<noteq> 0" "sqrt (1 + (cmod a')\<^sup>2) \<noteq> 0"
	+ using sqrt_1_plus_square
	+ by simp+
	+ hence "(1 + (cmod z')\<^sup>2) * (1 + (cmod a')\<^sup>2) \<noteq> 0"
	+ by simp
	+ ultimately
	+ have "4 * (cmod (z' - a'))\<^sup>2 / ((1 + (cmod z')\<^sup>2) * (1 + (cmod a')\<^sup>2)) = r\<^sup>2 "
	+ by (simp add: field_simps)
	+ hence "2 * cmod (z' - a') / (sqrt (1 + (cmod z')\<^sup>2) * sqrt (1 + (cmod a')\<^sup>2)) = r"
	+ using \<open>r \<ge> 0\<close>
	+ by (subst (asm) real_sqrt_eq_iff[symmetric]) (simp add: real_sqrt_mult real_sqrt_divide)
	+ thus ?thesis
	+ using \<open>z = of_complex z'\<close> \<open>a = of_complex a'\<close>
	+ using dist_fs_finite[of z' a']
	+ by simp
	+ next
	+ case True
	+ have "z \<in> circline_set (mk_circline ?A ?B ?C ?D)"
	+ using assms \<open>a = of_complex a'\<close> *
	+ by simp
	+ hence "circline_A0 (mk_circline ?A ?B ?C ?D)"
	+ using inf_in_circline_set[of "mk_circline ?A ?B ?C ?D"]
	+ using \<open>z = \<infinity>\<^sub>h\<close>
	+ by simp
	+ hence "4 - (cor r)\<^sup>2 * (1 + (a'*cnj a')) = 0"
	+ using hh
	+ by (transfer, transfer, simp)
	+ hence "Re (4 - (cor r)\<^sup>2 * (1 + (a' * cnj a'))) = 0"
	+ by simp
	+ hence "4 = r\<^sup>2 * (1 + (cmod a')\<^sup>2)"
	+ by (subst cmod_square) (simp add: power2_eq_square)
	+ hence "2 = r * sqrt (1 + (cmod a')\<^sup>2)"
	+ using \<open>r \<ge> 0\<close>
	+ by (subst (asm) real_sqrt_eq_iff[symmetric]) (simp add: real_sqrt_mult)
	+ moreover
	+ have "sqrt (1 + (cmod a')\<^sup>2) \<noteq> 0"
	+ using sqrt_1_plus_square
	+ by simp
	+ ultimately
	+ have "2 / sqrt (1 + (cmod a')\<^sup>2) = r"
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using \<open>a = of_complex a'\<close> \<open>z = \<infinity>\<^sub>h\<close>
	+ using dist_fs_infinite2[of a']
	+ by simp
	+ qed
	+next
	+ case True
	+ let ?A = "-(cor r)\<^sup>2" and ?B = "0" and ?C = "0" and ?D = "4 -(cor r)\<^sup>2"
	+ have hh: "(?A, ?B, ?C, ?D) \<in> {H. hermitean H \<and> H \<noteq> mat_zero}"
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def power2_eq_square)
	+ hence *: "chordal_circle a r = mk_circline ?A ?B ?C ?D"
	+ using \<open>a = \<infinity>\<^sub>h\<close>
	+ by simp (transfer, transfer, simp, rule_tac x=1 in exI, simp)
	+
	+ show ?thesis
	+ proof (cases "z = \<infinity>\<^sub>h")
	+ case True
	+ thus ?thesis
	+ using \<open>a = \<infinity>\<^sub>h\<close> assms * hh
	+ by simp (subst (asm) inf_in_circline_set, transfer, transfer, simp)
	+ next
	+ case False
	+ then obtain z' where "z = of_complex z'"
	+ using inf_or_of_complex
	+ by auto
	+ hence "z \<in> circline_set (mk_circline ?A ?B ?C ?D)"
	+ using assms *
	+ by simp
	+ hence "- (cor r)\<^sup>2 * z'*cnj z' + 4 - (cor r)\<^sup>2 = 0"
	+ using hh
	+ unfolding circline_set_def
	+ apply (subst (asm) \<open>z = of_complex z'\<close>)
	+ by (simp, transfer, transfer, simp add: vec_cnj_def, algebra)
	+ hence "4 - (cor r)\<^sup>2 * (1 + (z'*cnj z')) = 0"
	+ by (simp add: field_simps)
	+ hence "Re (4 - (cor r)\<^sup>2 * (1 + (z' * cnj z'))) = 0"
	+ by simp
	+ hence "4 = r\<^sup>2 * (1 + (cmod z')\<^sup>2)"
	+ by (subst cmod_square) (simp add: power2_eq_square)
	+ hence "2 = r * sqrt (1 + (cmod z')\<^sup>2)"
	+ using \<open>r \<ge> 0\<close>
	+ by (subst (asm) real_sqrt_eq_iff[symmetric]) (simp add: real_sqrt_mult)
	+ moreover
	+ have "sqrt (1 + (cmod z')\<^sup>2) \<noteq> 0"
	+ using sqrt_1_plus_square
	+ by simp
	+ ultimately
	+ have "2 / sqrt (1 + (cmod z')\<^sup>2) = r"
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using \<open>z = of_complex z'\<close> \<open>a = \<infinity>\<^sub>h\<close>
	+ using dist_fs_infinite2[of z']
	+ by (simp add: dist_fs_sym)
	+ qed
	+qed
	+
	+text \<open>Two chordal centers and radii for the given circline\<close>
	+definition chordal_circles_cmat :: "complex_mat \<Rightarrow> (complex \<times> real) \<times> (complex \<times> real)" where
	+ [simp]: "chordal_circles_cmat H =
	+ (let (A, B, C, D) = H;
	+ dsc = sqrt(Re ((D-A)\<^sup>2 + 4 * (B*cnj B)));
	+ a1 = (A - D + cor dsc) / (2 * C);
	+ r1 = sqrt((4 - Re((-4 * a1/B) * A)) / (1 + Re (a1*cnj a1)));
	+ a2 = (A - D - cor dsc) / (2 * C);
	+ r2 = sqrt((4 - Re((-4 * a2/B) * A)) / (1 + Re (a2*cnj a2)))
	+ in ((a1, r1), (a2, r2)))"
	+
	+lift_definition chordal_circles_clmat :: "circline_mat \<Rightarrow> (complex \<times> real) \<times> (complex \<times> real)" is chordal_circles_cmat
	+ done
	+
	+lift_definition chordal_circles :: "ocircline \<Rightarrow> (complex \<times> real) \<times> (complex \<times> real)" is chordal_circles_clmat
	+proof transfer
	+ fix H1 H2 :: complex_mat
	+ obtain A1 B1 C1 D1 where hh1: "(A1, B1, C1, D1) = H1"
	+ by (cases H1) auto
	+ obtain A2 B2 C2 D2 where hh2: "(A2, B2, C2, D2) = H2"
	+ by (cases H2) auto
	+
	+ assume "ocircline_eq_cmat H1 H2"
	+ then obtain k where : "k > 0" "A2 = cor k A1" "B2 = cor k * B1" "C2 = cor k * C1" "D2 = cor k * D1"
	+ using hh1[symmetric] hh2[symmetric]
	+ by auto
	+ let ?dsc1 = "sqrt (Re ((D1 - A1)\<^sup>2 + 4 * (B1 * cnj B1)))" and ?dsc2 = "sqrt (Re ((D2 - A2)\<^sup>2 + 4 * (B2 * cnj B2)))"
	+ let ?a11 = "(A1 - D1 + cor ?dsc1) / (2 * C1)" and ?a12 = "(A2 - D2 + cor ?dsc2) / (2 * C2)"
	+ let ?a21 = "(A1 - D1 - cor ?dsc1) / (2 * C1)" and ?a22 = "(A2 - D2 - cor ?dsc2) / (2 * C2)"
	+ let ?r11 = "sqrt((4 - Re((-4 * ?a11/B1) * A1)) / (1 + Re (?a11*cnj ?a11)))"
	+ let ?r12 = "sqrt((4 - Re((-4 * ?a12/B2) * A2)) / (1 + Re (?a12*cnj ?a12)))"
	+ let ?r21 = "sqrt((4 - Re((-4 * ?a21/B1) * A1)) / (1 + Re (?a21*cnj ?a21)))"
	+ let ?r22 = "sqrt((4 - Re((-4 * ?a22/B2) * A2)) / (1 + Re (?a22*cnj ?a22)))"
	+
	+ have "Re ((D2 - A2)\<^sup>2 + 4 * (B2 * cnj B2)) = k\<^sup>2 * Re ((D1 - A1)\<^sup>2 + 4 * (B1 * cnj B1))"
	+ using *
	+ by (simp add: power2_eq_square field_simps)
	+ hence "?dsc2 = k * ?dsc1"
	+ using \<open>k > 0\<close>
	+ by (simp add: real_sqrt_mult)
	+ hence "A2 - D2 + cor ?dsc2 = cor k * (A1 - D1 + cor ?dsc1)" "A2 - D2 - cor ?dsc2 = cor k * (A1 - D1 - cor ?dsc1)" "2C2 = cor k (2*C1)"
	+ using *
	+ by (auto simp add: field_simps)
	+ hence "?a12 = ?a11" "?a22 = ?a21"
	+ using \<open>k > 0\<close>
	+ by simp_all
	+ moreover
	+ have "Re((-4 * ?a12/B2) * A2) = Re((-4 * ?a11/B1) * A1)"
	+ using *
	+ by (subst \<open>?a12 = ?a11\<close>) (simp, simp add: field_simps)
	+ have "?r12 = ?r11"
	+ by (subst \<open>Re((-4 * ?a12/B2) * A2) = Re((-4 * ?a11/B1) * A1)\<close>, (subst \<open>?a12 = ?a11\<close>)+) simp
	+ moreover
	+ have "Re((-4 * ?a22/B2) * A2) = Re((-4 * ?a21/B1) * A1)"
	+ using *
	+ by (subst \<open>?a22 = ?a21\<close>) (simp, simp add: field_simps)
	+ have "?r22 = ?r21"
	+ by (subst \<open>Re((-4 * ?a22/B2) * A2) = Re((-4 * ?a21/B1) * A1)\<close>, (subst \<open>?a22 = ?a21\<close>)+) simp
	+ moreover
	+ have "chordal_circles_cmat H1 = ((?a11, ?r11), (?a21, ?r21))"
	+ using hh1[symmetric]
	+ unfolding chordal_circles_cmat_def Let_def
	+ by (simp del: times_complex.sel)
	+ moreover
	+ have "chordal_circles_cmat H2 = ((?a12, ?r12), (?a22, ?r22))"
	+ using hh2[symmetric]
	+ unfolding chordal_circles_cmat_def Let_def
	+ by (simp del: times_complex.sel)
	+ ultimately
	+ show "chordal_circles_cmat H1 = chordal_circles_cmat H2"
	+ by metis
	+qed
	+
	+lemma chordal_circle_radius_positive:
	+ assumes "hermitean (A, B, C, D)" and "Re (mat_det (A, B, C, D)) \<le> 0" and "B \<noteq> 0" and
	+ "dsc = sqrt(Re ((D-A)\<^sup>2 + 4 * (B*cnj B)))" and
	+ "a1 = (A - D + cor dsc) / (2 * C)" and "a2 = (A - D - cor dsc) / (2 * C)"
	+ shows "Re (Aa1/B) \<ge> -1 \<and> Re (Aa2/B) \<ge> -1"
	+proof-
	+ from assms have "is_real A" "is_real D" "C = cnj B"
	+ using hermitean_elems
	+ by auto
	+ have : "Aa1/B = ((A - D + cor dsc) / (2 * (B * cnj B))) * A"
	+ using \<open>B \<noteq> 0\<close> \<open>C = cnj B\<close> \<open>a1 = (A - D + cor dsc) / (2 * C)\<close>
	+ by (simp add: field_simps) algebra
	+ have *: "Aa2/B = ((A - D - cor dsc) / (2 * (B * cnj B))) * A"
	+ using \<open>B \<noteq> 0\<close> \<open>C = cnj B\<close> \<open>a2 = (A - D - cor dsc) / (2 * C)\<close>
	+ by (simp add: field_simps) algebra
	+ have "dsc \<ge> 0"
	+ proof-
	+ have "0 \<le> Re ((D - A)\<^sup>2) + 4 * Re ((cor (cmod B))\<^sup>2)"
	+ using \<open>is_real A\<close> \<open>is_real D\<close>
	+ by (subst cor_squared, subst Re_complex_of_real) (simp add: power2_eq_square)
	+ thus ?thesis
	+ using \<open>dsc = sqrt(Re ((D-A)\<^sup>2 + 4(Bcnj B)))\<close>
	+ by (subst (asm) complex_mult_cnj_cmod) simp
	+ qed
	+ hence "Re (A - D - cor dsc) \<le> Re (A - D + cor dsc)"
	+ by simp
	+ moreover
	+ have "Re (2 * (B * cnj B)) > 0"
	+ using \<open>B \<noteq> 0\<close>
	+ by (subst complex_mult_cnj_cmod, simp add: power2_eq_square)
	+ ultimately
	+ have xxx: "Re (A - D + cor dsc) / Re (2 * (B * cnj B)) \<ge> Re (A - D - cor dsc) / Re (2 * (B * cnj B))" (is "?lhs \<ge> ?rhs")
	+ by (metis divide_right_mono less_eq_real_def)
	+
	+ have "Re A * Re D \<le> Re (B*cnj B)"
	+ using \<open>Re (mat_det (A, B, C, D)) \<le> 0\<close> \<open>C = cnj B\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ by simp
	+
	+
	+ have "(Re (2 * (B * cnj B)) / Re A) / Re (2 * B * cnj B) = 1 / Re A"
	+ using \<open>Re (2 * (B * cnj B)) > 0\<close>
	+ apply (subst divide_divide_eq_left)
	+ apply (subst mult.assoc)
	+ apply (subst nonzero_divide_mult_cancel_right)
	+ by simp_all
	+
	+ show ?thesis
	+ proof (cases "Re A > 0")
	+ case True
	+ hence "Re (Aa1/B) \<ge> Re (Aa2/B)"
	+ using * ** \<open>Re (2 * (B * cnj B)) > 0\<close> \<open>B \<noteq> 0\<close> \<open>is_real A\<close> \<open>is_real D\<close> xxx
	+ using mult_right_mono[of ?rhs ?lhs "Re A"]
	+ apply simp
	+ apply (subst Re_divide_real, simp, simp)
	+ apply (subst Re_divide_real, simp, simp)
	+ apply (subst Re_mult_real, simp)+
	+ apply simp
	+ done
	+ moreover
	+ have "Re (A*a2/B) \<ge> -1"
	+ proof-
	+ from \<open>Re A * Re D \<le> Re (B*cnj B)\<close>
	+ have "Re (A\<^sup>2) \<le> Re (Bcnj B) + Re ((A - D)A)"
	+ using \<open>Re A > 0\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ by (simp add: power2_eq_square field_simps)
	+ have "1 \<le> Re (B*cnj B) / Re (A\<^sup>2) + Re (A - D) / Re A"
	+ using \<open>Re A > 0\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ using divide_right_mono[OF \<open>Re (A\<^sup>2) \<le> Re (Bcnj B) + Re ((A - D)A)\<close>, of "Re (A\<^sup>2)"]
	+ by (simp add: power2_eq_square add_divide_distrib)
	+ have "4 * Re(Bcnj B) \<le> 4 (Re (Bcnj B))\<^sup>2 / Re (A\<^sup>2) + 2Re (A - D) / Re A * 2 * Re(B*cnj B)"
	+ using mult_right_mono[OF \<open>1 \<le> Re (Bcnj B) / Re (A\<^sup>2) + Re (A - D) / Re A\<close>, of "4 Re (B*cnj B)"]
	+ by (simp add: distrib_right) (simp add: power2_eq_square field_simps)
	+ moreover
	+ have "A \<noteq> 0"
	+ using \<open>Re A > 0\<close>
	+ by auto
	+ hence "4 * (Re (Bcnj B))\<^sup>2 / Re (A\<^sup>2) = Re (4 (B*cnj B)\<^sup>2 / A\<^sup>2)"
	+ using Re_divide_real[of "A\<^sup>2" "4 * (B*cnj B)\<^sup>2"] \<open>Re A > 0\<close> \<open>is_real A\<close>
	+ by (auto simp add: power2_eq_square)
	+ moreover
	+ have "2Re (A - D) / Re A 2 * Re(Bcnj B) = Re (2 (A - D) / A * 2 * B * cnj B)"
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> 0\<close>
	+ using Re_divide_real[of "A" "(4 * A - 4 * D) * B * cnj B"]
	+ by (simp add: field_simps)
	+ ultimately
	+ have "Re ((D - A)\<^sup>2 + 4 * Bcnj B) \<le> Re((A - D)\<^sup>2 + 4 (Bcnj B)\<^sup>2 / A\<^sup>2 + 2(A - D) / A * 2 * B*cnj B)"
	+ by (simp add: field_simps power2_eq_square)
	+ hence "Re ((D - A)\<^sup>2 + 4 * Bcnj B) \<le> Re(((A - D) + 2 B*cnj B / A)\<^sup>2)"
	+ using \<open>A \<noteq> 0\<close>
	+ by (subst power2_sum) (simp add: power2_eq_square field_simps)
	+ hence "dsc \<le> sqrt (Re(((A - D) + 2 * B*cnj B / A)\<^sup>2))"
	+ using \<open>dsc = sqrt(Re ((D-A)\<^sup>2 + 4(Bcnj B)))\<close>
	+ by simp
	+ moreover
	+ have "Re(((A - D) + 2 * Bcnj B / A)\<^sup>2) = (Re((A - D) + 2 B*cnj B / A))\<^sup>2"
	+ using \<open>is_real A\<close> \<open>is_real D\<close> div_reals
	+ by (simp add: power2_eq_square)
	+ ultimately
	+ have "dsc \<le> \<bar>Re (A - D + 2 * B * cnj B / A)\<bar>"
	+ by simp
	+ moreover
	+ have "Re (A - D + 2 * B * cnj B / A) \<ge> 0"
	+ proof-
	+ have : "Re (A\<^sup>2 + Bcnj B) \<ge> 0"
	+ using \<open>is_real A\<close>
	+ by (simp add: power2_eq_square)
	+ also have "Re (A\<^sup>2 + 2Bcnj B - AD) \<ge> Re (A\<^sup>2 + Bcnj B)"
	+ using \<open>Re A * Re D \<le> Re (B*cnj B)\<close>
	+ using \<open>is_real A\<close> \<open>is_real D\<close>
	+ by simp
	+ finally
	+ have "Re (A\<^sup>2 + 2Bcnj B - A*D) \<ge> 0"
	+ by simp
	+ show ?thesis
	+ using divide_right_mono[OF \<open>Re (A\<^sup>2 + 2Bcnj B - A*D) \<ge> 0\<close>, of "Re A"] \<open>Re A > 0\<close> \<open>is_real A\<close> \<open>A \<noteq> 0\<close>
	+ by (simp add: add_divide_distrib diff_divide_distrib) (subst Re_divide_real, auto simp add: power2_eq_square field_simps)
	+ qed
	+ ultimately
	+ have "dsc \<le> Re (A - D + 2 * B * cnj B / A)"
	+ by simp
	+ hence "- Re (2 * (B * cnj B) / A) \<le> Re ((A - D - cor dsc))"
	+ by (simp add: field_simps)
	+ hence : "- (Re (2 (B * cnj B)) / Re A) \<le> Re (A - D - cor dsc)"
	+ using \<open>is_real A\<close> \<open>A \<noteq> 0\<close>
	+ by (subst (asm) Re_divide_real, auto)
	+ from divide_right_mono[OF this, of "Re (2 * B * cnj B)"]
	+ have "- 1 / Re A \<le> Re (A - D - cor dsc) / Re (2 * B * cnj B)"
	+ using \<open>Re A > 0\<close> \<open>B \<noteq> 0\<close> \<open>A \<noteq> 0\<close> \<open>0 < Re (2 * (B * cnj B))\<close>
	+ using \<open>(Re (2 * (B * cnj B)) / Re A) / Re (2 * B * cnj B) = 1 / Re A\<close>
	+ by simp
	+ from mult_right_mono[OF this, of "Re A"]
	+ show ?thesis
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>B \<noteq> 0\<close> \<open>Re A > 0\<close> \<open>A \<noteq> 0\<close>
	+ apply (subst **)
	+ apply (subst Re_mult_real, simp)
	+ apply (subst Re_divide_real, simp, simp)
	+ apply (simp add: field_simps)
	+ done
	+ qed
	+ ultimately
	+ show ?thesis
	+ by simp
	+ next
	+ case False
	+ show ?thesis
	+ proof (cases "Re A < 0")
	+ case True
	+ hence "Re (Aa1/B) \<le> Re (Aa2/B)"
	+ using * ** \<open>Re (2 * (B * cnj B)) > 0\<close> \<open>B \<noteq> 0\<close> \<open>is_real A\<close> \<open>is_real D\<close> xxx
	+ using mult_right_mono_neg[of ?rhs ?lhs "Re A"]
	+ apply simp
	+ apply (subst Re_divide_real, simp, simp)
	+ apply (subst Re_divide_real, simp, simp)
	+ apply (subst Re_mult_real, simp)+
	+ apply simp
	+ done
	+ moreover
	+ have "Re (A*a1/B) \<ge> -1"
	+ proof-
	+ from \<open>Re A * Re D \<le> Re (B*cnj B)\<close>
	+ have "Re (A\<^sup>2) \<le> Re (Bcnj B) - Re ((D - A)A)"
	+ using \<open>Re A < 0\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ by (simp add: power2_eq_square field_simps)
	+ hence "1 \<le> Re (B*cnj B) / Re (A\<^sup>2) - Re (D - A) / Re A"
	+ using \<open>Re A < 0\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ using divide_right_mono[OF \<open>Re (A\<^sup>2) \<le> Re (Bcnj B) - Re ((D - A)A)\<close>, of "Re (A\<^sup>2)"]
	+ by (simp add: power2_eq_square diff_divide_distrib)
	+ have "4 * Re(Bcnj B) \<le> 4 (Re (Bcnj B))\<^sup>2 / Re (A\<^sup>2) - 2Re (D - A) / Re A * 2 * Re(B*cnj B)"
	+ using mult_right_mono[OF \<open>1 \<le> Re (Bcnj B) / Re (A\<^sup>2) - Re (D - A) / Re A\<close>, of "4 Re (B*cnj B)"]
	+ by (simp add: left_diff_distrib) (simp add: power2_eq_square field_simps)
	+ moreover
	+ have "A \<noteq> 0"
	+ using \<open>Re A < 0\<close>
	+ by auto
	+ hence "4 * (Re (Bcnj B))\<^sup>2 / Re (A\<^sup>2) = Re (4 (B*cnj B)\<^sup>2 / A\<^sup>2)"
	+ using Re_divide_real[of "A\<^sup>2" "4 * (B*cnj B)\<^sup>2"] \<open>Re A < 0\<close> \<open>is_real A\<close>
	+ by (auto simp add: power2_eq_square)
	+ moreover
	+ have "2Re (D - A) / Re A 2 * Re(Bcnj B) = Re (2 (D - A) / A * 2 * B * cnj B)"
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> 0\<close>
	+ using Re_divide_real[of "A" "(4 * D - 4 * A) * B * cnj B"]
	+ by (simp add: field_simps)
	+ ultimately
	+ have "Re ((D - A)\<^sup>2 + 4 * Bcnj B) \<le> Re((D - A)\<^sup>2 + 4 (Bcnj B)\<^sup>2 / A\<^sup>2 - 2(D - A) / A * 2 * B*cnj B)"
	+ by (simp add: field_simps power2_eq_square)
	+ hence "Re ((D - A)\<^sup>2 + 4 * Bcnj B) \<le> Re(((D - A) - 2 B*cnj B / A)\<^sup>2)"
	+ using \<open>A \<noteq> 0\<close>
	+ by (subst power2_diff) (simp add: power2_eq_square field_simps)
	+ hence "dsc \<le> sqrt (Re(((D - A) - 2 * B*cnj B / A)\<^sup>2))"
	+ using \<open>dsc = sqrt(Re ((D-A)\<^sup>2 + 4(Bcnj B)))\<close>
	+ by simp
	+ moreover
	+ have "Re(((D - A) - 2 * Bcnj B / A)\<^sup>2) = (Re((D - A) - 2 B*cnj B / A))\<^sup>2"
	+ using \<open>is_real A\<close> \<open>is_real D\<close> div_reals
	+ by (simp add: power2_eq_square)
	+ ultimately
	+ have "dsc \<le> \<bar>Re (D - A - 2 * B * cnj B / A)\<bar>"
	+ by simp
	+ moreover
	+ have "Re (D - A - 2 * B * cnj B / A) \<ge> 0"
	+ proof-
	+ have "Re (A\<^sup>2 + B*cnj B) \<ge> 0"
	+ using \<open>is_real A\<close>
	+ by (simp add: power2_eq_square)
	+ also have "Re (A\<^sup>2 + 2Bcnj B - AD) \<ge> Re (A\<^sup>2 + Bcnj B)"
	+ using \<open>Re A * Re D \<le> Re (B*cnj B)\<close>
	+ using \<open>is_real A\<close> \<open>is_real D\<close>
	+ by simp
	+ finally have "Re (A\<^sup>2 + 2Bcnj B - A*D) \<ge> 0"
	+ by simp
	+ show ?thesis
	+ using divide_right_mono_neg[OF \<open>Re (A\<^sup>2 + 2Bcnj B - A*D) \<ge> 0\<close>, of "Re A"] \<open>Re A < 0\<close> \<open>is_real A\<close> \<open>A \<noteq> 0\<close>
	+ by (simp add: add_divide_distrib diff_divide_distrib) (subst Re_divide_real, auto simp add: power2_eq_square field_simps)
	+ qed
	+ ultimately
	+ have "dsc \<le> Re (D - A - 2 * B * cnj B / A)"
	+ by simp
	+ hence "- Re (2 * (B * cnj B) / A) \<ge> Re ((A - D + cor dsc))"
	+ by (simp add: field_simps)
	+ hence "- (Re (2 * (B * cnj B)) / Re A) \<ge> Re (A - D + cor dsc)"
	+ using \<open>is_real A\<close> \<open>A \<noteq> 0\<close>
	+ by (subst (asm) Re_divide_real, auto)
	+ from divide_right_mono[OF this, of "Re (2 * B * cnj B)"]
	+ have "- 1 / Re A \<ge> Re (A - D + cor dsc) / Re (2 * B * cnj B)"
	+ using \<open>Re A < 0\<close> \<open>B \<noteq> 0\<close> \<open>A \<noteq> 0\<close> \<open>0 < Re (2 * (B * cnj B))\<close>
	+ using \<open>(Re (2 * (B * cnj B)) / Re A) / Re (2 * B * cnj B) = 1 / Re A\<close>
	+ by simp
	+ from mult_right_mono_neg[OF this, of "Re A"]
	+ show ?thesis
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>B \<noteq> 0\<close> \<open>Re A < 0\<close> \<open>A \<noteq> 0\<close>
	+ apply (subst *)
	+ apply (subst Re_mult_real, simp)
	+ apply (subst Re_divide_real, simp, simp)
	+ apply (simp add: field_simps)
	+ done
	+ qed
	+ ultimately
	+ show ?thesis
	+ by simp
	+ next
	+ case False
	+ hence "A = 0"
	+ using \<open>\<not> Re A > 0\<close> \<open>is_real A\<close>
	+ using complex_eq_if_Re_eq by auto
	+ thus ?thesis
	+ by simp
	+ qed
	+ qed
	+qed
	+
	+
	+lemma chordal_circle_det_positive:
	+ fixes x y :: real
	+ assumes "x * y < 0"
	+ shows "x / (x - y) > 0"
	+proof (cases "x > 0")
	+ case True
	+ hence "y < 0"
	+ using \<open>x * y < 0\<close>
	+ by (smt mult_nonneg_nonneg)
	+ have "x - y > 0"
	+ using \<open>x > 0\<close> \<open>y < 0\<close>
	+ by auto
	+ thus ?thesis
	+ using \<open>x > 0\<close>
	+ by (metis zero_less_divide_iff)
	+next
	+ case False
	+ hence *: "y > 0 \<and> x < 0"
	+ using \<open>x * y < 0\<close>
	+ using mult_nonpos_nonpos[of x y]
	+ by (cases "x=0") force+
	+
	+ have "x - y < 0"
	+ using *
	+ by auto
	+ thus ?thesis
	+ using *
	+ by (metis zero_less_divide_iff)
	+qed
	+
	+lemma chordal_circle1:
	+ assumes "is_real A" and "is_real D" and "Re (A * D) < 0" and "r = sqrt(Re ((4*A)/(A-D)))"
	+ shows "mk_circline A 0 0 D = chordal_circle \<infinity>\<^sub>h r"
	+using assms
	+proof (transfer, transfer)
	+ fix A D r
	+ assume : "is_real A" "is_real D" "Re (A D) < 0" "r = sqrt (Re ((4*A)/(A-D)))"
	+ hence "A \<noteq> 0 \<or> D \<noteq> 0"
	+ by auto
	+ hence "(A, 0, 0, D) \<in> hermitean_nonzero"
	+ using eq_cnj_iff_real[of A] eq_cnj_iff_real[of D] *
	+ unfolding hermitean_def
	+ by (simp add: mat_adj_def mat_cnj_def)
	+ moreover
	+ have "(- (cor r)\<^sup>2, 0, 0, 4 - (cor r)\<^sup>2) \<in> hermitean_nonzero"
	+ by (simp add: hermitean_def mat_adj_def mat_cnj_def power2_eq_square)
	+ moreover
	+ have "A \<noteq> D"
	+ using \<open>Re (A * D) < 0\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ by auto
	+ have "Re ((4*A)/(A-D)) \<ge> 0"
	+ proof-
	+ have "Re A / Re (A - D) \<ge> 0"
	+ using \<open>Re (A * D) < 0\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ using chordal_circle_det_positive[of "Re A" "Re D"]
	+ by simp
	+ thus ?thesis
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> D\<close>
	+ by (subst Re_divide_real, auto)
	+ qed
	+ moreover
	+ have "- (cor (sqrt (Re (4 * A / (A - D)))))\<^sup>2 = cor (Re (4 / (D - A))) * A"
	+ using \<open>Re ((4*A)/(A-D)) \<ge> 0\<close> \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> D\<close>
	+ by (subst cor_squared, subst real_sqrt_power[symmetric], simp) (simp add: Re_divide_real Re_mult_real minus_divide_right)
	+ moreover
	+ have "4 * (A - D) - 4 * A = 4 * -D"
	+ by (simp add: field_simps)
	+ hence "4 - 4 * A / (A - D) = -4 * D / (A - D)"
	+ using \<open>A \<noteq> D\<close>
	+ by (smt ab_semigroup_mult_class.mult_ac(1) diff_divide_eq_iff eq_iff_diff_eq_0 mult_minus1 mult_minus1_right mult_numeral_1_right right_diff_distrib_numeral times_divide_eq_right)
	+ hence "4 - 4 * A / (A - D) = 4 * D / (D - A)"
	+ by (metis (hide_lams, no_types) minus_diff_eq minus_divide_left minus_divide_right minus_mult_left)
	+ hence *: "4 - (cor (sqrt (Re (4 A / (A - D)))))\<^sup>2 = cor (Re (4 / (D - A))) * D"
	+ using \<open>Re ((4*A)/(A-D)) \<ge> 0\<close> \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> D\<close>
	+ by (subst cor_squared, subst real_sqrt_power[symmetric], simp)
	+ ultimately
	+ show "circline_eq_cmat (mk_circline_cmat A 0 0 D) (chordal_circle_cvec_cmat \<infinity>\<^sub>v r)"
	+ using * \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> D\<close> \<open>r = sqrt(Re ((4*A)/(A-D)))\<close>
	+ by (simp, rule_tac x="Re(4/(D-A))" in exI, auto, simp_all add: **)
	+qed
	+
	+lemma chordal_circle2:
	+ assumes "is_real A" and "is_real D" and "Re (A * D) < 0" and "r = sqrt(Re ((4*D)/(D-A)))"
	+ shows "mk_circline A 0 0 D = chordal_circle 0\<^sub>h r"
	+using assms
	+proof (transfer, transfer)
	+ fix A D r
	+ assume : "is_real A" "is_real D" "Re (A D) < 0" "r = sqrt (Re ((4*D)/(D-A)))"
	+ hence "A \<noteq> 0 \<or> D \<noteq> 0"
	+ by auto
	+ hence "(A, 0, 0, D) \<in> {H. hermitean H \<and> H \<noteq> mat_zero}"
	+ using eq_cnj_iff_real[of A] eq_cnj_iff_real[of D] *
	+ unfolding hermitean_def
	+ by (simp add: mat_adj_def mat_cnj_def)
	+ moreover
	+ have "(4 - (cor r)\<^sup>2, 0, 0, - (cor r)\<^sup>2) \<in> {H. hermitean H \<and> H \<noteq> mat_zero}"
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def power2_eq_square)
	+ moreover
	+ have "A \<noteq> D"
	+ using \<open>Re (A * D) < 0\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ by auto
	+ have "Re((4*D)/(D-A)) \<ge> 0"
	+ proof-
	+ have "Re D / Re (D - A) \<ge> 0"
	+ using \<open>Re (A * D) < 0\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ using chordal_circle_det_positive[of "Re D" "Re A"]
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> D\<close>
	+ by (subst Re_divide_real, auto)
	+ qed
	+ have "4 * (D - A) - 4 * D = 4 * -A"
	+ by (simp add: field_simps)
	+ hence "4 - 4 * D / (D - A) = -4 * A / (D - A)"
	+ using \<open>A \<noteq> D\<close>
	+ by (smt ab_semigroup_mult_class.mult_ac(1) diff_divide_eq_iff eq_iff_diff_eq_0 mult_minus1 mult_minus1_right mult_numeral_1_right right_diff_distrib_numeral times_divide_eq_right)
	+ hence "4 - 4 * D / (D - A) = 4 * A / (A - D)"
	+ by (metis (hide_lams, no_types) minus_diff_eq minus_divide_left minus_divide_right minus_mult_left)
	+ hence *: "4 - (cor (sqrt (Re ((4D)/(D-A)))))\<^sup>2 = cor (Re (4 / (A - D))) * A"
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> D\<close> \<open>Re (4 * D / (D - A)) \<ge> 0\<close>
	+ by (subst cor_squared, subst real_sqrt_power[symmetric], simp)
	+
	+ moreover
	+ have "- (cor (sqrt (Re ((4D)/(D-A)))))\<^sup>2 = cor (Re (4 / (A - D))) D"
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> D\<close> \<open>Re ((4*D)/(D-A)) \<ge> 0\<close>
	+ by (subst cor_squared, subst real_sqrt_power[symmetric], simp) (simp add: Re_divide_real minus_divide_right)
	+
	+ ultimately
	+ show "circline_eq_cmat (mk_circline_cmat A 0 0 D) (chordal_circle_cvec_cmat 0\<^sub>v r)"
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> 0 \<or> D \<noteq> 0\<close> \<open>r = sqrt (Re ((4*D)/(D-A)))\<close>
	+ using *
	+ by (simp, rule_tac x="Re (4/(A-D))" in exI, auto, simp_all add: **)
	+qed
	+
	+lemma chordal_circle':
	+ assumes "B \<noteq> 0" and "(A, B, C, D) \<in> hermitean_nonzero" and "Re (mat_det (A, B, C, D)) \<le> 0" and
	+ "C * a\<^sup>2 + (D - A) * a - B = 0" and "r = sqrt((4 - Re((-4 * a/B) * A)) / (1 + Re (a*cnj a)))"
	+ shows "mk_circline A B C D = chordal_circle (of_complex a) r"
	+using assms
	+proof (transfer, transfer)
	+ fix A B C D a :: complex and r :: real
	+
	+ let ?k = "(-4) * a / B"
	+
	+ assume : "(A, B, C, D) \<in> {H. hermitean H \<and> H \<noteq> mat_zero}" and : "B \<noteq> 0" "C a\<^sup>2 + (D - A) * a - B = 0" and rr: "r = sqrt ((4 - Re (?k * A)) / (1 + Re (a * cnj a)))" and det: "Re (mat_det (A, B, C, D)) \<le> 0"
	+
	+ have "is_real A" "is_real D" "C = cnj B"
	+ using * hermitean_elems
	+ by auto
	+
	+ from ** have a12: "let dsc = sqrt(Re ((D-A)\<^sup>2 + 4 * (B*cnj B)))
	+ in a = (A - D + cor dsc) / (2 * C) \<or> a = (A - D - cor dsc) / (2 * C)"
	+ proof-
	+ have "Re ((D-A)\<^sup>2 + 4 * (B*cnj B)) \<ge> 0"
	+ using \<open>is_real A\<close> \<open>is_real D\<close>
	+ by (subst complex_mult_cnj_cmod) (simp add: power2_eq_square)
	+ hence "ccsqrt ((D - A)\<^sup>2 - 4 * C * - B) = cor (sqrt (Re ((D - A)\<^sup>2 + 4 * (B * cnj B))))"
	+ using csqrt_real[of "((D - A)\<^sup>2 + 4 * (B * cnj B))"] \<open>is_real A\<close> \<open>is_real D\<close> \<open>C = cnj B\<close>
	+ by (auto simp add: power2_eq_square field_simps)
	+ thus ?thesis
	+ using complex_quadratic_equation_two_roots[of C a "D - A" "-B"]
	+ using \<open>C * a\<^sup>2 + (D - A) * a - B = 0\<close> \<open>B \<noteq> 0\<close> \<open>C = cnj B\<close>
	+ by (simp add: Let_def)
	+ qed
	+
	+ have "is_real ?k"
	+ using a12 \<open>C = cnj B\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ by (auto simp add: Let_def)
	+ have "a \<noteq> 0"
	+ using **
	+ by auto
	+ hence "Re ?k \<noteq> 0"
	+ using \<open>is_real (-4*a / B)\<close> \<open>B \<noteq> 0\<close>
	+ by (metis complex.expand divide_eq_0_iff divisors_zero zero_complex.simps(1) zero_complex.simps(2) zero_neq_neg_numeral)
	+ moreover
	+ have "(-4) * a = cor (Re ?k) * B"
	+ using complex_of_real_Re[OF \<open>is_real (-4*a/B)\<close>] \<open>B \<noteq> 0\<close>
	+ by simp
	+ moreover
	+ have "is_real (a/B)"
	+ using \<open>is_real ?k\<close> is_real_mult_real[of "-4" "a / B"]
	+ by simp
	+ hence "is_real (B * cnj a)"
	+ using * \<open>C = cnj B\<close>
	+ by (metis (no_types, lifting) Im_complex_div_eq_0 complex_cnj_divide eq_cnj_iff_real hermitean_elems(3) mem_Collect_eq mult.commute)
	+ hence "B * cnj a = cnj B * a"
	+ using eq_cnj_iff_real[of "B * cnj a"]
	+ by simp
	+ hence "-4 * cnj a = cor (Re ?k) * C"
	+ using \<open>C = cnj B\<close>
	+ using complex_of_real_Re[OF \<open>is_real ?k\<close>] \<open>B \<noteq> 0\<close>
	+ by (simp, simp add: field_simps)
	+ moreover
	+ have "1 + a * cnj a \<noteq> 0"
	+ by (subst complex_mult_cnj_cmod) (smt cor_add of_real_0 of_real_1 of_real_eq_iff realpow_square_minus_le)
	+ have "r\<^sup>2 = (4 - Re (?k * A)) / (1 + Re (a * cnj a))"
	+ proof-
	+ have "Re (a / B * A) \<ge> -1"
	+ using a12 chordal_circle_radius_positive[of A B C D] * \<open>B \<noteq> 0\<close> det
	+ by (auto simp add: Let_def field_simps)
	+ from mult_right_mono_neg[OF this, of "-4"]
	+ have "4 - Re (?k * A) \<ge> 0"
	+ using Re_mult_real[of "-4" "a / B * A"]
	+ by (simp add: field_simps)
	+ moreover
	+ have "1 + Re (a * cnj a) > 0"
	+ using \<open>a \<noteq> 0\<close> complex_mult_cnj complex_neq_0
	+ by auto
	+ ultimately
	+ have "(4 - Re (?k * A)) / (1 + Re (a * cnj a)) \<ge> 0"
	+ by (metis divide_nonneg_pos)
	+ thus ?thesis
	+ using rr
	+ by simp
	+ qed
	+ hence "r\<^sup>2 = Re ((4 - ?k * A) / (1 + a * cnj a))"
	+ using \<open>is_real ?k\<close> \<open>is_real A\<close> \<open>1 + a * cnj a \<noteq> 0\<close>
	+ by (subst Re_divide_real, auto)
	+ hence "(cor r)\<^sup>2 = (4 - ?k * A) / (1 + a * cnj a)"
	+ using \<open>is_real ?k\<close> \<open>is_real A\<close>
	+ using mult_reals[of ?k A]
	+ by (simp add: cor_squared)
	+ hence "4 - (cor r)\<^sup>2 * (a * cnj a + 1) = cor (Re ?k) * A"
	+ using complex_of_real_Re[OF \<open>is_real (-4*a/B)\<close>]
	+ using \<open>1 + a * cnj a \<noteq> 0\<close>
	+ by (simp add: field_simps)
	+ moreover
	+
	+ have "?k = cnj ?k"
	+ using \<open>is_real ?k\<close>
	+ using eq_cnj_iff_real[of "-4*a/B"]
	+ by simp
	+
	+ have "?k\<^sup>2 = cor ((cmod ?k)\<^sup>2)"
	+ using cor_cmod_real[OF \<open>is_real ?k\<close>]
	+ unfolding power2_eq_square
	+ by (subst cor_mult) (metis minus_mult_minus)
	+ hence "?k\<^sup>2 = ?k * cnj ?k"
	+ using complex_mult_cnj_cmod[of ?k]
	+ by simp
	+ hence **: "a cnj a = (cor ((Re ?k)\<^sup>2) * B * C) / 16"
	+ using complex_of_real_Re[OF \<open>is_real (-4a/B)\<close>] \<open>C = cnj B\<close> \<open>is_real (-4a/B)\<close> \<open>B \<noteq> 0\<close>
	+ by simp
	+ from ** have "cor ((Re ?k)\<^sup>2) * B * C - 4 * cor (Re ?k) * (D-A) - 16 = 0"
	+ using complex_of_real_Re[OF \<open>is_real ?k\<close>]
	+ by (simp add: power2_eq_square, simp add: field_simps, algebra)
	+ hence "?k * (D-A) = 4 * (cor ((Re ?k)\<^sup>2) * B * C / 16 - 1)"
	+ by (subst (asm) complex_of_real_Re[OF \<open>is_real ?k\<close>]) algebra
	+ hence "?k * (D-A) = 4 * (a*cnj a - 1)"
	+ by (subst (asm) ***[symmetric]) simp
	+
	+ hence "4 * a * cnj a - (cor r)\<^sup>2 * (a * cnj a + 1) = cor (Re ?k) * D"
	+ using \<open>4 - (cor r)\<^sup>2 * (a * cnj a + 1) = cor (Re ?k) * A\<close>
	+ using complex_of_real_Re[OF \<open>is_real (-4*a/B)\<close>]
	+ by simp algebra
	+ ultimately
	+ show "circline_eq_cmat (mk_circline_cmat A B C D) (chordal_circle_cvec_cmat (of_complex_cvec a) r)"
	+ using * \<open>a \<noteq> 0\<close>
	+ by (simp, rule_tac x="Re (-4*a / B)" in exI, simp)
	+qed
	+
	+end
	diff --git a/thys/Complex_Geometry/Circlines.thy b/thys/Complex_Geometry/Circlines.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Circlines.thy
	@@ -0,0 +1,2048 @@
	+(* ---------------------------------------------------------------------------- *)
	+section \<open>Circlines\<close>
	+(* ---------------------------------------------------------------------------- *)
	+theory Circlines
	+ imports More_Set Moebius Hermitean_Matrices Elementary_Complex_Geometry
	+begin
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Definition of circlines\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>In our formalization we follow the approach described by Schwerdtfeger
	+\cite{schwerdtfeger} and represent circlines by Hermitean, non-zero
	+$2\times 2$ matrices. In the original formulation, a matrix
	+$\left(\begin{array}{cc}A & B\\C & D\end{array}\right)$ corresponds to
	+the equation $A\cdot z\cdot \overline{z} + B\cdot \overline{z} + C\cdot z + D = 0$,
	+where $C = \overline{B}$ and $A$ and $D$ are real (as the matrix is
	+Hermitean).\<close>
	+
	+abbreviation hermitean_nonzero where
	+ "hermitean_nonzero \<equiv> {H. hermitean H \<and> H \<noteq> mat_zero}"
	+
	+typedef circline_mat = hermitean_nonzero
	+by (rule_tac x="eye" in exI) (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+
	+setup_lifting type_definition_circline_mat
	+
	+
	+definition circline_eq_cmat :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> bool" where
	+ [simp]: "circline_eq_cmat A B \<longleftrightarrow> (\<exists> k::real. k \<noteq> 0 \<and> B = cor k *\<^sub>s\<^sub>m A)"
	+
	+lemma symp_circline_eq_cmat: "symp circline_eq_cmat"
	+ unfolding symp_def
	+proof ((rule allI)+, rule impI)
	+ fix x y
	+ assume "circline_eq_cmat x y"
	+ then obtain k where "k \<noteq> 0 \<and> y = cor k *\<^sub>s\<^sub>m x"
	+ by auto
	+ hence "1 / k \<noteq> 0 \<and> x = cor (1 / k) *\<^sub>s\<^sub>m y"
	+ by auto
	+ thus "circline_eq_cmat y x"
	+ unfolding circline_eq_cmat_def
	+ by blast
	+qed
	+
	+text\<open>Hermitean non-zero matrices are equivalent only to such matrices\<close>
	+lemma circline_eq_cmat_hermitean_nonzero:
	+ assumes "hermitean H \<and> H \<noteq> mat_zero" "circline_eq_cmat H H'"
	+ shows "hermitean H' \<and> H' \<noteq> mat_zero"
	+ using assms
	+ by (metis circline_eq_cmat_def hermitean_mult_real nonzero_mult_real of_real_eq_0_iff)
	+
	+
	+lift_definition circline_eq_clmat :: "circline_mat \<Rightarrow> circline_mat \<Rightarrow> bool" is circline_eq_cmat
	+ done
	+
	+lemma circline_eq_clmat_refl [simp]: "circline_eq_clmat H H"
	+ by transfer (simp, rule_tac x="1" in exI, simp)
	+
	+quotient_type circline = circline_mat / circline_eq_clmat
	+proof (rule equivpI)
	+ show "reflp circline_eq_clmat"
	+ unfolding reflp_def
	+ by transfer (auto, rule_tac x="1" in exI, simp)
	+next
	+ show "symp circline_eq_clmat"
	+ unfolding symp_def
	+ by transfer (auto, (rule_tac x="1/k" in exI, simp)+)
	+next
	+ show "transp circline_eq_clmat"
	+ unfolding transp_def
	+ by transfer (simp, safe, (rule_tac x="ka*k" in exI, simp)+)
	+qed
	+
	+text \<open>Circline with specified matrix\<close>
	+
	+text \<open>An auxiliary constructor @{term mk_circline} returns a circline (an
	+equivalence class) for given four complex numbers $A$, $B$, $C$ and
	+$D$ (provided that they form a Hermitean, non-zero matrix).\<close>
	+
	+definition mk_circline_cmat :: "complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> complex_mat" where
	+[simp]: "mk_circline_cmat A B C D =
	+ (let M = (A, B, C, D)
	+ in if M \<in> hermitean_nonzero then
	+ M
	+ else
	+ eye)"
	+
	+lift_definition mk_circline_clmat :: "complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> circline_mat" is mk_circline_cmat
	+ by (auto simp add: Let_def hermitean_def mat_adj_def mat_cnj_def)
	+
	+lift_definition mk_circline :: "complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> circline" is mk_circline_clmat
	+ done
	+
	+lemma ex_mk_circline:
	+ shows "\<exists> A B C D. H = mk_circline A B C D \<and> hermitean (A, B, C, D) \<and> (A, B, C, D) \<noteq> mat_zero"
	+proof (transfer, transfer)
	+ fix H
	+ assume *: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where "H = (A, B, C, D)"
	+ by (cases " H", auto)
	+ hence "circline_eq_cmat H (mk_circline_cmat A B C D) \<and> hermitean (A, B, C, D) \<and> (A, B, C, D) \<noteq> mat_zero"
	+ using *
	+ by auto
	+ thus "\<exists> A B C D. circline_eq_cmat H (mk_circline_cmat A B C D) \<and> hermitean (A, B, C, D) \<and> (A, B, C, D) \<noteq> mat_zero"
	+ by blast
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Circline type\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+definition circline_type_cmat :: "complex_mat \<Rightarrow> real" where
	+ [simp]: "circline_type_cmat H = sgn (Re (mat_det H))"
	+
	+lift_definition circline_type_clmat :: "circline_mat \<Rightarrow> real" is circline_type_cmat
	+ done
	+
	+lift_definition circline_type :: "circline \<Rightarrow> real" is circline_type_clmat
	+ by transfer (simp, erule exE, simp add: sgn_mult)
	+
	+lemma circline_type: "circline_type H = -1 \<or> circline_type H = 0 \<or> circline_type H = 1"
	+ by (transfer, transfer, simp add: sgn_if)
	+
	+lemma circline_type_mk_circline [simp]:
	+ assumes "(A, B, C, D) \<in> hermitean_nonzero"
	+ shows "circline_type (mk_circline A B C D) = sgn (Re (AD - BC))"
	+ using assms
	+ by (transfer, transfer, simp)
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Points on the circline\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Each circline determines a corresponding set of points. Again, a description given in
	+homogeneous coordinates is a bit better than the original description defined only for ordinary
	+complex numbers. The point with homogeneous coordinates $(z_1, z_2)$ will belong to the set of
	+circline points iff $A \cdot z_1\cdot \overline{z_1} + B\cdot \overline{z_1} \cdot z_2 + C\cdot z_1 \cdot\overline{z_2} +
	+D\cdot z_2 \cdot \overline{z_2} = 0$. Note that this is a quadratic form determined by a vector of
	+homogeneous coordinates and the Hermitean matrix.\<close>
	+
	+definition on_circline_cmat_cvec :: "complex_mat \<Rightarrow> complex_vec \<Rightarrow> bool" where
	+ [simp]: "on_circline_cmat_cvec H z \<longleftrightarrow> quad_form z H = 0"
	+
	+lift_definition on_circline_clmat_hcoords :: "circline_mat \<Rightarrow> complex_homo_coords \<Rightarrow> bool" is on_circline_cmat_cvec
	+ done
	+
	+lift_definition on_circline :: "circline \<Rightarrow> complex_homo \<Rightarrow> bool" is on_circline_clmat_hcoords
	+ by transfer (simp del: quad_form_def, (erule exE)+, simp del: quad_form_def add: quad_form_scale_m quad_form_scale_v)
	+
	+definition circline_set :: "circline \<Rightarrow> complex_homo set" where
	+ "circline_set H = {z. on_circline H z}"
	+
	+lemma circline_set_I [simp]:
	+ assumes "on_circline H z"
	+ shows "z \<in> circline_set H"
	+ using assms
	+ unfolding circline_set_def
	+ by auto
	+
	+abbreviation circline_equation where
	+ "circline_equation A B C D z1 z2 \<equiv> Az1cnj z1 + Bz2cnj z1 + Ccnj z2z1 + Dz2cnj z2 = 0"
	+
	+lemma on_circline_cmat_cvec_circline_equation:
	+ "on_circline_cmat_cvec (A, B, C, D) (z1, z2) \<longleftrightarrow> circline_equation A B C D z1 z2"
	+ by (simp add: vec_cnj_def field_simps)
	+
	+lemma circline_equation:
	+ assumes "H = mk_circline A B C D" and "(A, B, C, D) \<in> hermitean_nonzero"
	+ shows "of_complex z \<in> circline_set H \<longleftrightarrow> circline_equation A B C D z 1"
	+ using assms
	+ unfolding circline_set_def
	+ by simp (transfer, transfer, simp add: vec_cnj_def field_simps)
	+
	+text \<open>Circlines trough 0 and inf.\<close>
	+text \<open>The circline represents a line when $A=0$ or a circle, otherwise.\<close>
	+
	+definition circline_A0_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "circline_A0_cmat H \<longleftrightarrow> (let (A, B, C, D) = H in A = 0)"
	+lift_definition circline_A0_clmat :: "circline_mat \<Rightarrow> bool" is circline_A0_cmat
	+ done
	+lift_definition circline_A0 :: "circline \<Rightarrow> bool" is circline_A0_clmat
	+ by transfer auto
	+
	+abbreviation is_line where
	+ "is_line H \<equiv> circline_A0 H"
	+
	+abbreviation is_circle where
	+ "is_circle H \<equiv> \<not> circline_A0 H"
	+
	+definition circline_D0_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "circline_D0_cmat H \<longleftrightarrow> (let (A, B, C, D) = H in D = 0)"
	+lift_definition circline_D0_clmat :: "circline_mat \<Rightarrow> bool" is circline_D0_cmat
	+ done
	+lift_definition circline_D0 :: "circline \<Rightarrow> bool" is circline_D0_clmat
	+ by transfer auto
	+
	+lemma inf_on_circline: "on_circline H \<infinity>\<^sub>h \<longleftrightarrow> circline_A0 H"
	+ by (transfer, transfer, auto simp add: vec_cnj_def)
	+
	+lemma
	+ inf_in_circline_set: "\<infinity>\<^sub>h \<in> circline_set H \<longleftrightarrow> is_line H"
	+ using inf_on_circline
	+ unfolding circline_set_def
	+ by simp
	+
	+lemma zero_on_circline: "on_circline H 0\<^sub>h \<longleftrightarrow> circline_D0 H"
	+ by (transfer, transfer, auto simp add: vec_cnj_def)
	+
	+lemma
	+ zero_in_circline_set: "0\<^sub>h \<in> circline_set H \<longleftrightarrow> circline_D0 H"
	+ using zero_on_circline
	+ unfolding circline_set_def
	+ by simp
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Connection with circles and lines in the classic complex plane\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Every Euclidean circle and Euclidean line can be represented by a
	+circline.\<close>
	+
	+lemma classic_circline:
	+ assumes "H = mk_circline A B C D" and "hermitean (A, B, C, D) \<and> (A, B, C, D) \<noteq> mat_zero"
	+ shows "circline_set H - {\<infinity>\<^sub>h} = of_complex ` circline (Re A) B (Re D)"
	+using assms
	+unfolding circline_set_def
	+proof (safe)
	+ fix z
	+ assume "hermitean (A, B, C, D)" "(A, B, C, D) \<noteq> mat_zero" "z \<in> circline (Re A) B (Re D)"
	+ thus "on_circline (mk_circline A B C D) (of_complex z)"
	+ using hermitean_elems[of A B C D]
	+ by (transfer, transfer) (auto simp add: circline_def vec_cnj_def field_simps)
	+next
	+ fix z
	+ assume "of_complex z = \<infinity>\<^sub>h"
	+ thus False
	+ by simp
	+next
	+ fix z
	+ assume "hermitean (A, B, C, D)" "(A, B, C, D) \<noteq> mat_zero" "on_circline (mk_circline A B C D) z" "z \<notin> of_complex ` circline (Re A) B (Re D)"
	+ moreover
	+ have "z \<noteq> \<infinity>\<^sub>h \<longrightarrow> z \<in> of_complex ` circline (Re A) B (Re D)"
	+ proof
	+ assume "z \<noteq> \<infinity>\<^sub>h"
	+ show "z \<in> of_complex ` circline (Re A) B (Re D)"
	+ proof
	+ show "z = of_complex (to_complex z)"
	+ using \<open>z \<noteq> \<infinity>\<^sub>h\<close>
	+ by simp
	+ next
	+ show "to_complex z \<in> circline (Re A) B (Re D)"
	+ using \<open>on_circline (mk_circline A B C D) z\<close> \<open>z \<noteq> \<infinity>\<^sub>h\<close>
	+ using \<open>hermitean (A, B, C, D)\<close> \<open>(A, B, C, D) \<noteq> mat_zero\<close>
	+ proof (transfer, transfer)
	+ fix A B C D and z :: complex_vec
	+ obtain z1 z2 where zz: "z = (z1, z2)"
	+ by (cases z, auto)
	+ assume *: "z \<noteq> vec_zero" "\<not> z \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ "on_circline_cmat_cvec (mk_circline_cmat A B C D) z"
	+ "hermitean (A, B, C, D)" "(A, B, C, D) \<noteq> mat_zero"
	+ have "z2 \<noteq> 0"
	+ using \<open>z \<noteq> vec_zero\<close> \<open>\<not> z \<approx>\<^sub>v \<infinity>\<^sub>v\<close>
	+ using inf_cvec_z2_zero_iff zz
	+ by blast
	+ thus "to_complex_cvec z \<in> circline (Re A) B (Re D)"
	+ using * zz
	+ using hermitean_elems[of A B C D]
	+ by (simp add: vec_cnj_def circline_def field_simps)
	+ qed
	+ qed
	+ qed
	+ ultimately
	+ show "z = \<infinity>\<^sub>h"
	+ by simp
	+qed
	+
	+text \<open>The matrix of the circline representing circle determined with center and radius.\<close>
	+definition mk_circle_cmat :: "complex \<Rightarrow> real \<Rightarrow> complex_mat" where
	+ [simp]: "mk_circle_cmat a r = (1, -a, -cnj a, acnj a - cor rcor r)"
	+
	+lift_definition mk_circle_clmat :: "complex \<Rightarrow> real \<Rightarrow> circline_mat" is mk_circle_cmat
	+ by (simp add: hermitean_def mat_adj_def mat_cnj_def)
	+
	+lift_definition mk_circle :: "complex \<Rightarrow> real \<Rightarrow> circline" is mk_circle_clmat
	+ done
	+
	+lemma is_circle_mk_circle: "is_circle (mk_circle a r)"
	+ by (transfer, transfer, simp)
	+
	+lemma circline_set_mk_circle [simp]:
	+ assumes "r \<ge> 0"
	+ shows "circline_set (mk_circle a r) = of_complex ` circle a r"
	+proof-
	+ let ?A = "1" and ?B = "-a" and ?C = "-cnj a" and ?D = "acnj a - cor rcor r"
	+ have *: "(?A, ?B, ?C, ?D) \<in> {H. hermitean H \<and> H \<noteq> mat_zero}"
	+ by (simp add: hermitean_def mat_adj_def mat_cnj_def)
	+ have "mk_circle a r = mk_circline ?A ?B ?C ?D"
	+ using *
	+ by (transfer, transfer, simp)
	+ hence "circline_set (mk_circle a r) - {\<infinity>\<^sub>h} = of_complex ` circline ?A ?B (Re ?D)"
	+ using classic_circline[of "mk_circle a r" ?A ?B ?C ?D] *
	+ by simp
	+ moreover
	+ have "circline ?A ?B (Re ?D) = circle a r"
	+ by (rule circline_circle[of ?A "Re ?D" "?B" "circline ?A ?B (Re ?D)" "a" "r*r" r], simp_all add: cmod_square \<open>r \<ge> 0\<close>)
	+ moreover
	+ have "\<infinity>\<^sub>h \<notin> circline_set (mk_circle a r)"
	+ using inf_in_circline_set[of "mk_circle a r"] is_circle_mk_circle[of a r]
	+ by auto
	+ ultimately
	+ show ?thesis
	+ unfolding circle_def
	+ by simp
	+qed
	+
	+text \<open>The matrix of the circline representing line determined with two (not equal) complex points.\<close>
	+definition mk_line_cmat :: "complex \<Rightarrow> complex \<Rightarrow> complex_mat" where
	+ [simp]: "mk_line_cmat z1 z2 =
	+ (if z1 \<noteq> z2 then
	+ let B = \<i> * (z2 - z1) in (0, B, cnj B, -cnj_mix B z1)
	+ else
	+ eye)"
	+
	+lift_definition mk_line_clmat :: "complex \<Rightarrow> complex \<Rightarrow> circline_mat" is mk_line_cmat
	+ by (auto simp add: Let_def hermitean_def mat_adj_def mat_cnj_def split: if_split_asm)
	+
	+lift_definition mk_line :: "complex \<Rightarrow> complex \<Rightarrow> circline" is mk_line_clmat
	+ done
	+
	+lemma circline_set_mk_line [simp]:
	+ assumes "z1 \<noteq> z2"
	+ shows "circline_set (mk_line z1 z2) - {\<infinity>\<^sub>h} = of_complex ` line z1 z2"
	+proof-
	+ let ?A = "0" and ?B = "\<i>*(z2 - z1)"
	+ let ?C = "cnj ?B" and ?D = "-cnj_mix ?B z1"
	+ have *: "(?A, ?B, ?C, ?D) \<in> {H. hermitean H \<and> H \<noteq> mat_zero}"
	+ using assms
	+ by (simp add: hermitean_def mat_adj_def mat_cnj_def)
	+ have "mk_line z1 z2 = mk_circline ?A ?B ?C ?D"
	+ using * assms
	+ by (transfer, transfer, auto simp add: Let_def)
	+ hence "circline_set (mk_line z1 z2) - {\<infinity>\<^sub>h} = of_complex ` circline ?A ?B (Re ?D)"
	+ using classic_circline[of "mk_line z1 z2" ?A ?B ?C ?D] *
	+ by simp
	+ moreover
	+ have "circline ?A ?B (Re ?D) = line z1 z2"
	+ using \<open>z1 \<noteq> z2\<close>
	+ using circline_line'
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by simp
	+qed
	+
	+text \<open>The set of points determined by a circline is always
	+either an Euclidean circle or an Euclidean line. \<close>
	+
	+text \<open>Euclidean circle is determined by its center and radius.\<close>
	+type_synonym euclidean_circle = "complex \<times> real"
	+
	+definition euclidean_circle_cmat :: "complex_mat \<Rightarrow> euclidean_circle" where
	+ [simp]: "euclidean_circle_cmat H = (let (A, B, C, D) = H in (-B/A, sqrt(Re ((BC - AD)/(A*A)))))"
	+
	+lift_definition euclidean_circle_clmat :: "circline_mat \<Rightarrow> euclidean_circle" is euclidean_circle_cmat
	+ done
	+
	+lift_definition euclidean_circle :: "circline \<Rightarrow> euclidean_circle" is euclidean_circle_clmat
	+proof transfer
	+ fix H1 H2
	+ assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ obtain A1 B1 C1 D1 where HH1: "H1 = (A1, B1, C1, D1)"
	+ by (cases "H1") auto
	+ obtain A2 B2 C2 D2 where HH2: "H2 = (A2, B2, C2, D2)"
	+ by (cases "H2") auto
	+ assume "circline_eq_cmat H1 H2"
	+ then obtain k where "k \<noteq> 0" and : "A2 = cor k A1" "B2 = cor k * B1" "C2 = cor k * C1" "D2 = cor k * D1"
	+ using HH1 HH2
	+ by auto
	+ have "(cor k * B1 * (cor k * C1) - cor k * A1 * (cor k * D1)) = (cor k)\<^sup>2 * (B1C1 - A1D1)"
	+ "(cor k * A1 * (cor k * A1)) = (cor k)\<^sup>2 * (A1*A1)"
	+ by (auto simp add: field_simps power2_eq_square)
	+ hence "(cor k * B1 * (cor k * C1) - cor k * A1 * (cor k * D1)) /
	+ (cor k * A1 * (cor k * A1)) = (B1C1 - A1D1) / (A1*A1)"
	+ using \<open>k \<noteq> 0\<close>
	+ by (simp add: power2_eq_square)
	+ thus "euclidean_circle_cmat H1 = euclidean_circle_cmat H2"
	+ using HH1 HH2 * hh
	+ by auto
	+qed
	+
	+lemma classic_circle:
	+ assumes "is_circle H" and "(a, r) = euclidean_circle H" and "circline_type H \<le> 0"
	+ shows "circline_set H = of_complex ` circle a r"
	+proof-
	+ obtain A B C D where *: "H = mk_circline A B C D" "hermitean (A, B, C, D)" "(A, B, C, D) \<noteq> mat_zero"
	+ using ex_mk_circline[of H]
	+ by auto
	+ have "is_real A" "is_real D" "C = cnj B"
	+ using * hermitean_elems
	+ by auto
	+ have "Re (AD - BC) \<le> 0"
	+ using \<open>circline_type H \<le> 0\<close> *
	+ by simp
	+
	+ hence *: "Re A Re D \<le> (cmod B)\<^sup>2"
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>C = cnj B\<close>
	+ by (simp add: cmod_square)
	+
	+ have "A \<noteq> 0"
	+ using \<open>is_circle H\<close> * \<open>is_real A\<close>
	+ by simp (transfer, transfer, simp)
	+
	+ hence "Re A \<noteq> 0"
	+ using \<open>is_real A\<close>
	+ by (metis complex_surj zero_complex.code)
	+
	+ have ***: "\<infinity>\<^sub>h \<notin> circline_set H"
	+ using * inf_in_circline_set[of H] \<open>is_circle H\<close>
	+ by simp
	+
	+ let ?a = "-B/A"
	+ let ?r2 = "((cmod B)\<^sup>2 - Re A * Re D) / (Re A)\<^sup>2"
	+ let ?r = "sqrt ?r2"
	+
	+ have "?a = a \<and> ?r = r"
	+ using \<open>(a, r) = euclidean_circle H\<close>
	+ using * \<open>is_real A\<close> \<open>is_real D\<close> \<open>C = cnj B\<close> \<open>A \<noteq> 0\<close>
	+ apply simp
	+ apply transfer
	+ apply transfer
	+ apply simp
	+ apply (subst Re_divide_real)
	+ apply (simp_all add: cmod_square, simp add: power2_eq_square)
	+ done
	+
	+ show ?thesis
	+ using * * \<open>Re A \<noteq> 0\<close> \<open>is_real A\<close> \<open>C = cnj B\<close> \<open>?a = a \<and> ?r = r\<close>
	+ using classic_circline[of H A B C D] assms circline_circle[of "Re A" "Re D" B "circline (Re A) B (Re D)" ?a ?r2 ?r]
	+ by (simp add: circle_def)
	+qed
	+
	+text \<open>Euclidean line is represented by two points.\<close>
	+type_synonym euclidean_line = "complex \<times> complex"
	+
	+definition euclidean_line_cmat :: "complex_mat \<Rightarrow> euclidean_line" where
	+ [simp]: "euclidean_line_cmat H =
	+ (let (A, B, C, D) = H;
	+ z1 = -(DB)/(2B*C);
	+ z2 = z1 + \<i> * sgn (if arg B > 0 then -B else B)
	+ in (z1, z2))"
	+
	+lift_definition euclidean_line_clmat :: "circline_mat \<Rightarrow> euclidean_line" is euclidean_line_cmat
	+ done
	+
	+lift_definition euclidean_line :: "circline \<Rightarrow> complex \<times> complex" is euclidean_line_clmat
	+proof transfer
	+ fix H1 H2
	+ assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ obtain A1 B1 C1 D1 where HH1: "H1 = (A1, B1, C1, D1)"
	+ by (cases "H1") auto
	+ obtain A2 B2 C2 D2 where HH2: "H2 = (A2, B2, C2, D2)"
	+ by (cases "H2") auto
	+ assume "circline_eq_cmat H1 H2"
	+ then obtain k where "k \<noteq> 0" and : "A2 = cor k A1" "B2 = cor k * B1" "C2 = cor k * C1" "D2 = cor k * D1"
	+ using HH1 HH2
	+ by auto
	+ have 1: "B1 \<noteq> 0 \<and> 0 < arg B1 \<longrightarrow> \<not> 0 < arg (- B1)"
	+ using canon_ang_plus_pi1[of "arg B1"] arg_bounded[of B1]
	+ by (auto simp add: arg_uminus)
	+ have 2: "B1 \<noteq> 0 \<and> \<not> 0 < arg B1 \<longrightarrow> 0 < arg (- B1)"
	+ using canon_ang_plus_pi2[of "arg B1"] arg_bounded[of B1]
	+ by (auto simp add: arg_uminus)
	+
	+ show "euclidean_line_cmat H1 = euclidean_line_cmat H2"
	+ using HH1 HH2 * \<open>k \<noteq> 0\<close>
	+ by (cases "k > 0") (auto simp add: Let_def, simp_all add: sgn_eq 1 2)
	+qed
	+
	+lemma classic_line:
	+ assumes "is_line H" and "circline_type H < 0" and "(z1, z2) = euclidean_line H"
	+ shows "circline_set H - {\<infinity>\<^sub>h} = of_complex ` line z1 z2"
	+proof-
	+ obtain A B C D where *: "H = mk_circline A B C D" "hermitean (A, B, C, D)" "(A, B, C, D) \<noteq> mat_zero"
	+ using ex_mk_circline[of H]
	+ by auto
	+ have "is_real A" "is_real D" "C = cnj B"
	+ using * hermitean_elems
	+ by auto
	+ have "Re A = 0"
	+ using \<open>is_line H\<close> * \<open>is_real A\<close> \<open>is_real D\<close> \<open>C = cnj B\<close>
	+ by simp (transfer, transfer, simp)
	+ have "B \<noteq> 0"
	+ using \<open>Re A = 0\<close> \<open>is_real A\<close> \<open>is_real D\<close> \<open>C = cnj B\<close> * \<open>circline_type H < 0\<close>
	+ using circline_type_mk_circline[of A B C D]
	+ by auto
	+
	+ let ?z1 = "- cor (Re D) * B / (2 * B * cnj B)"
	+ let ?z2 = "?z1 + \<i> * sgn (if 0 < arg B then - B else B)"
	+ have "z1 = ?z1 \<and> z2 = ?z2"
	+ using \<open>(z1, z2) = euclidean_line H\<close> * \<open>is_real A\<close> \<open>is_real D\<close> \<open>C = cnj B\<close>
	+ by simp (transfer, transfer, simp add: Let_def)
	+ thus ?thesis
	+ using *
	+ using classic_circline[of H A B C D] circline_line[of "Re A" B "circline (Re A) B (Re D)" "Re D" ?z1 ?z2] \<open>Re A = 0\<close> \<open>B \<noteq> 0\<close>
	+ by simp
	+qed
	+
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Some special circlines\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Unit circle\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+definition unit_circle_cmat :: complex_mat where
	+ [simp]: "unit_circle_cmat = (1, 0, 0, -1)"
	+lift_definition unit_circle_clmat :: circline_mat is unit_circle_cmat
	+ by (simp add: hermitean_def mat_adj_def mat_cnj_def)
	+lift_definition unit_circle :: circline is unit_circle_clmat
	+ done
	+
	+lemma on_circline_cmat_cvec_unit:
	+ shows "on_circline_cmat_cvec unit_circle_cmat (z1, z2) \<longleftrightarrow>
	+ z1 * cnj z1 = z2 * cnj z2"
	+ by (simp add: vec_cnj_def field_simps)
	+
	+lemma
	+ one_on_unit_circle [simp]: "on_circline unit_circle 1\<^sub>h" and
	+ ii_on_unit_circle [simp]: "on_circline unit_circle ii\<^sub>h" and
	+ not_zero_on_unit_circle [simp]: "\<not> on_circline unit_circle 0\<^sub>h"
	+ by (transfer, transfer, simp add: vec_cnj_def)+
	+
	+lemma
	+ one_in_unit_circle_set [simp]: "1\<^sub>h \<in> circline_set unit_circle" and
	+ ii_in_unit_circle_set [simp]: "ii\<^sub>h \<in> circline_set unit_circle" and
	+ zero_in_unit_circle_set [simp]: "0\<^sub>h \<notin> circline_set unit_circle"
	+ unfolding circline_set_def
	+ by simp_all
	+
	+lemma is_circle_unit_circle [simp]:
	+ shows "is_circle unit_circle"
	+ by (transfer, transfer, simp)
	+
	+lemma not_inf_on_unit_circle' [simp]:
	+ shows "\<not> on_circline unit_circle \<infinity>\<^sub>h"
	+ using is_circle_unit_circle inf_on_circline
	+ by blast
	+
	+lemma not_inf_on_unit_circle'' [simp]:
	+ shows "\<infinity>\<^sub>h \<notin> circline_set unit_circle"
	+ by (simp add: inf_in_circline_set)
	+
	+lemma euclidean_circle_unit_circle [simp]:
	+ shows "euclidean_circle unit_circle = (0, 1)"
	+ by (transfer, transfer, simp)
	+
	+lemma circline_type_unit_circle [simp]:
	+ shows "circline_type unit_circle = -1"
	+ by (transfer, transfer, simp)
	+
	+lemma on_circline_unit_circle [simp]:
	+ shows "on_circline unit_circle (of_complex z) \<longleftrightarrow> cmod z = 1"
	+ by (transfer, transfer, simp add: vec_cnj_def mult.commute)
	+
	+lemma circline_set_unit_circle [simp]:
	+ shows "circline_set unit_circle = of_complex ` {z. cmod z = 1}"
	+proof-
	+ show ?thesis
	+ proof safe
	+ fix x
	+ assume "x \<in> circline_set unit_circle"
	+ then obtain x' where "x = of_complex x'"
	+ using inf_or_of_complex[of x]
	+ by auto
	+ thus "x \<in> of_complex ` {z. cmod z = 1}"
	+ using \<open>x \<in> circline_set unit_circle\<close>
	+ unfolding circline_set_def
	+ by auto
	+ next
	+ fix x
	+ assume "cmod x = 1"
	+ thus "of_complex x \<in> circline_set unit_circle"
	+ unfolding circline_set_def
	+ by auto
	+ qed
	+qed
	+
	+lemma circline_set_unit_circle_I [simp]:
	+ assumes "cmod z = 1"
	+ shows "of_complex z \<in> circline_set unit_circle"
	+ using assms
	+ unfolding circline_set_unit_circle
	+ by simp
	+
	+lemma inversion_unit_circle [simp]:
	+ assumes "on_circline unit_circle x"
	+ shows "inversion x = x"
	+proof-
	+ obtain x' where "x = of_complex x'" "x' \<noteq> 0"
	+ using inf_or_of_complex[of x]
	+ using assms
	+ by force
	+ moreover
	+ hence "x' * cnj x' = 1"
	+ using assms
	+ using circline_set_unit_circle
	+ unfolding circline_set_def
	+ by auto
	+ hence "1 / cnj x' = x'"
	+ using \<open>x' \<noteq> 0\<close>
	+ by (simp add: field_simps)
	+ ultimately
	+ show ?thesis
	+ using assms
	+ unfolding inversion_def
	+ by simp
	+qed
	+
	+lemma inversion_id_iff_on_unit_circle:
	+ shows "inversion a = a \<longleftrightarrow> on_circline unit_circle a"
	+ using inversion_id_iff[of a] inf_or_of_complex[of a]
	+ by auto
	+
	+lemma on_unit_circle_conjugate [simp]:
	+ shows "on_circline unit_circle (conjugate z) \<longleftrightarrow> on_circline unit_circle z"
	+ by (transfer, transfer, auto simp add: vec_cnj_def field_simps)
	+
	+lemma conjugate_unit_circle_set [simp]:
	+ shows "conjugate ` (circline_set unit_circle) = circline_set unit_circle"
	+ unfolding circline_set_def
	+ by (auto simp add: image_iff, rule_tac x="conjugate x" in exI, simp)
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>x-axis\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+definition x_axis_cmat :: complex_mat where
	+ [simp]: "x_axis_cmat = (0, \<i>, -\<i>, 0)"
	+lift_definition x_axis_clmat :: circline_mat is x_axis_cmat
	+ by (simp add: hermitean_def mat_adj_def mat_cnj_def)
	+lift_definition x_axis :: circline is x_axis_clmat
	+ done
	+
	+lemma special_points_on_x_axis' [simp]:
	+ shows "on_circline x_axis 0\<^sub>h" and "on_circline x_axis 1\<^sub>h" and "on_circline x_axis \<infinity>\<^sub>h"
	+ by (transfer, transfer, simp add: vec_cnj_def)+
	+
	+lemma special_points_on_x_axis'' [simp]:
	+ shows "0\<^sub>h \<in> circline_set x_axis" and "1\<^sub>h \<in> circline_set x_axis" and "\<infinity>\<^sub>h \<in> circline_set x_axis"
	+ unfolding circline_set_def
	+ by auto
	+
	+lemma is_line_x_axis [simp]:
	+ shows "is_line x_axis"
	+ by (transfer, transfer, simp)
	+
	+lemma circline_type_x_axis [simp]:
	+ shows "circline_type x_axis = -1"
	+ by (transfer, transfer, simp)
	+
	+lemma on_circline_x_axis:
	+ shows "on_circline x_axis z \<longleftrightarrow> (\<exists> c. is_real c \<and> z = of_complex c) \<or> z = \<infinity>\<^sub>h"
	+proof safe
	+ fix z c
	+ assume "is_real c"
	+ thus "on_circline x_axis (of_complex c)"
	+ proof (transfer, transfer)
	+ fix c
	+ assume "is_real c"
	+ thus "on_circline_cmat_cvec x_axis_cmat (of_complex_cvec c)"
	+ using eq_cnj_iff_real[of c]
	+ by (simp add: vec_cnj_def)
	+ qed
	+next
	+ fix z
	+ assume "on_circline x_axis z" "z \<noteq> \<infinity>\<^sub>h"
	+ thus "\<exists>c. is_real c \<and> z = of_complex c"
	+ proof (transfer, transfer, safe)
	+ fix a b
	+ assume "(a, b) \<noteq> vec_zero"
	+ "on_circline_cmat_cvec x_axis_cmat (a, b)"
	+ "\<not> (a, b) \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ hence "b \<noteq> 0" "cnj a * b = cnj b * a" using inf_cvec_z2_zero_iff
	+ by (auto simp add: vec_cnj_def)
	+ thus "\<exists>c. is_real c \<and> (a, b) \<approx>\<^sub>v of_complex_cvec c"
	+ apply (rule_tac x="a/b" in exI)
	+ apply (auto simp add: is_real_div field_simps)
	+ apply (rule_tac x="1/b" in exI, simp)
	+ done
	+ qed
	+next
	+ show "on_circline x_axis \<infinity>\<^sub>h"
	+ by auto
	+qed
	+
	+lemma on_circline_x_axis_I [simp]:
	+ assumes "is_real z"
	+ shows "on_circline x_axis (of_complex z)"
	+ using assms
	+ unfolding on_circline_x_axis
	+ by auto
	+
	+lemma circline_set_x_axis:
	+ shows "circline_set x_axis = of_complex ` {x. is_real x} \<union> {\<infinity>\<^sub>h}"
	+ using on_circline_x_axis
	+ unfolding circline_set_def
	+ by auto
	+
	+lemma circline_set_x_axis_I:
	+ assumes "is_real z"
	+ shows "of_complex z \<in> circline_set x_axis"
	+ using assms
	+ unfolding circline_set_x_axis
	+ by auto
	+
	+lemma circline_equation_x_axis:
	+ shows "of_complex z \<in> circline_set x_axis \<longleftrightarrow> z = cnj z"
	+ unfolding circline_set_x_axis
	+proof auto
	+ fix x
	+ assume "of_complex z = of_complex x" "is_real x"
	+ hence "z = x"
	+ using of_complex_inj[of z x]
	+ by simp
	+ thus "z = cnj z"
	+ using eq_cnj_iff_real[of z] \<open>is_real x\<close>
	+ by auto
	+next
	+ assume "z = cnj z"
	+ thus "of_complex z \<in> of_complex ` {x. is_real x} "
	+ using eq_cnj_iff_real[of z]
	+ by auto
	+qed
	+
	+text \<open>Positive and negative part of x-axis\<close>
	+
	+definition positive_x_axis where
	+ "positive_x_axis = {z. z \<in> circline_set x_axis \<and> z \<noteq> \<infinity>\<^sub>h \<and> Re (to_complex z) > 0}"
	+
	+definition negative_x_axis where
	+ "negative_x_axis = {z. z \<in> circline_set x_axis \<and> z \<noteq> \<infinity>\<^sub>h \<and> Re (to_complex z) < 0}"
	+
	+lemma circline_set_positive_x_axis_I [simp]:
	+ assumes "is_real z" and "Re z > 0"
	+ shows "of_complex z \<in> positive_x_axis"
	+ using assms
	+ unfolding positive_x_axis_def
	+ by simp
	+
	+lemma circline_set_negative_x_axis_I [simp]:
	+ assumes "is_real z" and "Re z < 0"
	+ shows "of_complex z \<in> negative_x_axis"
	+ using assms
	+ unfolding negative_x_axis_def
	+ by simp
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>y-axis\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+definition y_axis_cmat :: complex_mat where
	+ [simp]: "y_axis_cmat = (0, 1, 1, 0)"
	+lift_definition y_axis_clmat :: circline_mat is y_axis_cmat
	+ by (simp add: hermitean_def mat_adj_def mat_cnj_def)
	+lift_definition y_axis :: circline is y_axis_clmat
	+ done
	+
	+lemma special_points_on_y_axis' [simp]:
	+ shows "on_circline y_axis 0\<^sub>h" and "on_circline y_axis ii\<^sub>h" and "on_circline y_axis \<infinity>\<^sub>h"
	+ by (transfer, transfer, simp add: vec_cnj_def)+
	+
	+lemma special_points_on_y_axis'' [simp]:
	+ shows "0\<^sub>h \<in> circline_set y_axis" and "ii\<^sub>h \<in> circline_set y_axis" and "\<infinity>\<^sub>h \<in> circline_set y_axis"
	+ unfolding circline_set_def
	+ by auto
	+
	+lemma on_circline_y_axis:
	+ shows "on_circline y_axis z \<longleftrightarrow> (\<exists> c. is_imag c \<and> z = of_complex c) \<or> z = \<infinity>\<^sub>h"
	+proof safe
	+ fix z c
	+ assume "is_imag c"
	+ thus "on_circline y_axis (of_complex c)"
	+ proof (transfer, transfer)
	+ fix c
	+ assume "is_imag c"
	+ thus "on_circline_cmat_cvec y_axis_cmat (of_complex_cvec c)"
	+ using eq_minus_cnj_iff_imag[of c]
	+ by (simp add: vec_cnj_def)
	+ qed
	+next
	+ fix z
	+ assume "on_circline y_axis z" "z \<noteq> \<infinity>\<^sub>h"
	+ thus "\<exists>c. is_imag c \<and> z = of_complex c"
	+ proof (transfer, transfer, safe)
	+ fix a b
	+ assume "(a, b) \<noteq> vec_zero"
	+ "on_circline_cmat_cvec y_axis_cmat (a, b)"
	+ "\<not> (a, b) \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ hence "b \<noteq> 0" "cnj a * b + cnj b * a = 0"
	+ using inf_cvec_z2_zero_iff
	+ by (blast, smt add.left_neutral add_cancel_right_right mult.commute mult.left_neutral mult_not_zero on_circline_cmat_cvec_circline_equation y_axis_cmat_def)
	+ thus "\<exists>c. is_imag c \<and> (a, b) \<approx>\<^sub>v of_complex_cvec c"
	+ using eq_minus_cnj_iff_imag[of "a / b"]
	+ apply (rule_tac x="a/b" in exI)
	+ apply (auto simp add: field_simps)
	+ apply (rule_tac x="1/b" in exI, simp)
	+ using add_eq_0_iff apply blast
	+ apply (rule_tac x="1/b" in exI, simp)
	+ done
	+ qed
	+next
	+ show "on_circline y_axis \<infinity>\<^sub>h"
	+ by simp
	+qed
	+
	+lemma on_circline_y_axis_I [simp]:
	+ assumes "is_imag z"
	+ shows "on_circline y_axis (of_complex z)"
	+ using assms
	+ unfolding on_circline_y_axis
	+ by auto
	+
	+lemma circline_set_y_axis:
	+ shows "circline_set y_axis = of_complex ` {x. is_imag x} \<union> {\<infinity>\<^sub>h}"
	+ using on_circline_y_axis
	+ unfolding circline_set_def
	+ by auto
	+
	+lemma circline_set_y_axis_I:
	+ assumes "is_imag z"
	+ shows "of_complex z \<in> circline_set y_axis"
	+ using assms
	+ unfolding circline_set_y_axis
	+ by auto
	+
	+text \<open>Positive and negative part of y-axis\<close>
	+
	+definition positive_y_axis where
	+ "positive_y_axis = {z. z \<in> circline_set y_axis \<and> z \<noteq> \<infinity>\<^sub>h \<and> Im (to_complex z) > 0}"
	+
	+definition negative_y_axis where
	+ "negative_y_axis = {z. z \<in> circline_set y_axis \<and> z \<noteq> \<infinity>\<^sub>h \<and> Im (to_complex z) < 0}"
	+
	+lemma circline_set_positive_y_axis_I [simp]:
	+ assumes "is_imag z" and "Im z > 0"
	+ shows "of_complex z \<in> positive_y_axis"
	+ using assms
	+ unfolding positive_y_axis_def
	+ by simp
	+
	+lemma circline_set_negative_y_axis_I [simp]:
	+ assumes "is_imag z" and "Im z < 0"
	+ shows "of_complex z \<in> negative_y_axis"
	+ using assms
	+ unfolding negative_y_axis_def
	+ by simp
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Point zero as a circline\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+definition circline_point_0_cmat :: complex_mat where
	+ [simp]: "circline_point_0_cmat = (1, 0, 0, 0)"
	+lift_definition circline_point_0_clmat :: circline_mat is circline_point_0_cmat
	+ by (simp add: hermitean_def mat_adj_def mat_cnj_def)
	+lift_definition circline_point_0 :: circline is circline_point_0_clmat
	+ done
	+
	+lemma circline_type_circline_point_0 [simp]:
	+ shows "circline_type circline_point_0 = 0"
	+ by (transfer, transfer, simp)
	+
	+lemma zero_in_circline_point_0 [simp]:
	+ shows "0\<^sub>h \<in> circline_set circline_point_0"
	+ unfolding circline_set_def
	+ by auto (transfer, transfer, simp add: vec_cnj_def)+
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Imaginary unit circle\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+definition imag_unit_circle_cmat :: complex_mat where
	+ [simp]: "imag_unit_circle_cmat = (1, 0, 0, 1)"
	+lift_definition imag_unit_circle_clmat :: circline_mat is imag_unit_circle_cmat
	+ by (simp add: hermitean_def mat_adj_def mat_cnj_def)
	+lift_definition imag_unit_circle :: circline is imag_unit_circle_clmat
	+ done
	+
	+lemma circline_type_imag_unit_circle [simp]:
	+ shows "circline_type imag_unit_circle = 1"
	+ by (transfer, transfer, simp)
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Intersection of circlines\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+definition circline_intersection :: "circline \<Rightarrow> circline \<Rightarrow> complex_homo set" where
	+ "circline_intersection H1 H2 = {z. on_circline H1 z \<and> on_circline H2 z}"
	+
	+lemma circline_equation_cancel_z2:
	+ assumes "circline_equation A B C D z1 z2 " and "z2 \<noteq> 0"
	+ shows "circline_equation A B C D (z1/z2) 1"
	+ using assms
	+ by (simp add: field_simps)
	+
	+lemma circline_equation_quadratic_equation:
	+ assumes "circline_equation A B (cnj B) D z 1" and
	+ "Re z = x" and "Im z = y" and "Re B = bx" and "Im B = by"
	+ shows "Ax\<^sup>2 + Ay\<^sup>2 + 2bxx + 2byy + D = 0"
	+ using assms
	+proof-
	+ have "z = x + \<i>y" "B = bx + \<i>by"
	+ using assms complex_eq
	+ by auto
	+ thus ?thesis
	+ using assms
	+ by (simp add: field_simps power2_eq_square)
	+qed
	+
	+lemma circline_intersection_symetry:
	+ shows "circline_intersection H1 H2 = circline_intersection H2 H1"
	+ unfolding circline_intersection_def
	+ by auto
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Möbius action on circlines\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+definition moebius_circline_cmat_cmat :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex_mat" where
	+ [simp]: "moebius_circline_cmat_cmat M H = congruence (mat_inv M) H"
	+
	+lift_definition moebius_circline_mmat_clmat :: "moebius_mat \<Rightarrow> circline_mat \<Rightarrow> circline_mat" is moebius_circline_cmat_cmat
	+ using mat_det_inv congruence_nonzero hermitean_congruence
	+ by simp
	+
	+lift_definition moebius_circline :: "moebius \<Rightarrow> circline \<Rightarrow> circline" is moebius_circline_mmat_clmat
	+proof transfer
	+ fix M M' H H'
	+ assume "moebius_cmat_eq M M'" "circline_eq_cmat H H'"
	+ thus "circline_eq_cmat (moebius_circline_cmat_cmat M H) (moebius_circline_cmat_cmat M' H')"
	+ by (auto simp add: mat_inv_mult_sm) (rule_tac x="ka / Re (k * cnj k)" in exI, auto simp add: complex_mult_cnj_cmod power2_eq_square)
	+qed
	+
	+lemma moebius_preserve_circline_type [simp]:
	+ shows "circline_type (moebius_circline M H) = circline_type H"
	+proof (transfer, transfer)
	+ fix M H :: complex_mat
	+ assume "mat_det M \<noteq> 0" "hermitean H \<and> H \<noteq> mat_zero"
	+ thus "circline_type_cmat (moebius_circline_cmat_cmat M H) = circline_type_cmat H"
	+ using Re_det_sgn_congruence[of "mat_inv M" "H"] mat_det_inv[of "M"]
	+ by (simp del: congruence_def)
	+qed
	+
	+text \<open>The central lemma in this section connects the action of Möbius transformations on points and
	+on circlines.\<close>
	+
	+lemma moebius_circline:
	+ shows "{z. on_circline (moebius_circline M H) z} =
	+ moebius_pt M ` {z. on_circline H z}"
	+proof safe
	+ fix z
	+ assume "on_circline H z"
	+ thus "on_circline (moebius_circline M H) (moebius_pt M z)"
	+ proof (transfer, transfer)
	+ fix z :: complex_vec and M H :: complex_mat
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero" "z \<noteq> vec_zero" "mat_det M \<noteq> 0"
	+ let ?z = "M *\<^sub>m\<^sub>v z"
	+ let ?H = "mat_adj (mat_inv M) \<^sub>m\<^sub>m H \<^sub>m\<^sub>m (mat_inv M)"
	+ assume *: "on_circline_cmat_cvec H z"
	+ hence "quad_form z H = 0"
	+ by simp
	+ hence "quad_form ?z ?H = 0"
	+ using quad_form_congruence[of M z H] hh
	+ by simp
	+ thus "on_circline_cmat_cvec (moebius_circline_cmat_cmat M H) (moebius_pt_cmat_cvec M z)"
	+ by simp
	+ qed
	+next
	+ fix z
	+ assume "on_circline (moebius_circline M H) z"
	+ hence "\<exists> z'. z = moebius_pt M z' \<and> on_circline H z'"
	+ proof (transfer, transfer)
	+ fix z :: complex_vec and M H :: complex_mat
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero" "z \<noteq> vec_zero" "mat_det M \<noteq> 0"
	+ let ?iM = "mat_inv M"
	+ let ?z' = "?iM *\<^sub>m\<^sub>v z"
	+ assume *: "on_circline_cmat_cvec (moebius_circline_cmat_cmat M H) z"
	+ have "?z' \<noteq> vec_zero"
	+ using hh
	+ using mat_det_inv mult_mv_nonzero
	+ by auto
	+ moreover
	+ have "z \<approx>\<^sub>v moebius_pt_cmat_cvec M ?z'"
	+ using hh eye_mv_l mat_inv_r
	+ by simp
	+ moreover
	+ have "M \<^sub>m\<^sub>v (?iM \<^sub>m\<^sub>v z) = z"
	+ using hh eye_mv_l mat_inv_r
	+ by auto
	+ hence "on_circline_cmat_cvec H ?z'"
	+ using hh *
	+ using quad_form_congruence[of M "?iM *\<^sub>m\<^sub>v z" H, symmetric]
	+ unfolding moebius_circline_cmat_cmat_def
	+ unfolding on_circline_cmat_cvec_def
	+ by simp
	+ ultimately
	+ show "\<exists>z'\<in>{v. v \<noteq> vec_zero}. z \<approx>\<^sub>v moebius_pt_cmat_cvec M z' \<and> on_circline_cmat_cvec H z'"
	+ by blast
	+ qed
	+ thus "z \<in> moebius_pt M ` {z. on_circline H z}"
	+ by auto
	+qed
	+
	+lemma on_circline_moebius_circline_I [simp]:
	+ assumes "on_circline H z"
	+ shows "on_circline (moebius_circline M H) (moebius_pt M z)"
	+ using assms moebius_circline
	+ by fastforce
	+
	+lemma circline_set_moebius_circline [simp]:
	+ shows "circline_set (moebius_circline M H) = moebius_pt M ` circline_set H"
	+ using moebius_circline[of M H]
	+ unfolding circline_set_def
	+ by auto
	+
	+lemma circline_set_moebius_circline_I [simp]:
	+ assumes "z \<in> circline_set H"
	+ shows "moebius_pt M z \<in> circline_set (moebius_circline M H)"
	+ using assms
	+ by simp
	+
	+lemma circline_set_moebius_circline_E:
	+ assumes "moebius_pt M z \<in> circline_set (moebius_circline M H)"
	+ shows "z \<in> circline_set H"
	+ using assms
	+ using moebius_pt_eq_I[of M z]
	+ by auto
	+
	+lemma circline_set_moebius_circline_iff [simp]:
	+ shows "moebius_pt M z \<in> circline_set (moebius_circline M H) \<longleftrightarrow>
	+ z \<in> circline_set H"
	+ using moebius_pt_eq_I[of M z]
	+ by auto
	+
	+lemma inj_moebius_circline:
	+ shows "inj (moebius_circline M)"
	+unfolding inj_on_def
	+proof (safe)
	+ fix H H'
	+ assume "moebius_circline M H = moebius_circline M H'"
	+ thus "H = H'"
	+ proof (transfer, transfer)
	+ fix M H H' :: complex_mat
	+ assume hh: "mat_det M \<noteq> 0"
	+ let ?iM = "mat_inv M"
	+ assume "circline_eq_cmat (moebius_circline_cmat_cmat M H) (moebius_circline_cmat_cmat M H')"
	+ then obtain k where "congruence ?iM H' = congruence ?iM (cor k *\<^sub>s\<^sub>m H)" "k \<noteq> 0"
	+ by auto
	+ thus "circline_eq_cmat H H'"
	+ using hh inj_congruence[of ?iM H' "cor k *\<^sub>s\<^sub>m H"] mat_det_inv[of M]
	+ by auto
	+ qed
	+qed
	+
	+lemma moebius_circline_eq_I:
	+ assumes "moebius_circline M H1 = moebius_circline M H2"
	+ shows "H1 = H2"
	+ using assms inj_moebius_circline[of M]
	+ unfolding inj_on_def
	+ by blast
	+
	+lemma moebius_circline_neq_I [simp]:
	+ assumes "H1 \<noteq> H2"
	+ shows "moebius_circline M H1 \<noteq> moebius_circline M H2"
	+ using assms inj_moebius_circline[of M]
	+ unfolding inj_on_def
	+ by blast
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Group properties of Möbius action on ciclines\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Möbius actions on circlines have similar properties as Möbius actions on points.\<close>
	+
	+lemma moebius_circline_id [simp]:
	+ shows "moebius_circline id_moebius H = H"
	+ by (transfer, transfer) (simp add: mat_adj_def mat_cnj_def, rule_tac x=1 in exI, auto)
	+
	+lemma moebius_circline_comp [simp]:
	+ shows "moebius_circline (moebius_comp M1 M2) H = moebius_circline M1 (moebius_circline M2 H)"
	+ by (transfer, transfer) (simp add: mat_inv_mult_mm, rule_tac x=1 in exI, simp add: mult_mm_assoc)
	+
	+lemma moebius_circline_comp_inv_left [simp]:
	+ shows "moebius_circline (moebius_inv M) (moebius_circline M H) = H"
	+ by (subst moebius_circline_comp[symmetric], simp)
	+
	+lemma moebius_circline_comp_inv_right [simp]:
	+ shows "moebius_circline M (moebius_circline (moebius_inv M) H) = H"
	+ by (subst moebius_circline_comp[symmetric], simp)
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Action of Euclidean similarities on circlines\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma moebius_similarity_lines_to_lines [simp]:
	+ assumes "a \<noteq> 0"
	+ shows "\<infinity>\<^sub>h \<in> circline_set (moebius_circline (moebius_similarity a b) H) \<longleftrightarrow>
	+ \<infinity>\<^sub>h \<in> circline_set H"
	+ using assms
	+ by (metis circline_set_moebius_circline_iff moebius_similarity_inf)
	+
	+lemma moebius_similarity_lines_to_lines':
	+ assumes "a \<noteq> 0"
	+ shows "on_circline (moebius_circline (moebius_similarity a b) H) \<infinity>\<^sub>h \<longleftrightarrow>
	+ \<infinity>\<^sub>h \<in> circline_set H"
	+ using moebius_similarity_lines_to_lines assms
	+ unfolding circline_set_def
	+ by simp
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Conjugation, recpiprocation and inversion of circlines\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Conjugation of circlines\<close>
	+definition conjugate_circline_cmat :: "complex_mat \<Rightarrow> complex_mat" where
	+ [simp]: "conjugate_circline_cmat = mat_cnj"
	+lift_definition conjugate_circline_clmat :: "circline_mat \<Rightarrow> circline_mat" is conjugate_circline_cmat
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+lift_definition conjugate_circline :: "circline \<Rightarrow> circline" is conjugate_circline_clmat
	+ by transfer (metis circline_eq_cmat_def conjugate_circline_cmat_def hermitean_transpose mat_t_mult_sm)
	+
	+lemma conjugate_circline_set':
	+ shows "conjugate ` circline_set H \<subseteq> circline_set (conjugate_circline H)"
	+proof (safe)
	+ fix z
	+ assume "z \<in> circline_set H"
	+ thus "conjugate z \<in> circline_set (conjugate_circline H)"
	+ unfolding circline_set_def
	+ apply simp
	+ apply (transfer, transfer)
	+ unfolding on_circline_cmat_cvec_def conjugate_cvec_def conjugate_circline_cmat_def
	+ apply (subst quad_form_vec_cnj_mat_cnj, simp_all)
	+ done
	+qed
	+
	+lemma conjugate_conjugate_circline [simp]:
	+ shows "conjugate_circline (conjugate_circline H) = H"
	+ by (transfer, transfer, force)
	+
	+lemma circline_set_conjugate_circline [simp]:
	+ shows "circline_set (conjugate_circline H) = conjugate ` circline_set H" (is "?lhs = ?rhs")
	+proof (safe)
	+ fix z
	+ assume "z \<in> ?lhs"
	+ show "z \<in> ?rhs"
	+ proof
	+ show "z = conjugate (conjugate z)"
	+ by simp
	+ next
	+ show "conjugate z \<in> circline_set H"
	+ using \<open>z \<in> circline_set (conjugate_circline H)\<close>
	+ using conjugate_circline_set'[of "conjugate_circline H"]
	+ by auto
	+ qed
	+next
	+ fix z
	+ assume "z \<in> circline_set H"
	+ thus "conjugate z \<in> circline_set (conjugate_circline H)"
	+ using conjugate_circline_set'[of H]
	+ by auto
	+qed
	+
	+lemma on_circline_conjugate_circline [simp]:
	+ shows "on_circline (conjugate_circline H) z \<longleftrightarrow> on_circline H (conjugate z)"
	+ using circline_set_conjugate_circline[of H]
	+ unfolding circline_set_def
	+ by force
	+
	+text \<open>Inversion of circlines\<close>
	+
	+definition circline_inversion_cmat :: "complex_mat \<Rightarrow> complex_mat" where
	+ [simp]: "circline_inversion_cmat H = (let (A, B, C, D) = H in (D, B, C, A))"
	+lift_definition circline_inversion_clmat :: "circline_mat \<Rightarrow> circline_mat" is circline_inversion_cmat
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+lift_definition circline_inversion :: "circline \<Rightarrow> circline" is circline_inversion_clmat
	+ by transfer auto
	+
	+lemma on_circline_circline_inversion [simp]:
	+ shows "on_circline (circline_inversion H) z \<longleftrightarrow> on_circline H (reciprocal (conjugate z))"
	+ by (transfer, transfer, auto simp add: vec_cnj_def field_simps)
	+
	+lemma circline_set_circline_inversion [simp]:
	+ shows "circline_set (circline_inversion H) = inversion ` circline_set H"
	+ unfolding circline_set_def inversion_def
	+ by (force simp add: comp_def image_iff)
	+
	+text \<open>Reciprocal of circlines\<close>
	+
	+definition circline_reciprocal :: "circline \<Rightarrow> circline" where
	+ "circline_reciprocal = conjugate_circline \<circ> circline_inversion"
	+
	+lemma circline_set_circline_reciprocal:
	+ shows "circline_set (circline_reciprocal H) = reciprocal ` circline_set H"
	+ unfolding circline_reciprocal_def comp_def
	+ by (auto simp add: inversion_def image_iff)
	+
	+text \<open>Rotation of circlines\<close>
	+
	+lemma rotation_pi_2_y_axis [simp]:
	+ shows "moebius_circline (moebius_rotation (pi/2)) y_axis = x_axis"
	+ unfolding moebius_rotation_def moebius_similarity_def
	+ by (transfer, transfer, simp add: mat_adj_def mat_cnj_def)
	+
	+lemma rotation_minus_pi_2_y_axis [simp]:
	+ shows "moebius_circline (moebius_rotation (-pi/2)) y_axis = x_axis"
	+ unfolding moebius_rotation_def moebius_similarity_def
	+ by (transfer, transfer, simp add: mat_adj_def mat_cnj_def, rule_tac x="-1" in exI, simp)
	+
	+lemma rotation_minus_pi_2_x_axis [simp]:
	+ shows "moebius_circline (moebius_rotation (-pi/2)) x_axis = y_axis"
	+ unfolding moebius_rotation_def moebius_similarity_def
	+ by (transfer, transfer, simp add: mat_adj_def mat_cnj_def)
	+
	+lemma rotation_pi_2_x_axis [simp]:
	+ shows "moebius_circline (moebius_rotation (pi/2)) x_axis = y_axis"
	+ unfolding moebius_rotation_def moebius_similarity_def
	+ by (transfer, transfer, simp add: mat_adj_def mat_cnj_def, rule_tac x="-1" in exI, simp)
	+
	+lemma rotation_minus_pi_2_positive_y_axis [simp]:
	+ shows "(moebius_pt (moebius_rotation (-pi/2))) ` positive_y_axis = positive_x_axis"
	+proof safe
	+ fix y
	+ assume y: "y \<in> positive_y_axis"
	+ have : "Re (a \<i> / b) < 0 \<longleftrightarrow> Im (a / b) > 0" for a b
	+ by (subst times_divide_eq_left [symmetric], subst mult.commute, subst Re_i_times) auto
	+ from y * show "moebius_pt (moebius_rotation (-pi/2)) y \<in> positive_x_axis"
	+ unfolding positive_y_axis_def positive_x_axis_def circline_set_def
	+ unfolding moebius_rotation_def moebius_similarity_def
	+ apply simp
	+ apply transfer
	+ apply transfer
	+ apply (auto simp add: vec_cnj_def field_simps add_eq_0_iff)
	+ done
	+next
	+ fix x
	+ assume x: "x \<in> positive_x_axis"
	+ let ?y = "moebius_pt (moebius_rotation (pi/2)) x"
	+ have : "Im (a \<i> / b) > 0 \<longleftrightarrow> Re (a / b) > 0" for a b
	+ by (subst times_divide_eq_left [symmetric], subst mult.commute, subst Im_i_times) auto
	+ hence "?y \<in> positive_y_axis"
	+ using \<open>x \<in> positive_x_axis\<close>
	+ unfolding positive_x_axis_def positive_y_axis_def
	+ unfolding moebius_rotation_def moebius_similarity_def
	+ unfolding circline_set_def
	+ apply simp
	+ apply transfer
	+ apply transfer
	+ apply (auto simp add: vec_cnj_def field_simps add_eq_0_iff)
	+ done
	+ thus "x \<in> moebius_pt (moebius_rotation (-pi/2)) ` positive_y_axis"
	+ by (auto simp add: image_iff) (rule_tac x="?y" in bexI, simp_all)
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Circline uniqueness\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Zero type circline uniqueness\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma unique_circline_type_zero_0':
	+ shows "(circline_type circline_point_0 = 0 \<and> 0\<^sub>h \<in> circline_set circline_point_0) \<and>
	+ (\<forall> H. circline_type H = 0 \<and> 0\<^sub>h \<in> circline_set H \<longrightarrow> H = circline_point_0)"
	+unfolding circline_set_def
	+proof (safe)
	+ show "circline_type circline_point_0 = 0"
	+ by (transfer, transfer, simp)
	+next
	+ show "on_circline circline_point_0 0\<^sub>h"
	+ using circline_set_def zero_in_circline_point_0
	+ by auto
	+next
	+ fix H
	+ assume "circline_type H = 0" "on_circline H 0\<^sub>h"
	+ thus "H = circline_point_0"
	+ proof (transfer, transfer)
	+ fix H :: complex_mat
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases "H") auto
	+ hence *: "C = cnj B" "is_real A"
	+ using hh hermitean_elems[of A B C D]
	+ by auto
	+ assume "circline_type_cmat H = 0" "on_circline_cmat_cvec H 0\<^sub>v"
	+ thus "circline_eq_cmat H circline_point_0_cmat"
	+ using HH hh *
	+ by (simp add: Let_def vec_cnj_def sgn_minus sgn_mult sgn_zero_iff)
	+ (rule_tac x="1/Re A" in exI, cases A, cases B, simp add: Complex_eq sgn_zero_iff)
	+ qed
	+qed
	+
	+lemma unique_circline_type_zero_0:
	+ shows "\<exists>! H. circline_type H = 0 \<and> 0\<^sub>h \<in> circline_set H"
	+ using unique_circline_type_zero_0'
	+ by blast
	+
	+lemma unique_circline_type_zero:
	+ shows "\<exists>! H. circline_type H = 0 \<and> z \<in> circline_set H"
	+proof-
	+ obtain M where ++: "moebius_pt M z = 0\<^sub>h"
	+ using ex_moebius_1[of z]
	+ by auto
	+ have +++: "z = moebius_pt (moebius_inv M) 0\<^sub>h"
	+ by (subst ++[symmetric]) simp
	+ then obtain H0 where *: "circline_type H0 = 0 \<and> 0\<^sub>h \<in> circline_set H0" and
	+ **: "\<forall> H'. circline_type H' = 0 \<and> 0\<^sub>h \<in> circline_set H' \<longrightarrow> H' = H0"
	+ using unique_circline_type_zero_0
	+ by auto
	+ let ?H' = "moebius_circline (moebius_inv M) H0"
	+ show ?thesis
	+ unfolding Ex1_def
	+ using * +++
	+ proof (rule_tac x="?H'" in exI, simp, safe)
	+ fix H'
	+ assume "circline_type H' = 0" "moebius_pt (moebius_inv M) 0\<^sub>h \<in> circline_set H'"
	+ hence "0\<^sub>h \<in> circline_set (moebius_circline M H')"
	+ using ++ +++
	+ by force
	+ hence "moebius_circline M H' = H0"
	+ using **[rule_format, of "moebius_circline M H'"]
	+ using \<open>circline_type H' = 0\<close>
	+ by simp
	+ thus "H' = moebius_circline (moebius_inv M) H0"
	+ by auto
	+ qed
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Negative type circline uniqueness\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma unique_circline_01inf':
	+ shows "0\<^sub>h \<in> circline_set x_axis \<and> 1\<^sub>h \<in> circline_set x_axis \<and> \<infinity>\<^sub>h \<in> circline_set x_axis \<and>
	+ (\<forall> H. 0\<^sub>h \<in> circline_set H \<and> 1\<^sub>h \<in> circline_set H \<and> \<infinity>\<^sub>h \<in> circline_set H \<longrightarrow> H = x_axis)"
	+proof safe
	+ fix H
	+ assume "0\<^sub>h \<in> circline_set H" "1\<^sub>h \<in> circline_set H" "\<infinity>\<^sub>h \<in> circline_set H"
	+ thus "H = x_axis"
	+ unfolding circline_set_def
	+ apply simp
	+ proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ have *: "C = cnj B" "A = 0 \<and> D = 0 \<longrightarrow> B \<noteq> 0"
	+ using hermitean_elems[of A B C D] hh HH
	+ by auto
	+ obtain Bx By where "B = Complex Bx By"
	+ by (cases B) auto
	+ assume "on_circline_cmat_cvec H 0\<^sub>v" "on_circline_cmat_cvec H 1\<^sub>v" "on_circline_cmat_cvec H \<infinity>\<^sub>v"
	+ thus "circline_eq_cmat H x_axis_cmat"
	+ using * HH \<open>C = cnj B\<close> \<open>B = Complex Bx By\<close>
	+ by (simp add: Let_def vec_cnj_def Complex_eq) (rule_tac x="1/By" in exI, auto)
	+ qed
	+qed simp_all
	+
	+lemma unique_circline_set:
	+ assumes "A \<noteq> B" and "A \<noteq> C" and "B \<noteq> C"
	+ shows "\<exists>! H. A \<in> circline_set H \<and> B \<in> circline_set H \<and> C \<in> circline_set H"
	+proof-
	+ let ?P = "\<lambda> A B C. A \<noteq> B \<and> A \<noteq> C \<and> B \<noteq> C \<longrightarrow> (\<exists>! H. A \<in> circline_set H \<and> B \<in> circline_set H \<and> C \<in> circline_set H)"
	+ have "?P A B C"
	+ proof (rule wlog_moebius_01inf[of ?P])
	+ fix M a b c
	+ let ?M = "moebius_pt M"
	+ assume "?P a b c"
	+ show "?P (?M a) (?M b) (?M c)"
	+ proof
	+ assume "?M a \<noteq> ?M b \<and> ?M a \<noteq> ?M c \<and> ?M b \<noteq> ?M c"
	+ hence "a \<noteq> b" "b \<noteq> c" "a \<noteq> c"
	+ by auto
	+ hence "\<exists>!H. a \<in> circline_set H \<and> b \<in> circline_set H \<and> c \<in> circline_set H"
	+ using \<open>?P a b c\<close>
	+ by simp
	+ then obtain H where
	+ *: "a \<in> circline_set H \<and> b \<in> circline_set H \<and> c \<in> circline_set H" and
	+ **: "\<forall>H'. a \<in> circline_set H' \<and> b \<in> circline_set H' \<and> c \<in> circline_set H' \<longrightarrow> H' = H"
	+ unfolding Ex1_def
	+ by auto
	+ let ?H' = "moebius_circline M H"
	+ show "\<exists>! H. ?M a \<in> circline_set H \<and> moebius_pt M b \<in> circline_set H \<and> moebius_pt M c \<in> circline_set H"
	+ unfolding Ex1_def
	+ proof (rule_tac x="?H'" in exI, rule)
	+ show "?M a \<in> circline_set ?H' \<and> ?M b \<in> circline_set ?H' \<and> ?M c \<in> circline_set ?H'"
	+ using *
	+ by auto
	+ next
	+ show "\<forall>H'. ?M a \<in> circline_set H' \<and> ?M b \<in> circline_set H' \<and> ?M c \<in> circline_set H' \<longrightarrow> H' = ?H'"
	+ proof (safe)
	+ fix H'
	+ let ?iH' = "moebius_circline (moebius_inv M) H'"
	+ assume "?M a \<in> circline_set H'" "?M b \<in> circline_set H'" "?M c \<in> circline_set H'"
	+ hence "a \<in> circline_set ?iH' \<and> b \<in> circline_set ?iH' \<and> c \<in> circline_set ?iH'"
	+ by simp
	+ hence "H = ?iH'"
	+ using **
	+ by blast
	+ thus "H' = moebius_circline M H"
	+ by simp
	+ qed
	+ qed
	+ qed
	+ next
	+ show "?P 0\<^sub>h 1\<^sub>h \<infinity>\<^sub>h"
	+ using unique_circline_01inf'
	+ unfolding Ex1_def
	+ by (safe, rule_tac x="x_axis" in exI) auto
	+ qed fact+
	+ thus ?thesis
	+ using assms
	+ by simp
	+qed
	+
	+lemma zero_one_inf_x_axis [simp]:
	+ assumes "0\<^sub>h \<in> circline_set H" and "1\<^sub>h \<in> circline_set H" and "\<infinity>\<^sub>h \<in> circline_set H"
	+ shows "H = x_axis"
	+ using assms unique_circline_set[of "0\<^sub>h" "1\<^sub>h" "\<infinity>\<^sub>h"]
	+ by auto
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Circline set cardinality\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Diagonal circlines\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+definition is_diag_circline_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "is_diag_circline_cmat H = (let (A, B, C, D) = H in B = 0 \<and> C = 0)"
	+lift_definition is_diag_circline_clmat :: "circline_mat \<Rightarrow> bool" is is_diag_circline_cmat
	+ done
	+lift_definition circline_diag :: "circline \<Rightarrow> bool" is is_diag_circline_clmat
	+ by transfer auto
	+
	+lemma circline_diagonalize:
	+ shows "\<exists> M H'. moebius_circline M H = H' \<and> circline_diag H'"
	+proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases "H") auto
	+ hence HH_elems: "is_real A" "is_real D" "C = cnj B"
	+ using hermitean_elems[of A B C D] hh
	+ by auto
	+ obtain M k1 k2 where *: "mat_det M \<noteq> 0" "unitary M" "congruence M H = (k1, 0, 0, k2)" "is_real k1" "is_real k2"
	+ using hermitean_diagonizable[of H] hh
	+ by auto
	+ have "k1 \<noteq> 0 \<or> k2 \<noteq> 0"
	+ using \<open>congruence M H = (k1, 0, 0, k2)\<close> hh congruence_nonzero[of H M] \<open>mat_det M \<noteq> 0\<close>
	+ by auto
	+ let ?M' = "mat_inv M"
	+ let ?H' = "(k1, 0, 0, k2)"
	+ have "circline_eq_cmat (moebius_circline_cmat_cmat ?M' H) ?H' \<and> is_diag_circline_cmat ?H'"
	+ using *
	+ by force
	+ moreover
	+ have "?H' \<in> hermitean_nonzero"
	+ using * \<open>k1 \<noteq> 0 \<or> k2 \<noteq> 0\<close> eq_cnj_iff_real[of k1] eq_cnj_iff_real[of k2]
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+ moreover
	+ have "mat_det ?M' \<noteq> 0"
	+ using * mat_det_inv[of M]
	+ by auto
	+ ultimately
	+ show "\<exists>M\<in>{M. mat_det M \<noteq> 0}.
	+ \<exists>H'\<in>hermitean_nonzero.
	+ circline_eq_cmat (moebius_circline_cmat_cmat M H) H' \<and> is_diag_circline_cmat H'"
	+ by blast
	+qed
	+
	+lemma wlog_circline_diag:
	+ assumes "\<And> H. circline_diag H \<Longrightarrow> P H"
	+ "\<And> M H. P H \<Longrightarrow> P (moebius_circline M H)"
	+ shows "P H"
	+proof-
	+ obtain M H' where "moebius_circline M H = H'" "circline_diag H'"
	+ using circline_diagonalize[of H]
	+ by auto
	+ hence "P (moebius_circline M H)"
	+ using assms(1)
	+ by simp
	+ thus ?thesis
	+ using assms(2)[of "moebius_circline M H" "moebius_inv M"]
	+ by simp
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Zero type circline set cardinality\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma circline_type_zero_card_eq1_0:
	+ assumes "circline_type H = 0" and "0\<^sub>h \<in> circline_set H"
	+ shows "circline_set H = {0\<^sub>h}"
	+using assms
	+unfolding circline_set_def
	+proof(safe)
	+ fix z
	+ assume "on_circline H z" "circline_type H = 0" "on_circline H 0\<^sub>h"
	+ hence "H = circline_point_0"
	+ using unique_circline_type_zero_0'
	+ unfolding circline_set_def
	+ by simp
	+ thus "z = 0\<^sub>h"
	+ using \<open>on_circline H z\<close>
	+ by (transfer, transfer) (case_tac z, case_tac H, force simp add: vec_cnj_def)
	+qed
	+
	+
	+lemma circline_type_zero_card_eq1:
	+ assumes "circline_type H = 0"
	+ shows "\<exists> z. circline_set H = {z}"
	+proof-
	+ have "\<exists> z. on_circline H z"
	+ using assms
	+ proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ hence "C = cnj B" "is_real A" "is_real D"
	+ using hh hermitean_elems[of A B C D]
	+ by auto
	+ assume "circline_type_cmat H = 0"
	+ hence "mat_det H = 0"
	+ by (simp add: complex_eq_if_Re_eq hh mat_det_hermitean_real sgn_eq_0_iff)
	+ hence "AD = BC"
	+ using HH
	+ by simp
	+ show "Bex {v. v \<noteq> vec_zero} (on_circline_cmat_cvec H)"
	+ proof (cases "A \<noteq> 0 \<or> B \<noteq> 0")
	+ case True
	+ thus ?thesis
	+ using HH \<open>AD = BC\<close>
	+ by (rule_tac x="(-B, A)" in bexI) (auto simp add: Let_def vec_cnj_def field_simps)
	+ next
	+ case False
	+ thus ?thesis
	+ using HH \<open>C = cnj B\<close>
	+ by (rule_tac x="(1, 0)" in bexI) (simp_all add: Let_def vec_cnj_def)
	+ qed
	+ qed
	+ then obtain z where "on_circline H z"
	+ by auto
	+ obtain M where "moebius_pt M z = 0\<^sub>h"
	+ using ex_moebius_1[of z]
	+ by auto
	+ hence "0\<^sub>h \<in> circline_set (moebius_circline M H)"
	+ using on_circline_moebius_circline_I[OF \<open>on_circline H z\<close>, of M]
	+ unfolding circline_set_def
	+ by simp
	+ hence "circline_set (moebius_circline M H) = {0\<^sub>h}"
	+ using circline_type_zero_card_eq1_0[of "moebius_circline M H"] \<open>circline_type H = 0\<close>
	+ by auto
	+ hence "circline_set H = {z}"
	+ using \<open>moebius_pt M z = 0\<^sub>h\<close>
	+ using bij_moebius_pt[of M] bij_image_singleton[of "moebius_pt M" "circline_set H" _ z]
	+ by simp
	+ thus ?thesis
	+ by auto
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Negative type circline set cardinality\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma quad_form_diagonal_iff:
	+ assumes "k1 \<noteq> 0" and "is_real k1" and "is_real k2" and "Re k1 * Re k2 < 0"
	+ shows "quad_form (z1, 1) (k1, 0, 0, k2) = 0 \<longleftrightarrow> (\<exists> \<phi>. z1 = rcis (sqrt (Re (-k2 /k1))) \<phi>)"
	+proof-
	+ have "Re (-k2/k1) \<ge> 0"
	+ using \<open>Re k1 * Re k2 < 0\<close> \<open>is_real k1\<close> \<open>is_real k2\<close> \<open>k1 \<noteq> 0\<close>
	+ using Re_divide_real[of k1 "-k2"]
	+ by (smt divide_less_0_iff mult_nonneg_nonneg mult_nonpos_nonpos uminus_complex.simps(1))
	+
	+ have "quad_form (z1, 1) (k1, 0, 0, k2) = 0 \<longleftrightarrow> (cor (cmod z1))\<^sup>2 = -k2 / k1"
	+ using assms add_eq_0_iff[of k2 "k1*(cor (cmod z1))\<^sup>2"]
	+ using eq_divide_imp[of k1 "(cor (cmod z1))\<^sup>2" "-k2"]
	+ by (auto simp add: vec_cnj_def field_simps complex_mult_cnj_cmod)
	+ also have "... \<longleftrightarrow> (cmod z1)\<^sup>2 = Re (-k2 /k1)"
	+ using assms
	+ apply (subst complex_eq_if_Re_eq)
	+ using Re_complex_of_real[of "(cmod z1)\<^sup>2"] div_reals
	+ by auto
	+ also have "... \<longleftrightarrow> cmod z1 = sqrt (Re (-k2 /k1))"
	+ by (metis norm_ge_zero real_sqrt_ge_0_iff real_sqrt_pow2 real_sqrt_power)
	+ also have "... \<longleftrightarrow> (\<exists> \<phi>. z1 = rcis (sqrt (Re (-k2 /k1))) \<phi>)"
	+ using rcis_cmod_arg[of z1, symmetric] assms abs_of_nonneg[of "sqrt (Re (-k2/k1))"]
	+ using \<open>Re (-k2/k1) \<ge> 0\<close>
	+ by auto
	+ finally show ?thesis
	+ .
	+qed
	+
	+lemma circline_type_neg_card_gt3_diag:
	+ assumes "circline_type H < 0" and "circline_diag H"
	+ shows "\<exists> A B C. A \<noteq> B \<and> A \<noteq> C \<and> B \<noteq> C \<and> {A, B, C} \<subseteq> circline_set H"
	+ using assms
	+ unfolding circline_set_def
	+ apply (simp del: HOL.ex_simps)
	+proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ hence HH_elems: "is_real A" "is_real D" "C = cnj B"
	+ using hermitean_elems[of A B C D] hh
	+ by auto
	+ assume "circline_type_cmat H < 0" "is_diag_circline_cmat H"
	+ hence "B = 0" "C = 0" "Re A * Re D < 0" "A \<noteq> 0"
	+ using HH \<open>is_real A\<close> \<open>is_real D\<close>
	+ by auto
	+
	+ let ?x = "sqrt (Re (- D / A))"
	+ let ?A = "(rcis ?x 0, 1)"
	+ let ?B = "(rcis ?x (pi/2), 1)"
	+ let ?C = "(rcis ?x pi, 1)"
	+ from quad_form_diagonal_iff[OF \<open>A \<noteq> 0\<close> \<open>is_real A\<close> \<open>is_real D\<close> \<open>Re A * Re D < 0\<close>]
	+ have "quad_form ?A (A, 0, 0, D) = 0" "quad_form ?B (A, 0, 0, D) = 0" "quad_form ?C (A, 0, 0, D) = 0"
	+ by (auto simp del: rcis_zero_arg)
	+ hence "on_circline_cmat_cvec H ?A \<and> on_circline_cmat_cvec H ?B \<and> on_circline_cmat_cvec H ?C"
	+ using HH \<open>B = 0\<close> \<open>C = 0\<close>
	+ by simp
	+ moreover
	+ have "Re (D / A) < 0"
	+ using \<open>Re A * Re D < 0\<close> \<open>A \<noteq> 0\<close> \<open>is_real A\<close> \<open>is_real D\<close>
	+ using Re_divide_real[of A D]
	+ by (metis Re_complex_div_lt_0 Re_mult_real div_reals eq_cnj_iff_real is_real_div)
	+ hence "\<not> ?A \<approx>\<^sub>v ?B \<and> \<not> ?A \<approx>\<^sub>v ?C \<and> \<not> ?B \<approx>\<^sub>v ?C"
	+ unfolding rcis_def
	+ by (auto simp add: cis_def complex.corec)
	+ moreover
	+ have "?A \<noteq> vec_zero" "?B \<noteq> vec_zero" "?C \<noteq> vec_zero"
	+ by auto
	+ ultimately
	+ show "\<exists>A\<in>{v. v \<noteq> vec_zero}. \<exists>B\<in>{v. v \<noteq> vec_zero}. \<exists>C\<in>{v. v \<noteq> vec_zero}.
	+ \<not> A \<approx>\<^sub>v B \<and> \<not> A \<approx>\<^sub>v C \<and> \<not> B \<approx>\<^sub>v C \<and>
	+ on_circline_cmat_cvec H A \<and> on_circline_cmat_cvec H B \<and> on_circline_cmat_cvec H C"
	+ by blast
	+qed
	+
	+lemma circline_type_neg_card_gt3:
	+ assumes "circline_type H < 0"
	+ shows "\<exists> A B C. A \<noteq> B \<and> A \<noteq> C \<and> B \<noteq> C \<and> {A, B, C} \<subseteq> circline_set H"
	+proof-
	+ obtain M H' where "moebius_circline M H = H'" "circline_diag H'"
	+ using circline_diagonalize[of H] assms
	+ by auto
	+ moreover
	+ hence "circline_type H' < 0"
	+ using assms moebius_preserve_circline_type
	+ by auto
	+ ultimately
	+ obtain A B C where "A \<noteq> B" "A \<noteq> C" "B \<noteq> C" "{A, B, C} \<subseteq> circline_set H'"
	+ using circline_type_neg_card_gt3_diag[of H']
	+ by auto
	+ let ?iM = "moebius_inv M"
	+ have "moebius_circline ?iM H' = H"
	+ using \<open>moebius_circline M H = H'\<close>[symmetric]
	+ by simp
	+ let ?A = "moebius_pt ?iM A" and ?B= "moebius_pt ?iM B" and ?C = "moebius_pt ?iM C"
	+ have "?A \<in> circline_set H" "?B \<in> circline_set H" "?C \<in> circline_set H"
	+ using \<open>moebius_circline ?iM H' = H\<close>[symmetric] \<open>{A, B, C} \<subseteq> circline_set H'\<close>
	+ by simp_all
	+ moreover
	+ have "?A \<noteq> ?B" "?A \<noteq> ?C" "?B \<noteq> ?C"
	+ using \<open>A \<noteq> B\<close> \<open>A \<noteq> C\<close> \<open>B \<noteq> C\<close>
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by auto
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Positive type circline set cardinality\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma circline_type_pos_card_eq0_diag:
	+ assumes "circline_diag H" and "circline_type H > 0"
	+ shows "circline_set H = {}"
	+using assms
	+unfolding circline_set_def
	+apply simp
	+proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ hence HH_elems: "is_real A" "is_real D" "C = cnj B"
	+ using hermitean_elems[of A B C D] hh
	+ by auto
	+ assume "is_diag_circline_cmat H" "0 < circline_type_cmat H"
	+ hence "B = 0" "C = 0" "Re A * Re D > 0" "A \<noteq> 0"
	+ using HH \<open>is_real A\<close> \<open>is_real D\<close>
	+ by auto
	+ show "\<forall>x\<in>{v. v \<noteq> vec_zero}. \<not> on_circline_cmat_cvec H x"
	+ proof
	+ fix x
	+ assume "x \<in> {v. v \<noteq> vec_zero}"
	+ obtain x1 x2 where xx: "x = (x1, x2)"
	+ by (cases x, auto)
	+ have "(Re A > 0 \<and> Re D > 0) \<or> (Re A < 0 \<and> Re D < 0)"
	+ using \<open>Re A * Re D > 0\<close>
	+ by (metis linorder_neqE_linordered_idom mult_eq_0_iff zero_less_mult_pos zero_less_mult_pos2)
	+ moreover
	+ have "(Re (x1 * cnj x1) \<ge> 0 \<and> Re (x2 * cnj x2) > 0) \<or> (Re (x1 * cnj x1) > 0 \<and> Re (x2 * cnj x2) \<ge> 0)"
	+ using \<open>x \<in> {v. v \<noteq> vec_zero}\<close> xx
	+ apply auto
	+ apply (simp add: complex_neq_0 power2_eq_square)+
	+ done
	+ ultimately
	+ have "Re A * Re (x1 * cnj x1) + Re D * Re (x2 * cnj x2) \<noteq> 0"
	+ by (smt mult_neg_pos mult_nonneg_nonneg mult_nonpos_nonneg mult_pos_pos)
	+ hence "A * (x1 * cnj x1) + D * (x2 * cnj x2) \<noteq> 0"
	+ using \<open>is_real A\<close> \<open>is_real D\<close>
	+ by (metis Re_mult_real plus_complex.simps(1) zero_complex.simps(1))
	+ thus "\<not> on_circline_cmat_cvec H x"
	+ using HH \<open>B = 0\<close> \<open>C = 0\<close> xx
	+ by (simp add: vec_cnj_def field_simps)
	+ qed
	+qed
	+
	+lemma circline_type_pos_card_eq0:
	+ assumes "circline_type H > 0"
	+ shows "circline_set H = {}"
	+proof-
	+ obtain M H' where "moebius_circline M H = H'" "circline_diag H'"
	+ using circline_diagonalize[of H] assms
	+ by auto
	+ moreover
	+ hence "circline_type H' > 0"
	+ using assms moebius_preserve_circline_type
	+ by auto
	+ ultimately
	+ have "circline_set H' = {}"
	+ using circline_type_pos_card_eq0_diag[of H']
	+ by auto
	+ let ?iM = "moebius_inv M"
	+ have "moebius_circline ?iM H' = H"
	+ using \<open>moebius_circline M H = H'\<close>[symmetric]
	+ by simp
	+ thus ?thesis
	+ using \<open>circline_set H' = {}\<close>
	+ by auto
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Cardinality determines type\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma card_eq1_circline_type_zero:
	+ assumes "\<exists> z. circline_set H = {z}"
	+ shows "circline_type H = 0"
	+proof (cases "circline_type H < 0")
	+ case True
	+ thus ?thesis
	+ using circline_type_neg_card_gt3[of H] assms
	+ by auto
	+next
	+ case False
	+ show ?thesis
	+ proof (cases "circline_type H > 0")
	+ case True
	+ thus ?thesis
	+ using circline_type_pos_card_eq0[of H] assms
	+ by auto
	+ next
	+ case False
	+ thus ?thesis
	+ using \<open>\<not> (circline_type H) < 0\<close>
	+ by simp
	+ qed
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Circline set is injective\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma inj_circline_set:
	+ assumes "circline_set H = circline_set H'" and "circline_set H \<noteq> {}"
	+ shows "H = H'"
	+proof (cases "circline_type H < 0")
	+ case True
	+ then obtain A B C where "A \<noteq> B" "A \<noteq> C" "B \<noteq> C" "{A, B, C} \<subseteq> circline_set H"
	+ using circline_type_neg_card_gt3[of H]
	+ by auto
	+ hence "\<exists>!H. A \<in> circline_set H \<and> B \<in> circline_set H \<and> C \<in> circline_set H"
	+ using unique_circline_set[of A B C]
	+ by simp
	+ thus ?thesis
	+ using \<open>circline_set H = circline_set H'\<close> \<open>{A, B, C} \<subseteq> circline_set H\<close>
	+ by auto
	+next
	+ case False
	+ show ?thesis
	+ proof (cases "circline_type H = 0")
	+ case True
	+ moreover
	+ then obtain A where "{A} = circline_set H"
	+ using circline_type_zero_card_eq1[of H]
	+ by auto
	+ moreover
	+ hence "circline_type H' = 0"
	+ using \<open>circline_set H = circline_set H'\<close> card_eq1_circline_type_zero[of H']
	+ by auto
	+ ultimately
	+ show ?thesis
	+ using unique_circline_type_zero[of A] \<open>circline_set H = circline_set H'\<close>
	+ by auto
	+ next
	+ case False
	+ hence "circline_type H > 0"
	+ using \<open>\<not> (circline_type H < 0)\<close>
	+ by auto
	+ thus ?thesis
	+ using \<open>circline_set H \<noteq> {}\<close> circline_type_pos_card_eq0[of H]
	+ by auto
	+ qed
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Circline points - cross ratio real\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma four_points_on_circline_iff_cross_ratio_real:
	+ assumes "distinct [z, u, v, w]"
	+ shows "is_real (to_complex (cross_ratio z u v w)) \<longleftrightarrow>
	+ (\<exists> H. {z, u, v, w} \<subseteq> circline_set H)"
	+proof-
	+ have "\<forall> z. distinct [z, u, v, w] \<longrightarrow> is_real (to_complex (cross_ratio z u v w)) \<longleftrightarrow> (\<exists> H. {z, u, v, w} \<subseteq> circline_set H)"
	+ (is "?P u v w")
	+ proof (rule wlog_moebius_01inf[of ?P u v w])
	+ fix M a b c
	+ assume aa: "?P a b c"
	+ let ?Ma = "moebius_pt M a" and ?Mb = "moebius_pt M b" and ?Mc = "moebius_pt M c"
	+ show "?P ?Ma ?Mb ?Mc"
	+ proof (rule allI, rule impI)
	+ fix z
	+ obtain d where *: "z = moebius_pt M d"
	+ using bij_moebius_pt[of M]
	+ unfolding bij_def
	+ by auto
	+ let ?Md = "moebius_pt M d"
	+ assume "distinct [z, moebius_pt M a, moebius_pt M b, moebius_pt M c]"
	+ hence "distinct [a, b, c, d]"
	+ using *
	+ by auto
	+ moreover
	+ have "(\<exists> H. {d, a, b, c} \<subseteq> circline_set H) \<longleftrightarrow> (\<exists> H. {z, ?Ma, ?Mb, ?Mc} \<subseteq> circline_set H)"
	+ using *
	+ apply auto
	+ apply (rule_tac x="moebius_circline M H" in exI, simp)
	+ apply (rule_tac x="moebius_circline (moebius_inv M) H" in exI, simp)
	+ done
	+ ultimately
	+ show "is_real (to_complex (cross_ratio z ?Ma ?Mb ?Mc)) = (\<exists>H. {z, ?Ma, ?Mb, ?Mc} \<subseteq> circline_set H)"
	+ using aa[rule_format, of d] *
	+ by auto
	+ qed
	+ next
	+ show "?P 0\<^sub>h 1\<^sub>h \<infinity>\<^sub>h"
	+ proof safe
	+ fix z
	+ assume "distinct [z, 0\<^sub>h, 1\<^sub>h, \<infinity>\<^sub>h]"
	+ hence "z \<noteq> \<infinity>\<^sub>h"
	+ by auto
	+ assume "is_real (to_complex (cross_ratio z 0\<^sub>h 1\<^sub>h \<infinity>\<^sub>h))"
	+ hence "is_real (to_complex z)"
	+ by simp
	+ hence "z \<in> circline_set x_axis"
	+ using of_complex_to_complex[symmetric, OF \<open>z \<noteq> \<infinity>\<^sub>h\<close>]
	+ using circline_set_x_axis
	+ by auto
	+ thus "\<exists>H. {z, 0\<^sub>h, 1\<^sub>h, \<infinity>\<^sub>h} \<subseteq> circline_set H"
	+ by (rule_tac x=x_axis in exI, auto)
	+ next
	+ fix z H
	+ assume *: "distinct [z, 0\<^sub>h, 1\<^sub>h, \<infinity>\<^sub>h]" "{z, 0\<^sub>h, 1\<^sub>h, \<infinity>\<^sub>h} \<subseteq> circline_set H"
	+ hence "H = x_axis"
	+ by auto
	+ hence "z \<in> circline_set x_axis"
	+ using *
	+ by auto
	+ hence "is_real (to_complex z)"
	+ using * circline_set_x_axis
	+ by auto
	+ thus "is_real (to_complex (cross_ratio z 0\<^sub>h 1\<^sub>h \<infinity>\<^sub>h))"
	+ by simp
	+ qed
	+ next
	+ show "u \<noteq> v" "v \<noteq> w" "u \<noteq> w"
	+ using assms
	+ by auto
	+ qed
	+ thus ?thesis
	+ using assms
	+ by auto
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Symmetric points wrt. circline\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>In the extended complex plane there are no substantial differences between circles and lines,
	+so we will consider only one kind of relation and call two points \emph{circline symmetric} if they
	+are mapped to one another using either reflection or inversion over arbitrary line or circle. Points
	+are symmetric iff the bilinear form of their representation vectors and matrix is zero.\<close>
	+
	+definition circline_symmetric_cvec_cmat :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_mat \<Rightarrow> bool" where
	+ [simp]: "circline_symmetric_cvec_cmat z1 z2 H \<longleftrightarrow> bilinear_form z1 z2 H = 0"
	+lift_definition circline_symmetric_hcoords_clmat :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> circline_mat \<Rightarrow> bool" is circline_symmetric_cvec_cmat
	+ done
	+lift_definition circline_symmetric :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> circline \<Rightarrow> bool" is circline_symmetric_hcoords_clmat
	+ apply transfer
	+ apply (simp del: bilinear_form_def)
	+ apply (erule exE)+
	+ apply (simp add: bilinear_form_scale_m bilinear_form_scale_v1 bilinear_form_scale_v2 del: vec_cnj_sv quad_form_def bilinear_form_def)
	+ done
	+
	+lemma symmetry_principle [simp]:
	+ assumes "circline_symmetric z1 z2 H"
	+ shows "circline_symmetric (moebius_pt M z1) (moebius_pt M z2) (moebius_circline M H)"
	+ using assms
	+ by (transfer, transfer, simp del: bilinear_form_def congruence_def)
	+
	+text \<open>Symmetry wrt. @{term "unit_circle"}\<close>
	+lemma circline_symmetric_0inf_disc [simp]:
	+ shows "circline_symmetric 0\<^sub>h \<infinity>\<^sub>h unit_circle"
	+ by (transfer, transfer, simp add: vec_cnj_def)
	+
	+lemma circline_symmetric_inv_homo_disc [simp]:
	+ shows "circline_symmetric a (inversion a) unit_circle"
	+ unfolding inversion_def
	+ by (transfer, transfer) (case_tac a, auto simp add: vec_cnj_def)
	+
	+lemma circline_symmetric_inv_homo_disc':
	+ assumes "circline_symmetric a a' unit_circle"
	+ shows "a' = inversion a"
	+ unfolding inversion_def
	+ using assms
	+proof (transfer, transfer)
	+ fix a a'
	+ assume vz: "a \<noteq> vec_zero" "a' \<noteq> vec_zero"
	+ obtain a1 a2 where aa: "a = (a1, a2)"
	+ by (cases a, auto)
	+ obtain a1' a2' where aa': "a' = (a1', a2')"
	+ by (cases a', auto)
	+ assume *: "circline_symmetric_cvec_cmat a a' unit_circle_cmat"
	+ show "a' \<approx>\<^sub>v (conjugate_cvec \<circ> reciprocal_cvec) a"
	+ proof (cases "a1' = 0")
	+ case True
	+ thus ?thesis
	+ using aa aa' vz *
	+ by (auto simp add: vec_cnj_def field_simps)
	+ next
	+ case False
	+ show ?thesis
	+ proof (cases "a2 = 0")
	+ case True
	+ thus ?thesis
	+ using \<open>a1' \<noteq> 0\<close>
	+ using aa aa' * vz
	+ by (simp add: vec_cnj_def field_simps)
	+ next
	+ case False
	+ thus ?thesis
	+ using \<open>a1' \<noteq> 0\<close> aa aa' *
	+ by (simp add: vec_cnj_def field_simps) (rule_tac x="cnj a2 / a1'" in exI, simp add: field_simps)
	+ qed
	+ qed
	+qed
	+
	+lemma ex_moebius_circline_x_axis:
	+ assumes "circline_type H < 0"
	+ shows "\<exists> M. moebius_circline M H = x_axis"
	+proof-
	+ obtain A B C where *: "A \<noteq> B" "A \<noteq> C" "B \<noteq> C" "on_circline H A" "on_circline H B" "on_circline H C"
	+ using circline_type_neg_card_gt3[OF assms]
	+ unfolding circline_set_def
	+ by auto
	+ then obtain M where "moebius_pt M A = 0\<^sub>h" "moebius_pt M B = 1\<^sub>h" "moebius_pt M C = \<infinity>\<^sub>h"
	+ using ex_moebius_01inf by blast
	+ hence "moebius_circline M H = x_axis"
	+ using *
	+ by (metis circline_set_I circline_set_moebius_circline rev_image_eqI unique_circline_01inf')
	+ thus ?thesis
	+ by blast
	+qed
	+
	+lemma wlog_circline_x_axis:
	+ assumes "circline_type H < 0"
	+ assumes "\<And> M H. P H \<Longrightarrow> P (moebius_circline M H)"
	+ assumes "P x_axis"
	+ shows "P H"
	+proof-
	+ obtain M where "moebius_circline M H = x_axis"
	+ using ex_moebius_circline_x_axis[OF assms(1)]
	+ by blast
	+ then obtain M' where "moebius_circline M' x_axis = H"
	+ by (metis moebius_circline_comp_inv_left)
	+ thus ?thesis
	+ using assms(2)[of x_axis M'] assms(3)
	+ by simp
	+qed
	+
	+lemma circline_intersection_at_most_2_points:
	+ assumes "H1 \<noteq> H2"
	+ shows "finite (circline_intersection H1 H2) \<and> card (circline_intersection H1 H2) \<le> 2"
	+proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "infinite (circline_intersection H1 H2) \<or> card (circline_intersection H1 H2) > 2"
	+ by auto
	+ hence "\<exists> A B C. A \<noteq> B \<and> B \<noteq> C \<and> A \<noteq> C \<and> {A, B, C} \<subseteq> circline_intersection H1 H2"
	+ proof
	+ assume "card (circline_intersection H1 H2) > 2"
	+ thus ?thesis
	+ using card_geq_3_iff_contains_3_elems[of "circline_intersection H1 H2"]
	+ by auto
	+ next
	+ assume "infinite (circline_intersection H1 H2)"
	+ thus ?thesis
	+ using infinite_contains_3_elems
	+ by blast
	+ qed
	+ then obtain A B C where "A \<noteq> B" "B \<noteq> C" "A \<noteq> C" "{A, B, C} \<subseteq> circline_intersection H1 H2"
	+ by blast
	+ hence "H2 = H1"
	+ using circline_intersection_def mem_Collect_eq unique_circline_set by fastforce
	+ thus False
	+ using assms
	+ by simp
	+qed
	+
	+end
	diff --git a/thys/Complex_Geometry/Circlines_Angle.thy b/thys/Complex_Geometry/Circlines_Angle.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Circlines_Angle.thy
	@@ -0,0 +1,387 @@
	+theory Circlines_Angle
	+ imports Oriented_Circlines Elementary_Complex_Geometry
	+begin
	+
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Angle between circlines\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Angle between circlines can be defined in purely algebraic terms (following Schwerdtfeger
	+\cite{schwerdtfeger}) and using this definitions many properties can be easily proved.\<close>
	+
	+fun mat_det_12 :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex" where
	+ "mat_det_12 (A1, B1, C1, D1) (A2, B2, C2, D2) = A1D2 + A2D1 - B1C2 - B2C1"
	+
	+lemma mat_det_12_mm_l [simp]:
	+ shows "mat_det_12 (M \<^sub>m\<^sub>m A) (M \<^sub>m\<^sub>m B) = mat_det M * mat_det_12 A B"
	+ by (cases M, cases A, cases B) (simp add: field_simps)
	+
	+lemma mat_det_12_mm_r [simp]:
	+ shows "mat_det_12 (A \<^sub>m\<^sub>m M) (B \<^sub>m\<^sub>m M) = mat_det M * mat_det_12 A B"
	+ by (cases M, cases A, cases B) (simp add: field_simps)
	+
	+lemma mat_det_12_sm_l [simp]:
	+ shows "mat_det_12 (k \<^sub>s\<^sub>m A) B = k mat_det_12 A B"
	+ by (cases A, cases B) (simp add: field_simps)
	+
	+lemma mat_det_12_sm_r [simp]:
	+ shows "mat_det_12 A (k \<^sub>s\<^sub>m B) = k mat_det_12 A B"
	+ by (cases A, cases B) (simp add: field_simps)
	+
	+lemma mat_det_12_congruence [simp]:
	+ shows "mat_det_12 (congruence M A) (congruence M B) = (cor ((cmod (mat_det M))\<^sup>2)) * mat_det_12 A B"
	+ unfolding congruence_def
	+ by ((subst mult_mm_assoc[symmetric])+, subst mat_det_12_mm_l, subst mat_det_12_mm_r, subst mat_det_adj) (auto simp add: field_simps complex_mult_cnj_cmod)
	+
	+
	+definition cos_angle_cmat :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> real" where
	+ [simp]: "cos_angle_cmat H1 H2 = - Re (mat_det_12 H1 H2) / (2 * (sqrt (Re (mat_det H1 * mat_det H2))))"
	+
	+lift_definition cos_angle_clmat :: "circline_mat \<Rightarrow> circline_mat \<Rightarrow> real" is cos_angle_cmat
	+ done
	+
	+lemma cos_angle_den_scale [simp]:
	+ assumes "k1 > 0" and "k2 > 0"
	+ shows "sqrt (Re ((k1\<^sup>2 * mat_det H1) * (k2\<^sup>2 * mat_det H2))) =
	+ k1 * k2 * sqrt (Re (mat_det H1 * mat_det H2))"
	+proof-
	+ let ?lhs = "(k1\<^sup>2 * mat_det H1) * (k2\<^sup>2 * mat_det H2)"
	+ let ?rhs = "mat_det H1 * mat_det H2"
	+ have 1: "?lhs = (k1\<^sup>2k2\<^sup>2) ?rhs"
	+ by simp
	+ hence "Re ?lhs = (k1\<^sup>2k2\<^sup>2) Re ?rhs"
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using assms
	+ by (simp add: real_sqrt_mult)
	+qed
	+
	+lift_definition cos_angle :: "ocircline \<Rightarrow> ocircline \<Rightarrow> real" is cos_angle_clmat
	+proof transfer
	+ fix H1 H2 H1' H2'
	+ assume "ocircline_eq_cmat H1 H1'" "ocircline_eq_cmat H2 H2'"
	+ then obtain k1 k2 :: real where
	+ : "k1 > 0" "H1' = cor k1 \<^sub>s\<^sub>m H1"
	+ "k2 > 0" "H2' = cor k2 *\<^sub>s\<^sub>m H2"
	+ by auto
	+ thus "cos_angle_cmat H1 H2 = cos_angle_cmat H1' H2'"
	+ unfolding cos_angle_cmat_def
	+ apply (subst *)+
	+ apply (subst mat_det_12_sm_l, subst mat_det_12_sm_r)
	+ apply (subst mat_det_mult_sm)+
	+ apply (subst power2_eq_square[symmetric])+
	+ apply (subst cos_angle_den_scale, simp, simp)
	+ apply simp
	+ done
	+qed
	+
	+text \<open>Möbius transformations are conformal, meaning that they preserve oriented angle between
	+oriented circlines.\<close>
	+
	+lemma cos_angle_opposite1 [simp]:
	+ shows "cos_angle (opposite_ocircline H) H' = - cos_angle H H'"
	+ by (transfer, transfer, simp)
	+
	+lemma cos_angle_opposite2 [simp]:
	+ shows "cos_angle H (opposite_ocircline H') = - cos_angle H H'"
	+ by (transfer, transfer, simp)
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Connection with the elementary angle definition between circles\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text\<open>We want to connect algebraic definition of an angle with a traditional one and
	+to prove equivalency between these two definitions. For the traditional definition of
	+an angle we follow the approach suggested by Needham \cite{needham}.\<close>
	+
	+lemma Re_sgn:
	+ assumes "is_real A" and "A \<noteq> 0"
	+ shows "Re (sgn A) = sgn_bool (Re A > 0)"
	+using assms
	+using More_Complex.Re_sgn complex_eq_if_Re_eq
	+by auto
	+
	+lemma Re_mult_real3:
	+ assumes "is_real z1" and "is_real z2" and "is_real z3"
	+ shows "Re (z1 * z2 * z3) = Re z1 * Re z2 * Re z3"
	+ using assms
	+ by (metis Re_mult_real mult_reals)
	+
	+lemma sgn_sqrt [simp]:
	+ shows "sgn (sqrt x) = sgn x"
	+ by (simp add: sgn_root sqrt_def)
	+
	+lemma real_circle_sgn_r:
	+ assumes "is_circle H" and "(a, r) = euclidean_circle H"
	+ shows "sgn r = - circline_type H"
	+ using assms
	+proof (transfer, transfer)
	+ fix H :: complex_mat and a r
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ hence "is_real A" "is_real D"
	+ using hermitean_elems hh
	+ by auto
	+ assume "\<not> circline_A0_cmat H" "(a, r) = euclidean_circle_cmat H"
	+ hence "A \<noteq> 0"
	+ using \<open>\<not> circline_A0_cmat H\<close> HH
	+ by simp
	+ hence "Re A * Re A > 0"
	+ using \<open>is_real A\<close>
	+ using complex_eq_if_Re_eq not_real_square_gt_zero
	+ by fastforce
	+ thus "sgn r = - circline_type_cmat H"
	+ using HH \<open>(a, r) = euclidean_circle_cmat H\<close> \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> 0\<close>
	+ by (simp add: Re_divide_real sgn_minus[symmetric])
	+qed
	+
	+text \<open>The definition of an angle using algebraic terms is not intuitive, and we want to connect it to
	+the more common definition given earlier that defines an
	+angle between circlines as the angle between tangent vectors in the point of the intersection of the
	+circlines.\<close>
	+
	+lemma cos_angle_eq_cos_ang_circ:
	+ assumes
	+ "is_circle (of_ocircline H1)" and "is_circle (of_ocircline H2)" and
	+ "circline_type (of_ocircline H1) < 0" and "circline_type (of_ocircline H2) < 0"
	+ "(a1, r1) = euclidean_circle (of_ocircline H1)" and "(a2, r2) = euclidean_circle (of_ocircline H2)" and
	+ "of_complex E \<in> ocircline_set H1 \<inter> ocircline_set H2"
	+ shows "cos_angle H1 H2 = cos (ang_circ E a1 a2 (pos_oriented H1) (pos_oriented H2))"
	+proof-
	+ let ?p1 = "pos_oriented H1" and ?p2 = "pos_oriented H2"
	+ have "E \<in> circle a1 r1" "E \<in> circle a2 r2"
	+ using classic_circle[of "of_ocircline H1" a1 r1] classic_circle[of "of_ocircline H2" a2 r2]
	+ using assms of_complex_inj
	+ by auto
	+ hence *: "cdist E a1 = r1" "cdist E a2 = r2"
	+ unfolding circle_def
	+ by (simp_all add: norm_minus_commute)
	+ have "r1 > 0" "r2 > 0"
	+ using assms(1-6) real_circle_sgn_r[of "of_ocircline H1" a1 r1] real_circle_sgn_r[of "of_ocircline H2" a2 r2]
	+ using sgn_greater
	+ by fastforce+
	+ hence "E \<noteq> a1" "E \<noteq> a2"
	+ using \<open>cdist E a1 = r1\<close> \<open>cdist E a2 = r2\<close>
	+ by auto
	+
	+ let ?k = "sgn_bool (?p1 = ?p2)"
	+ let ?xx = "?k * (r1\<^sup>2 + r2\<^sup>2 - (cdist a2 a1)\<^sup>2) / (2 * r1 * r2)"
	+
	+ have "cos (ang_circ E a1 a2 ?p1 ?p2) = ?xx"
	+ using law_of_cosines[of a2 a1 E] * \<open>r1 > 0\<close> \<open>r2 > 0\<close> cos_ang_circ_simp[OF \<open>E \<noteq> a1\<close> \<open>E \<noteq> a2\<close>]
	+ by (subst (asm) ang_vec_opposite_opposite'[OF \<open>E \<noteq> a1\<close>[symmetric] \<open>E \<noteq> a2\<close>[symmetric], symmetric]) simp
	+ moreover
	+ have "cos_angle H1 H2 = ?xx"
	+ using \<open>r1 > 0\<close> \<open>r2 > 0\<close>
	+ using \<open>(a1, r1) = euclidean_circle (of_ocircline H1)\<close> \<open>(a2, r2) = euclidean_circle (of_ocircline H2)\<close>
	+ using \<open>is_circle (of_ocircline H1)\<close> \<open>is_circle (of_ocircline H2)\<close>
	+ using \<open>circline_type (of_ocircline H1) < 0\<close> \<open>circline_type (of_ocircline H2) < 0\<close>
	+ proof (transfer, transfer)
	+ fix a1 r1 H1 H2 a2 r2
	+ assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ obtain A1 B1 C1 D1 where HH1: "H1 = (A1, B1, C1, D1)"
	+ by (cases H1) auto
	+ obtain A2 B2 C2 D2 where HH2: "H2 = (A2, B2, C2, D2)"
	+ by (cases H2) auto
	+ have *: "is_real A1" "is_real A2" "is_real D1" "is_real D2" "cnj B1 = C1" "cnj B2 = C2"
	+ using hh hermitean_elems[of A1 B1 C1 D1] hermitean_elems[of A2 B2 C2 D2] HH1 HH2
	+ by auto
	+ have "cnj A1 = A1" "cnj A2 = A2"
	+ using \<open>is_real A1\<close> \<open>is_real A2\<close>
	+ by (case_tac[!] A1, case_tac[!] A2, auto simp add: Complex_eq)
	+
	+ assume "\<not> circline_A0_cmat (id H1)" "\<not> circline_A0_cmat (id H2)"
	+ hence "A1 \<noteq> 0" "A2 \<noteq> 0"
	+ using HH1 HH2
	+ by auto
	+ hence "Re A1 \<noteq> 0" "Re A2 \<noteq> 0"
	+ using \<open>is_real A1\<close> \<open>is_real A2\<close>
	+ using complex.expand
	+ by auto
	+
	+ assume "circline_type_cmat (id H1) < 0" "circline_type_cmat (id H2) < 0"
	+ assume "(a1, r1) = euclidean_circle_cmat (id H1)" "(a2, r2) = euclidean_circle_cmat (id H2)"
	+ assume "r1 > 0" "r2 > 0"
	+
	+ let ?D12 = "mat_det_12 H1 H2" and ?D1 = "mat_det H1" and ?D2 = "mat_det H2"
	+ let ?x1 = "(cdist a2 a1)\<^sup>2 - r1\<^sup>2 - r2\<^sup>2" and ?x2 = "2r1r2"
	+ let ?x = "?x1 / ?x2"
	+ have : "Re (?D12) / (2 (sqrt (Re (?D1 * ?D2)))) = Re (sgn A1) * Re (sgn A2) * ?x"
	+ proof-
	+ let ?M1 = "(A1, B1, C1, D1)" and ?M2 = "(A2, B2, C2, D2)"
	+ let ?d1 = "B1 * C1 - A1 * D1" and ?d2 = "B2 * C2 - A2 * D2"
	+ have "Re ?d1 > 0" "Re ?d2 > 0"
	+ using HH1 HH2 \<open>circline_type_cmat (id H1) < 0\<close> \<open>circline_type_cmat (id H2) < 0\<close>
	+ by auto
	+ hence *: "Re (?d1 / (A1 A1)) > 0" "Re (?d2 / (A2 * A2)) > 0"
	+ using \<open>is_real A1\<close> \<open>is_real A2\<close> \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
	+ by (subst Re_divide_real, simp_all add: complex_neq_0 power2_eq_square)+
	+ have **: "is_real (?d1 / (A1 A1)) \<and> is_real (?d2 / (A2 * A2))"
	+ using \<open>is_real A1\<close> \<open>is_real A2\<close> \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close> \<open>cnj B1 = C1\<close>[symmetric] \<open>cnj B2 = C2\<close>[symmetric] \<open>is_real D1\<close> \<open>is_real D2\<close>
	+ by (subst div_reals, simp, simp, simp)+
	+
	+ have "cor ?x = mat_det_12 ?M1 ?M2 / (2 * sgn A1 * sgn A2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))"
	+ proof-
	+ have "A1A2cor ?x1 = mat_det_12 ?M1 ?M2"
	+ proof-
	+ have 1: "A1A2(cor ((cdist a2 a1)\<^sup>2)) = ((B2A1 - A2B1)(C2A1 - C1A2)) / (A1A2)"
	+ using \<open>(a1, r1) = euclidean_circle_cmat (id H1)\<close> \<open>(a2, r2) = euclidean_circle_cmat (id H2)\<close>
	+ unfolding cdist_def cmod_square
	+ using HH1 HH2 * \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close> \<open>cnj A1 = A1\<close> \<open>cnj A2 = A2\<close>
	+ unfolding Let_def
	+ apply (subst complex_of_real_Re)
	+ apply (simp add: field_simps)
	+ apply (simp add: complex_mult_cnj_cmod power2_eq_square)
	+ apply (simp add: field_simps)
	+ done
	+ have 2: "A1A2cor (-r1\<^sup>2) = A2D1 - B1C1*A2/A1"
	+ using \<open>(a1, r1) = euclidean_circle_cmat (id H1)\<close>
	+ using HH1 ** * *** \<open>A1 \<noteq> 0\<close>
	+ by (simp add: power2_eq_square field_simps)
	+ have 3: "A1A2cor (-r2\<^sup>2) = A1D2 - B2C2*A1/A2"
	+ using \<open>(a2, r2) = euclidean_circle_cmat (id H2)\<close>
	+ using HH2 ** * *** \<open>A2 \<noteq> 0\<close>
	+ by (simp add: power2_eq_square field_simps)
	+ have "A1A2cor((cdist a2 a1)\<^sup>2) + A1A2cor(-r1\<^sup>2) + A1A2cor(-r2\<^sup>2) = mat_det_12 ?M1 ?M2"
	+ using \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
	+ by (subst 1, subst 2, subst 3) (simp add: field_simps)
	+ thus ?thesis
	+ by (simp add: field_simps)
	+ qed
	+
	+ moreover
	+
	+ have "A1 * A2 * cor (?x2) = 2 * sgn A1 * sgn A2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2))"
	+ proof-
	+ have 1: "sqrt (Re (?d1/ (A1 * A1))) = sqrt (Re ?d1) / \<bar>Re A1\<bar>"
	+ using \<open>A1 \<noteq> 0\<close> \<open>is_real A1\<close>
	+ by (subst Re_divide_real, simp, simp, subst real_sqrt_divide, simp)
	+
	+ have 2: "sqrt (Re (?d2/ (A2 * A2))) = sqrt (Re ?d2) / \<bar>Re A2\<bar>"
	+ using \<open>A2 \<noteq> 0\<close> \<open>is_real A2\<close>
	+ by (subst Re_divide_real, simp, simp, subst real_sqrt_divide, simp)
	+ have "sgn A1 = A1 / cor \<bar>Re A1\<bar>"
	+ using \<open>is_real A1\<close>
	+ unfolding sgn_eq
	+ by (simp add: cmod_eq_Re)
	+ moreover
	+ have "sgn A2 = A2 / cor \<bar>Re A2\<bar>"
	+ using \<open>is_real A2\<close>
	+ unfolding sgn_eq
	+ by (simp add: cmod_eq_Re)
	+ ultimately
	+ show ?thesis
	+ using \<open>(a1, r1) = euclidean_circle_cmat (id H1)\<close> \<open>(a2, r2) = euclidean_circle_cmat (id H2)\<close> HH1 HH2
	+ using *** \<open>is_real A1\<close> \<open>is_real A2\<close>
	+ by simp (subst 1, subst 2, simp)
	+ qed
	+
	+ ultimately
	+
	+ have "(A1 * A2 * cor ?x1) / (A1 * A2 * (cor ?x2)) =
	+ mat_det_12 ?M1 ?M2 / (2 * sgn A1 * sgn A2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))"
	+ by simp
	+ thus ?thesis
	+ using \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
	+ by simp
	+ qed
	+ hence "cor ?x * sgn A1 * sgn A2 = mat_det_12 ?M1 ?M2 / (2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))"
	+ using \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
	+ by (simp add: sgn_zero_iff)
	+ moreover
	+ have "Re (cor ?x * sgn A1 * sgn A2) = Re (sgn A1) * Re (sgn A2) * ?x"
	+ proof-
	+ have "is_real (cor ?x)" "is_real (sgn A1)" "is_real (sgn A2)"
	+ using \<open>is_real A1\<close> \<open>is_real A2\<close> Im_complex_of_real[of ?x]
	+ by auto
	+ thus ?thesis
	+ using Re_complex_of_real[of ?x]
	+ by (subst Re_mult_real3, auto simp add: field_simps)
	+ qed
	+ moreover
	+ have : "sqrt (Re ?D1) sqrt (Re ?D2) = sqrt (Re ?d1) * sqrt (Re ?d2)"
	+ using HH1 HH2
	+ by (subst real_sqrt_mult[symmetric])+ (simp add: field_simps)
	+ have "2 * (sqrt (Re (?D1 * ?D2))) \<noteq> 0"
	+ using \<open>Re ?d1 > 0\<close> \<open>Re ?d2 > 0\<close> HH1 HH2 \<open>is_real A1\<close> \<open>is_real A2\<close> \<open>is_real D1\<close> \<open>is_real D2\<close>
	+ using hh mat_det_hermitean_real[of "H1"]
	+ by (subst Re_mult_real, auto)
	+ hence *: "Re (?D12 / (2 cor (sqrt (Re (?D1 * ?D2))))) = Re (?D12) / (2 * (sqrt (Re (?D1 * ?D2))))"
	+ using \<open>Re ?d1 > 0\<close> \<open>Re ?d2 > 0\<close> HH1 HH2 \<open>is_real A1\<close> \<open>is_real A2\<close> \<open>is_real D1\<close> \<open>is_real D2\<close>
	+ by (subst Re_divide_real) auto
	+ have "Re (mat_det_12 ?M1 ?M2 / (2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))) = Re (?D12) / (2 * (sqrt (Re (?D1 * ?D2))))"
	+ using HH1 HH2 hh mat_det_hermitean_real[of "H1"]
	+ by (subst *[symmetric], subst Re_mult_real, simp, subst real_sqrt_mult, subst , simp)
	+ ultimately
	+ show ?thesis
	+ by simp
	+ qed
	+ have **: "pos_oriented_cmat H1 \<longleftrightarrow> Re A1 > 0" "pos_oriented_cmat H2 \<longleftrightarrow> Re A2 > 0"
	+ using \<open>Re A1 \<noteq> 0\<close> HH1 \<open>Re A2 \<noteq> 0\<close> HH2
	+ by auto
	+ show "cos_angle_cmat H1 H2 = sgn_bool (pos_oriented_cmat H1 = pos_oriented_cmat H2) * (r1\<^sup>2 + r2\<^sup>2 - (cdist a2 a1)\<^sup>2) / (2 * r1 * r2)"
	+ unfolding Let_def
	+ using \<open>r1 > 0\<close> \<open>r2 > 0\<close>
	+ unfolding cos_angle_cmat_def
	+ apply (subst divide_minus_left)
	+ apply (subst *)
	+ apply (subst Re_sgn[OF \<open>is_real A1\<close> \<open>A1 \<noteq> 0\<close>], subst Re_sgn[OF \<open>is_real A2\<close> \<open>A2 \<noteq> 0\<close>])
	+ apply (subst , subst )
	+ apply (simp add: field_simps)
	+ done
	+ qed
	+ ultimately
	+ show ?thesis
	+ by simp
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Perpendicularity\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Two circlines are perpendicular if the intersect at right angle i.e., the angle with the cosine
	+0.\<close>
	+
	+definition perpendicular where
	+ "perpendicular H1 H2 \<longleftrightarrow> cos_angle (of_circline H1) (of_circline H2) = 0"
	+
	+lemma perpendicular_sym:
	+ shows "perpendicular H1 H2 \<longleftrightarrow> perpendicular H2 H1"
	+ unfolding perpendicular_def
	+ by (transfer, transfer, auto simp add: field_simps)
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Möbius transforms preserve angles and perpendicularity\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Möbius transformations are \emph{conformal} i.e., they preserve angles between circlines.\<close>
	+
	+lemma moebius_preserve_circline_angle [simp]:
	+ shows "cos_angle (moebius_ocircline M H1) (moebius_ocircline M H2) =
	+ cos_angle H1 H2 "
	+proof (transfer, transfer)
	+ fix H1 H2 M :: complex_mat
	+ assume hh: "mat_det M \<noteq> 0"
	+ show "cos_angle_cmat (moebius_circline_cmat_cmat M H1) (moebius_circline_cmat_cmat M H2) = cos_angle_cmat H1 H2"
	+ unfolding cos_angle_cmat_def moebius_circline_cmat_cmat_def
	+ unfolding Let_def mat_det_12_congruence mat_det_congruence
	+ using hh mat_det_inv[of M]
	+ apply (subst cor_squared[symmetric])+
	+ apply (subst cos_angle_den_scale, simp)
	+ apply (auto simp add: power2_eq_square real_sqrt_mult field_simps)
	+ done
	+qed
	+
	+lemma perpendicular_moebius [simp]:
	+ assumes "perpendicular H1 H2"
	+ shows "perpendicular (moebius_circline M H1) (moebius_circline M H2)"
	+ using assms
	+ unfolding perpendicular_def
	+ using moebius_preserve_circline_angle[of M "of_circline H1" "of_circline H2"]
	+ using moebius_ocircline_circline[of M "of_circline H1"]
	+ using moebius_ocircline_circline[of M "of_circline H2"]
	+ by (auto simp del: moebius_preserve_circline_angle)
	+
	+end
	diff --git a/thys/Complex_Geometry/Elementary_Complex_Geometry.thy b/thys/Complex_Geometry/Elementary_Complex_Geometry.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Elementary_Complex_Geometry.thy
	@@ -0,0 +1,519 @@
	+(* ----------------------------------------------------------------- *)
	+section \<open>Elementary complex geometry\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>In this section equations and basic properties of the most fundamental objects and relations in
	+geometry -- collinearity, lines, circles and circlines. These are defined by equations in
	+$\mathbb{C}$ (not extended by an infinite point). Later these equations will be generalized to
	+equations in the extended complex plane, over homogenous coordinates.\<close>
	+
	+theory Elementary_Complex_Geometry
	+imports More_Complex Linear_Systems Angles
	+begin
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Collinear points\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+definition collinear :: "complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> bool" where
	+ "collinear z1 z2 z3 \<longleftrightarrow> z1 = z2 \<or> Im ((z3 - z1) / (z2 - z1)) = 0"
	+
	+lemma collinear_ex_real:
	+ shows "collinear z1 z2 z3 \<longleftrightarrow>
	+ (\<exists> k::real. z1 = z2 \<or> z3 - z1 = complex_of_real k * (z2 - z1))"
	+ unfolding collinear_def
	+ by (metis Im_complex_of_real add_diff_cancel_right' complex_eq diff_zero legacy_Complex_simps(15) nonzero_mult_div_cancel_right right_minus_eq times_divide_eq_left zero_complex.code)
	+
	+text \<open>Collinearity characterization using determinants\<close>
	+lemma collinear_det:
	+ assumes "\<not> collinear z1 z2 z3"
	+ shows "det2 (z3 - z1) (cnj (z3 - z1)) (z1 - z2) (cnj (z1 - z2)) \<noteq> 0"
	+proof-
	+ from assms have "((z3 - z1) / (z2 - z1)) - cnj ((z3 - z1) / (z2 - z1)) \<noteq> 0" "z2 \<noteq> z1"
	+ unfolding collinear_def
	+ using Complex_Im_express_cnj[of "(z3 - z1) / (z2 - z1)"]
	+ by (auto simp add: Complex_eq)
	+ thus ?thesis
	+ by (auto simp add: field_simps)
	+qed
	+
	+text \<open>Properties of three collinear points\<close>
	+
	+lemma collinear_sym1:
	+ shows "collinear z1 z2 z3 \<longleftrightarrow> collinear z1 z3 z2"
	+ unfolding collinear_def
	+ using div_reals[of "1" "(z3 - z1)/(z2 - z1)"] div_reals[of "1" "(z2 - z1)/(z3 - z1)"]
	+ by auto
	+
	+lemma collinear_sym2':
	+ assumes "collinear z1 z2 z3"
	+ shows "collinear z2 z1 z3"
	+proof-
	+ obtain k where "z1 = z2 \<or> z3 - z1 = complex_of_real k * (z2 - z1)"
	+ using assms
	+ unfolding collinear_ex_real
	+ by auto
	+ thus ?thesis
	+ proof
	+ assume "z3 - z1 = complex_of_real k * (z2 - z1)"
	+ thus ?thesis
	+ unfolding collinear_ex_real
	+ by (rule_tac x="1-k" in exI) (auto simp add: field_simps)
	+ qed (simp add: collinear_def)
	+qed
	+
	+lemma collinear_sym2:
	+ shows "collinear z1 z2 z3 \<longleftrightarrow> collinear z2 z1 z3"
	+ using collinear_sym2'[of z1 z2 z3] collinear_sym2'[of z2 z1 z3]
	+ by auto
	+
	+text \<open>Properties of four collinear points\<close>
	+
	+lemma collinear_trans1:
	+ assumes "collinear z0 z2 z1" and "collinear z0 z3 z1" and "z0 \<noteq> z1"
	+ shows "collinear z0 z2 z3"
	+ using assms
	+ unfolding collinear_ex_real
	+ by (cases "z0 = z2", auto) (rule_tac x="k/ka" in exI, case_tac "ka = 0", auto simp add: field_simps)
	+
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Euclidean line\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Line is defined by using collinearity\<close>
	+definition line :: "complex \<Rightarrow> complex \<Rightarrow> complex set" where
	+ "line z1 z2 = {z. collinear z1 z2 z}"
	+
	+lemma line_points_collinear:
	+ assumes "z1 \<in> line z z'" and "z2 \<in> line z z'" and "z3 \<in> line z z'" and "z \<noteq> z'"
	+ shows "collinear z1 z2 z3"
	+ using assms
	+ unfolding line_def
	+ by (smt collinear_sym1 collinear_sym2' collinear_trans1 mem_Collect_eq)
	+
	+text \<open>Parametric equation of a line\<close>
	+lemma line_param:
	+ shows "z1 + cor k * (z2 - z1) \<in> line z1 z2"
	+ unfolding line_def
	+ by (auto simp add: collinear_def)
	+
	+text \<open>Equation of the line containing two different given points\<close>
	+lemma line_equation:
	+ assumes "z1 \<noteq> z2" and "\<mu> = rot90 (z2 - z1)"
	+ shows "line z1 z2 = {z. cnj \<mu>z + \<mu>cnj z - (cnj \<mu> * z1 + \<mu> * cnj z1) = 0}"
	+proof-
	+ {
	+ fix z
	+ have "z \<in> line z1 z2 \<longleftrightarrow> Im ((z - z1)/(z2 - z1)) = 0"
	+ using assms
	+ by (simp add: line_def collinear_def)
	+ also have "... \<longleftrightarrow> (z - z1)/(z2 - z1) = cnj ((z - z1)/(z2 - z1))"
	+ using complex_diff_cnj[of "(z - z1)/(z2 - z1)"]
	+ by auto
	+ also have "... \<longleftrightarrow> (z - z1)(cnj z2 - cnj z1) = (cnj z - cnj z1)(z2 - z1)"
	+ using assms(1)
	+ using \<open>(z \<in> line z1 z2) = is_real ((z - z1) / (z2 - z1))\<close> calculation is_real_div
	+ by auto
	+ also have "... \<longleftrightarrow> cnj(z2 - z1)z - (z2 - z1)cnj z - (cnj(z2 - z1)z1 - (z2 - z1)cnj z1) = 0"
	+ by (simp add: field_simps)
	+ also have "... \<longleftrightarrow> cnj \<mu> * z + \<mu> * cnj z - (cnj \<mu> * z1 + \<mu> * cnj z1) = 0"
	+ apply (subst assms)+
	+ apply (subst cnj_mix_minus)+
	+ by simp
	+ finally have "z \<in> line z1 z2 \<longleftrightarrow> cnj \<mu> * z + \<mu> * cnj z - (cnj \<mu> * z1 + \<mu> * cnj z1) = 0"
	+ .
	+ }
	+ thus ?thesis
	+ by auto
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Euclidean circle\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Definition of the circle with given center and radius. It consists of all
	+points on the distance $r$ from the center $\mu$.\<close>
	+definition circle :: "complex \<Rightarrow> real \<Rightarrow> complex set" where
	+ "circle \<mu> r = {z. cmod (z - \<mu>) = r}"
	+
	+text \<open>Equation of the circle centered at $\mu$ with the radius $r$.\<close>
	+lemma circle_equation:
	+ assumes "r \<ge> 0"
	+ shows "circle \<mu> r = {z. zcnj z - zcnj \<mu> - cnj z\<mu> + \<mu>cnj \<mu> - cor (r*r) = 0}"
	+proof (safe)
	+ fix z
	+ assume "z \<in> circle \<mu> r"
	+ hence "(z - \<mu>)cnj (z - \<mu>) = complex_of_real (rr)"
	+ unfolding circle_def
	+ using complex_mult_cnj_cmod[of "z - \<mu>"]
	+ by (auto simp add: power2_eq_square)
	+ thus "z * cnj z - z * cnj \<mu> - cnj z * \<mu> + \<mu> * cnj \<mu> - cor (r * r) = 0"
	+ by (auto simp add: field_simps)
	+next
	+ fix z
	+ assume "z * cnj z - z * cnj \<mu> - cnj z * \<mu> + \<mu> * cnj \<mu> - cor (r * r) = 0"
	+ hence "(z - \<mu>)cnj (z - \<mu>) = cor (rr)"
	+ by (auto simp add: field_simps)
	+ thus "z \<in> circle \<mu> r"
	+ using assms
	+ using complex_mult_cnj_cmod[of "z - \<mu>"]
	+ using power2_eq_imp_eq[of "cmod (z - \<mu>)" r]
	+ unfolding circle_def power2_eq_square[symmetric] complex_of_real_def
	+ by auto
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Circline\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>A very important property of the extended complex plane is that it is possible to treat circles
	+and lines in a uniform way. The basic object is \emph{generalized circle}, or \emph{circline} for
	+short. We introduce circline equation given in $\mathbb{C}$, and it will later be generalized to an
	+equation in the extended complex plane $\overline{\mathbb{C}}$ given in matrix form using a
	+Hermitean matrix and a quadratic form over homogenous coordinates.\<close>
	+
	+definition circline where
	+ "circline A BC D = {z. cor Azcnj z + cnj BCz + BCcnj z + cor D = 0}"
	+
	+text \<open>Connection between circline and Euclidean circle\<close>
	+
	+text \<open>Every circline with positive determinant and $A \neq 0$ represents an Euclidean circle\<close>
	+
	+lemma circline_circle:
	+ assumes "A \<noteq> 0" and "A * D \<le> (cmod BC)\<^sup>2"
	+ "cl = circline A BC D" and
	+ "\<mu> = -BC/cor A" and
	+ "r2 = ((cmod BC)\<^sup>2 - A*D) / A\<^sup>2" and "r = sqrt r2"
	+ shows "cl = circle \<mu> r"
	+proof-
	+ have : "cl = {z. z cnj z + cnj (BC / cor A) * z + (BC / cor A) * cnj z + cor (D / A) = 0}"
	+ using \<open>cl = circline A BC D\<close> \<open>A \<noteq> 0\<close>
	+ by (auto simp add: circline_def field_simps)
	+
	+ have "r2 \<ge> 0"
	+ proof-
	+ have "(cmod BC)\<^sup>2 - A * D \<ge> 0"
	+ using \<open>A * D \<le> (cmod BC)\<^sup>2\<close>
	+ by auto
	+ thus ?thesis
	+ using \<open>A \<noteq> 0\<close> \<open>r2 = ((cmod BC)\<^sup>2 - A*D) / A\<^sup>2\<close>
	+ by (metis zero_le_divide_iff zero_le_power2)
	+ qed
	+ hence *: "r r = r2" "r \<ge> 0"
	+ using \<open>r = sqrt r2\<close>
	+ by (auto simp add: real_sqrt_mult[symmetric])
	+
	+ have **: "- \<mu> - cnj \<mu> - cor r2 = cor (D / A)"
	+ using \<open>\<mu> = - BC / complex_of_real A\<close> \<open>r2 = ((cmod BC)\<^sup>2 - A * D) / A\<^sup>2\<close>
	+ by (auto simp add: power2_eq_square complex_mult_cnj_cmod field_simps)
	+ (simp add: add_divide_eq_iff assms(1))
	+ thus ?thesis
	+ using \<open>r2 = ((cmod BC)\<^sup>2 - A*D) / A\<^sup>2\<close> \<open>\<mu> = - BC / cor A\<close>
	+ by (subst , subst circle_equation[of r \<mu>, OF \<open>r \<ge> 0\<close>], subst *) (auto simp add: field_simps power2_eq_square)
	+qed
	+
	+lemma circline_ex_circle:
	+ assumes "A \<noteq> 0" and "A * D \<le> (cmod BC)\<^sup>2" and "cl = circline A BC D"
	+ shows "\<exists> \<mu> r. cl = circle \<mu> r"
	+ using circline_circle[OF assms]
	+ by auto
	+
	+text \<open>Every Euclidean circle can be represented by a circline\<close>
	+
	+lemma circle_circline:
	+ assumes "cl = circle \<mu> r" and "r \<ge> 0"
	+ shows "cl = circline 1 (-\<mu>) ((cmod \<mu>)\<^sup>2 - r\<^sup>2)"
	+proof-
	+ have "complex_of_real ((cmod \<mu>)\<^sup>2 - r\<^sup>2) = \<mu> * cnj \<mu> - complex_of_real (r\<^sup>2)"
	+ by (auto simp add: complex_mult_cnj_cmod)
	+ thus "cl = circline 1 (- \<mu>) ((cmod \<mu>)\<^sup>2 - r\<^sup>2)"
	+ using assms
	+ using circle_equation[of r \<mu>]
	+ unfolding circline_def power2_eq_square
	+ by (simp add: field_simps)
	+qed
	+
	+lemma circle_ex_circline:
	+ assumes "cl = circle \<mu> r" and "r \<ge> 0"
	+ shows "\<exists> A BC D. A \<noteq> 0 \<and> A*D \<le> (cmod BC)\<^sup>2 \<and> cl = circline A BC D"
	+ using circle_circline[OF assms]
	+ using \<open>r \<ge> 0\<close>
	+ by (rule_tac x=1 in exI, rule_tac x="-\<mu>" in exI, rule_tac x="Re (\<mu> * cnj \<mu>) - (r * r)" in exI) (simp add: complex_mult_cnj_cmod power2_eq_square)
	+
	+text \<open>Connection between circline and Euclidean line\<close>
	+
	+text \<open>Every circline with a positive determinant and $A = 0$ represents an Euclidean line\<close>
	+
	+lemma circline_line:
	+ assumes
	+ "A = 0" and "BC \<noteq> 0" and
	+ "cl = circline A BC D" and
	+ "z1 = - cor D * BC / (2 * BC * cnj BC)" and
	+ "z2 = z1 + \<i> * sgn (if arg BC > 0 then -BC else BC)"
	+ shows
	+ "cl = line z1 z2"
	+proof-
	+ have "cl = {z. cnj BCz + BCcnj z + complex_of_real D = 0}"
	+ using assms
	+ by (simp add: circline_def)
	+ have "{z. cnj BCz + BCcnj z + complex_of_real D = 0} =
	+ {z. cnj BCz + BCcnj z - (cnj BCz1 + BCcnj z1) = 0}"
	+ using \<open>BC \<noteq> 0\<close> assms
	+ by simp
	+ moreover
	+ have "z1 \<noteq> z2"
	+ using \<open>BC \<noteq> 0\<close> assms
	+ by (auto simp add: sgn_eq)
	+ moreover
	+ have "\<exists> k. k \<noteq> 0 \<and> BC = cor k*rot90 (z2 - z1)"
	+ proof (cases "arg BC > 0")
	+ case True
	+ thus ?thesis
	+ using assms
	+ by (rule_tac x="(cmod BC)" in exI, auto simp add: Complex_scale4)
	+ next
	+ case False
	+ thus ?thesis
	+ using assms
	+ by (rule_tac x="-(cmod BC)" in exI, simp)
	+ (smt Complex.Re_sgn Im_sgn cis_arg complex_minus complex_surj mult_minus_right rcis_cmod_arg rcis_def)
	+ qed
	+ then obtain k where "cor k \<noteq> 0" "BC = cor k*rot90 (z2 - z1)"
	+ by auto
	+ moreover
	+ have : "\<And> z. cnj_mix (BC / cor k) z - cnj_mix (BC / cor k) z1 = (1/cor k) (cnj_mix BC z - cnj_mix BC z1)"
	+ using \<open>cor k \<noteq> 0\<close>
	+ by (simp add: field_simps)
	+ hence "{z. cnj_mix BC z - cnj_mix BC z1 = 0} = {z. cnj_mix (BC / cor k) z - cnj_mix (BC / cor k) z1 = 0}"
	+ using \<open>cor k \<noteq> 0\<close>
	+ by auto
	+ ultimately
	+ have "cl = line z1 z2"
	+ using line_equation[of z1 z2 "BC/cor k"] \<open>cl = {z. cnj BCz + BCcnj z + complex_of_real D = 0}\<close>
	+ by auto
	+ thus ?thesis
	+ using \<open>z1 \<noteq> z2\<close>
	+ by blast
	+qed
	+
	+lemma circline_ex_line:
	+ assumes "A = 0" and "BC \<noteq> 0" and "cl = circline A BC D"
	+ shows "\<exists> z1 z2. z1 \<noteq> z2 \<and> cl = line z1 z2"
	+proof-
	+ let ?z1 = "- cor D * BC / (2 * BC * cnj BC)"
	+ let ?z2 = "?z1 + \<i> * sgn (if 0 < arg BC then - BC else BC)"
	+ have "?z1 \<noteq> ?z2"
	+ using \<open>BC \<noteq> 0\<close>
	+ by (simp add: sgn_eq)
	+ thus ?thesis
	+ using circline_line[OF assms, of ?z1 ?z2] \<open>BC \<noteq> 0\<close>
	+ by (rule_tac x="?z1" in exI, rule_tac x="?z2" in exI, simp)
	+qed
	+
	+text \<open>Every Euclidean line can be represented by a circline\<close>
	+
	+lemma line_ex_circline:
	+ assumes "cl = line z1 z2" and "z1 \<noteq> z2"
	+ shows "\<exists> BC D. BC \<noteq> 0 \<and> cl = circline 0 BC D"
	+proof-
	+ let ?BC = "rot90 (z2 - z1)"
	+ let ?D = "Re (- 2 * scalprod z1 ?BC)"
	+ show ?thesis
	+ proof (rule_tac x="?BC" in exI, rule_tac x="?D" in exI, rule conjI)
	+ show "?BC \<noteq> 0"
	+ using \<open>z1 \<noteq> z2\<close> rot90_ii[of "z2 - z1"]
	+ by auto
	+ next
	+ have : "complex_of_real (Re (- 2 scalprod z1 (rot90 (z2 - z1)))) = - (cnj_mix z1 (rot90 (z2 - z1)))"
	+ using rot90_ii[of "z2 - z1"]
	+ by (cases z1, cases z2, simp add: Complex_eq field_simps)
	+ show "cl = circline 0 ?BC ?D"
	+ apply (subst assms, subst line_equation[of z1 z2 ?BC])
	+ unfolding circline_def
	+ by (fact, simp, subst *, simp add: field_simps)
	+ qed
	+qed
	+
	+lemma circline_line':
	+ assumes "z1 \<noteq> z2"
	+ shows "circline 0 (\<i> * (z2 - z1)) (Re (- cnj_mix (\<i> * (z2 - z1)) z1)) = line z1 z2"
	+proof-
	+ let ?B = "\<i> * (z2 - z1)"
	+ let ?D = "Re (- cnj_mix ?B z1)"
	+ have "circline 0 ?B ?D = {z. cnj ?Bz + ?Bcnj z + complex_of_real ?D = 0}"
	+ using assms
	+ by (simp add: circline_def)
	+ moreover
	+ have "is_real (- cnj_mix (\<i> * (z2 - z1)) z1)"
	+ using cnj_mix_real[of ?B z1]
	+ by auto
	+ hence "{z. cnj ?Bz + ?Bcnj z + complex_of_real ?D = 0} =
	+ {z. cnj ?Bz + ?Bcnj z - (cnj ?Bz1 + ?Bcnj z1) = 0}"
	+ apply (subst complex_of_real_Re, simp)
	+ unfolding diff_conv_add_uminus
	+ by simp
	+ moreover
	+ have "line z1 z2 = {z. cnj_mix (\<i> * (z2 - z1)) z - cnj_mix (\<i> * (z2 - z1)) z1 = 0}"
	+ using line_equation[of z1 z2 ?B] assms
	+ unfolding rot90_ii
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by simp
	+qed
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Angle between two circles\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Given a center $\mu$ of an Euclidean circle and a point $E$ on it, we define the tangent vector
	+in $E$ as the radius vector $\overrightarrow{\mu E}$, rotated by $\pi/2$, clockwise or
	+counterclockwise, depending on the circle orientation. The Boolean @{term p} encodes the orientation
	+of the circle, and the function @{term "sgn_bool p"} returns $1$ when @{term p} is true, and
	+$-1$ when @{term p} is false.\<close>
	+
	+abbreviation sgn_bool where
	+ "sgn_bool p \<equiv> if p then 1 else -1"
	+
	+definition circ_tang_vec :: "complex \<Rightarrow> complex \<Rightarrow> bool \<Rightarrow> complex" where
	+ "circ_tang_vec \<mu> E p = sgn_bool p * \<i> * (E - \<mu>)"
	+
	+text \<open>Tangent vector is orthogonal to the radius.\<close>
	+lemma circ_tang_vec_ortho:
	+ shows "scalprod (E - \<mu>) (circ_tang_vec \<mu> E p) = 0"
	+ unfolding circ_tang_vec_def Let_def
	+ by auto
	+
	+text \<open>Changing the circle orientation gives the opposite tangent vector.\<close>
	+lemma circ_tang_vec_opposite_orient:
	+ shows "circ_tang_vec \<mu> E p = - circ_tang_vec \<mu> E (\<not> p)"
	+ unfolding circ_tang_vec_def
	+ by auto
	+
	+text \<open>Angle between two oriented circles at their common point $E$ is defined as the angle between
	+tangent vectors at $E$. Again we define three different angle measures.\<close>
	+
	+text \<open>The oriented angle between two circles at the point $E$. The first circle is
	+centered at $\mu_1$ and its orientation is given by the Boolean $p_1$,
	+while the second circle is centered at $\mu_2$ and its orientation is given by
	+the Boolea $p_2$.\<close>
	+definition ang_circ where
	+ "ang_circ E \<mu>1 \<mu>2 p1 p2 = \<angle> (circ_tang_vec \<mu>1 E p1) (circ_tang_vec \<mu>2 E p2)"
	+
	+text \<open>The unoriented angle between the two circles\<close>
	+definition ang_circ_c where
	+ "ang_circ_c E \<mu>1 \<mu>2 p1 p2 = \<angle>c (circ_tang_vec \<mu>1 E p1) (circ_tang_vec \<mu>2 E p2)"
	+
	+text \<open>The acute angle between the two circles\<close>
	+definition ang_circ_a where
	+ "ang_circ_a E \<mu>1 \<mu>2 p1 p2 = \<angle>a (circ_tang_vec \<mu>1 E p1) (circ_tang_vec \<mu>2 E p2)"
	+
	+text \<open>Explicit expression for oriented angle between two circles\<close>
	+lemma ang_circ_simp:
	+ assumes "E \<noteq> \<mu>1" and "E \<noteq> \<mu>2"
	+ shows "ang_circ E \<mu>1 \<mu>2 p1 p2 =
	+ \<downharpoonright>arg (E - \<mu>2) - arg (E - \<mu>1) + sgn_bool p1 * pi / 2 - sgn_bool p2 * pi / 2\<downharpoonleft>"
	+ unfolding ang_circ_def ang_vec_def circ_tang_vec_def
	+ apply (rule canon_ang_eq)
	+ using assms
	+ using arg_mult_2kpi[of "sgn_bool p2*\<i>" "E - \<mu>2"]
	+ using arg_mult_2kpi[of "sgn_bool p1*\<i>" "E - \<mu>1"]
	+ apply auto
	+ apply (rule_tac x="x-xa" in exI, auto simp add: field_simps)
	+ apply (rule_tac x="-1+x-xa" in exI, auto simp add: field_simps)
	+ apply (rule_tac x="1+x-xa" in exI, auto simp add: field_simps)
	+ apply (rule_tac x="x-xa" in exI, auto simp add: field_simps)
	+ done
	+
	+text \<open>Explicit expression for the cosine of angle between two circles\<close>
	+lemma cos_ang_circ_simp:
	+ assumes "E \<noteq> \<mu>1" and "E \<noteq> \<mu>2"
	+ shows "cos (ang_circ E \<mu>1 \<mu>2 p1 p2) =
	+ sgn_bool (p1 = p2) * cos (arg (E - \<mu>2) - arg (E - \<mu>1))"
	+ using assms
	+ using cos_periodic_pi2[of "arg (E - \<mu>2) - arg (E - \<mu>1)"]
	+ using cos_minus_pi[of "arg (E - \<mu>2) - arg (E - \<mu>1)"]
	+ using ang_circ_simp[OF assms, of p1 p2]
	+ by auto
	+
	+text \<open>Explicit expression for the unoriented angle between two circles\<close>
	+lemma ang_circ_c_simp:
	+ assumes "E \<noteq> \<mu>1" and "E \<noteq> \<mu>2"
	+ shows "ang_circ_c E \<mu>1 \<mu>2 p1 p2 =
	+ \<bar>\<downharpoonright>arg (E - \<mu>2) - arg (E - \<mu>1) + sgn_bool p1 * pi / 2 - sgn_bool p2 * pi / 2\<downharpoonleft>\<bar>"
	+ unfolding ang_circ_c_def ang_vec_c_def
	+ using ang_circ_simp[OF assms]
	+ unfolding ang_circ_def
	+ by auto
	+
	+text \<open>Explicit expression for the acute angle between two circles\<close>
	+lemma ang_circ_a_simp:
	+ assumes "E \<noteq> \<mu>1" and "E \<noteq> \<mu>2"
	+ shows "ang_circ_a E \<mu>1 \<mu>2 p1 p2 =
	+ acute_ang (abs (canon_ang (arg(E - \<mu>2) - arg(E - \<mu>1) + (sgn_bool p1) * pi/2 - (sgn_bool p2) * pi/2)))"
	+ unfolding ang_circ_a_def ang_vec_a_def
	+ using ang_circ_c_simp[OF assms]
	+ unfolding ang_circ_c_def
	+ by auto
	+
	+text \<open>Acute angle between two circles does not depend on the circle orientation.\<close>
	+lemma ang_circ_a_pTrue:
	+ assumes "E \<noteq> \<mu>1" and "E \<noteq> \<mu>2"
	+ shows "ang_circ_a E \<mu>1 \<mu>2 p1 p2 = ang_circ_a E \<mu>1 \<mu>2 True True"
	+proof (cases "p1")
	+ case True
	+ show ?thesis
	+ proof (cases "p2")
	+ case True
	+ show ?thesis
	+ using \<open>p1\<close> \<open>p2\<close>
	+ by simp
	+ next
	+ case False
	+ show ?thesis
	+ using \<open>p1\<close> \<open>\<not> p2\<close>
	+ unfolding ang_circ_a_def
	+ using circ_tang_vec_opposite_orient[of \<mu>2 E p2]
	+ using ang_vec_a_opposite2
	+ by simp
	+ qed
	+next
	+ case False
	+ show ?thesis
	+ proof (cases "p2")
	+ case True
	+ show ?thesis
	+ using \<open>\<not> p1\<close> \<open>p2\<close>
	+ unfolding ang_circ_a_def
	+ using circ_tang_vec_opposite_orient[of \<mu>1 E p1]
	+ using ang_vec_a_opposite1
	+ by simp
	+ next
	+ case False
	+ show ?thesis
	+ using \<open>\<not> p1\<close> \<open>\<not> p2\<close>
	+ unfolding ang_circ_a_def
	+ using circ_tang_vec_opposite_orient[of \<mu>1 E p1] circ_tang_vec_opposite_orient[of \<mu>2 E p2]
	+ using ang_vec_a_opposite1 ang_vec_a_opposite2
	+ by simp
	+ qed
	+qed
	+
	+text \<open>Definition of the acute angle between the two unoriented circles \<close>
	+abbreviation ang_circ_a' where
	+ "ang_circ_a' E \<mu>1 \<mu>2 \<equiv> ang_circ_a E \<mu>1 \<mu>2 True True"
	+
	+text \<open>A very simple expression for the acute angle between the two circles\<close>
	+lemma ang_circ_a_simp1:
	+ assumes "E \<noteq> \<mu>1" and "E \<noteq> \<mu>2"
	+ shows "ang_circ_a E \<mu>1 \<mu>2 p1 p2 = \<angle>a (E - \<mu>1) (E - \<mu>2)"
	+ unfolding ang_vec_a_def ang_vec_c_def ang_vec_def
	+ by (subst ang_circ_a_pTrue[OF assms, of p1 p2], subst ang_circ_a_simp[OF assms, of True True]) (metis add_diff_cancel)
	+
	+lemma ang_circ_a'_simp:
	+ assumes "E \<noteq> \<mu>1" and "E \<noteq> \<mu>2"
	+ shows "ang_circ_a' E \<mu>1 \<mu>2 = \<angle>a (E - \<mu>1) (E - \<mu>2)"
	+ by (rule ang_circ_a_simp1[OF assms])
	+
	+end
	diff --git a/thys/Complex_Geometry/Hermitean_Matrices.thy b/thys/Complex_Geometry/Hermitean_Matrices.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Hermitean_Matrices.thy
	@@ -0,0 +1,418 @@
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Hermitean matrices\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Hermitean matrices over $\mathbb{C}$ generalize symmetric matrices over $\mathbb{R}$. Quadratic
	+forms with Hermitean matrices represent circles and lines in the extended complex plane (when
	+applied to homogenous coordinates).\<close>
	+
	+theory Hermitean_Matrices
	+imports Unitary_Matrices
	+begin
	+
	+definition hermitean :: "complex_mat \<Rightarrow> bool" where
	+ "hermitean A \<longleftrightarrow> mat_adj A = A"
	+
	+lemma hermitean_transpose:
	+ shows "hermitean A \<longleftrightarrow> mat_transpose A = mat_cnj A"
	+ unfolding hermitean_def
	+ by (cases A) (auto simp add: mat_adj_def mat_cnj_def)
	+
	+text \<open>Characterization of 2x2 Hermitean matrices elements.
	+All 2x2 Hermitean matrices are of the form
	+$$
	+\left(
	+\begin{array}{cc}
	+A & B\\
	+\overline{B} & D
	+\end{array}
	+\right),
	+$$
	+for real $A$ and $D$ and complex $B$.
	+\<close>
	+
	+lemma hermitean_mk_circline [simp]:
	+ shows "hermitean (cor A, B, cnj B, cor D)"
	+ unfolding hermitean_def mat_adj_def mat_cnj_def
	+ by simp
	+
	+lemma hermitean_mk_circline' [simp]:
	+ assumes "is_real A" and "is_real D"
	+ shows "hermitean (A, B, cnj B, D)"
	+ using assms eq_cnj_iff_real
	+ unfolding hermitean_def mat_adj_def mat_cnj_def
	+ by force
	+
	+lemma hermitean_elems:
	+ assumes "hermitean (A, B, C, D)"
	+ shows "is_real A" and "is_real D" and "B = cnj C" and "cnj B = C"
	+ using assms eq_cnj_iff_real[of A] eq_cnj_iff_real[of D]
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+
	+text \<open>Operations that preserve the Hermitean property\<close>
	+
	+lemma hermitean_mat_cnj:
	+ shows "hermitean H \<longleftrightarrow> hermitean (mat_cnj H)"
	+ by (cases H) (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+
	+lemma hermitean_mult_real:
	+ assumes "hermitean H"
	+ shows "hermitean ((cor k) *\<^sub>s\<^sub>m H)"
	+ using assms
	+ unfolding hermitean_def
	+ by simp
	+
	+lemma hermitean_congruence:
	+ assumes "hermitean H"
	+ shows "hermitean (congruence M H)"
	+ using assms
	+ unfolding hermitean_def
	+ by (auto simp add: mult_mm_assoc)
	+
	+text \<open>Identity matrix is Hermitean\<close>
	+
	+lemma hermitean_eye [simp]:
	+ shows "hermitean eye"
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+
	+lemma hermitean_eye' [simp]:
	+ shows "hermitean (1, 0, 0, 1)"
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+
	+text \<open>Unit circle matrix is Hermitean\<close>
	+
	+lemma hermitean_unit_circle [simp]:
	+ shows "hermitean (1, 0, 0, -1)"
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+
	+text \<open>Hermitean matrices have real determinant\<close>
	+lemma mat_det_hermitean_real:
	+ assumes "hermitean A"
	+ shows "is_real (mat_det A)"
	+ using assms
	+ unfolding hermitean_def
	+ by (metis eq_cnj_iff_real mat_det_adj)
	+
	+text \<open>Zero matrix is the only Hermitean matrix with both determinant and trace equal
	+to zero\<close>
	+lemma hermitean_det_zero_trace_zero:
	+ assumes "mat_det A = 0" and "mat_trace A = (0::complex)" and "hermitean A"
	+ shows "A = mat_zero"
	+using assms
	+proof-
	+ {
	+ fix a d c
	+ assume "a * d = cnj c * c" "a + d = 0" "cnj a = a"
	+ from \<open>a + d = 0\<close> have "d = -a"
	+ by (metis add_eq_0_iff)
	+ hence "- (cor (Re a))\<^sup>2 = (cor (cmod c))\<^sup>2"
	+ using \<open>cnj a = a\<close> eq_cnj_iff_real[of a]
	+ using \<open>ad = cnj c c\<close>
	+ using complex_mult_cnj_cmod[of "cnj c"]
	+ by (simp add: power2_eq_square)
	+ hence "- (Re a)\<^sup>2 \<ge> 0"
	+ using zero_le_power2[of "cmod c"]
	+ by (metis Re_complex_of_real cor_squared of_real_minus)
	+ hence "a = 0"
	+ using zero_le_power2[of "Re a"]
	+ using \<open>cnj a = a\<close> eq_cnj_iff_real[of a]
	+ by (simp add: complex_eq_if_Re_eq)
	+ } note * = this
	+ obtain a b c d where "A = (a, b, c, d)"
	+ by (cases A) auto
	+ thus ?thesis
	+ using [of a d c] [of d a c]
	+ using assms \<open>A = (a, b, c, d)\<close>
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+qed
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Bilinear and quadratic forms with Hermitean matrices\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>A Hermitean matrix $(A, B, \overline{B}, D)$, for real $A$ and $D$, gives rise to bilinear form
	+$A\cdot \overline{v_{11}} \cdot v_{21}+\overline{B} \cdot \overline{v_{12}} \cdot v_{21} +
	+B \cdot \overline{v_{11}} \cdot v_{22}+D\cdot \overline{v_{12}}\cdot v_{22}$ (acting on vectors $(v_{11}, v_{12})$ and
	+$(v_{21}, v_{22})$) and to the quadratic form $A \cdot \overline{v_1} \cdot v_1+\overline{B}\cdot \overline{v_2}\cdot v_1 +
	+B\cdot \overline{v_1}\cdot v_2 + D\cdot \overline{v_2} \cdot v_2$ (acting on the vector $(v_1, v_2)$).\<close>
	+
	+lemma bilinear_form_hermitean_commute:
	+ assumes "hermitean H"
	+ shows "bilinear_form v1 v2 H = cnj (bilinear_form v2 v1 H)"
	+proof-
	+ have "v2 \<^sub>v\<^sub>m mat_cnj H \<^sub>v\<^sub>v vec_cnj v1 = vec_cnj v1 \<^sub>v\<^sub>v (mat_adj H \<^sub>m\<^sub>v v2)"
	+ by (subst mult_vv_commute, subst mult_mv_mult_vm, simp add: mat_adj_def mat_transpose_mat_cnj)
	+ also
	+ have "\<dots> = bilinear_form v1 v2 H"
	+ using assms
	+ by (simp add: mult_vv_mv hermitean_def)
	+ finally
	+ show ?thesis
	+ by (simp add: cnj_mult_vv vec_cnj_mult_vm)
	+qed
	+
	+lemma quad_form_hermitean_real:
	+ assumes "hermitean H"
	+ shows "is_real (quad_form z H)"
	+ using assms
	+ by (subst eq_cnj_iff_real[symmetric]) (simp del: quad_form_def add: hermitean_def)
	+
	+lemma quad_form_vec_cnj_mat_cnj:
	+ assumes "hermitean H"
	+ shows "quad_form (vec_cnj z) (mat_cnj H) = quad_form z H"
	+ using assms
	+ using cnj_mult_vv cnj_quad_form hermitean_def vec_cnj_mult_vm by auto
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Eigenvalues, eigenvectors and diagonalization of Hermitean matrices\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Hermitean matrices have real eigenvalues\<close>
	+lemma hermitean_eigenval_real:
	+ assumes "hermitean H" and "eigenval k H"
	+ shows "is_real k"
	+proof-
	+ from assms obtain v where "v \<noteq> vec_zero" "H \<^sub>m\<^sub>v v = k \<^sub>s\<^sub>v v"
	+ unfolding eigenval_def
	+ by blast
	+ have "k * (v \<^sub>v\<^sub>v vec_cnj v) = (k \<^sub>s\<^sub>v v) *\<^sub>v\<^sub>v (vec_cnj v)"
	+ by (simp add: mult_vv_scale_sv1)
	+ also have "... = (H \<^sub>m\<^sub>v v) \<^sub>v\<^sub>v (vec_cnj v)"
	+ using \<open>H \<^sub>m\<^sub>v v = k \<^sub>s\<^sub>v v\<close>
	+ by simp
	+ also have "... = v \<^sub>v\<^sub>v (mat_transpose H \<^sub>m\<^sub>v (vec_cnj v))"
	+ by (simp add: mult_mv_vv)
	+ also have "... = v \<^sub>v\<^sub>v (vec_cnj (mat_cnj (mat_transpose H) \<^sub>m\<^sub>v v))"
	+ by (simp add: vec_cnj_mult_mv)
	+ also have "... = v \<^sub>v\<^sub>v (vec_cnj (H \<^sub>m\<^sub>v v))"
	+ using \<open>hermitean H\<close>
	+ by (simp add: hermitean_def mat_adj_def)
	+ also have "... = v \<^sub>v\<^sub>v (vec_cnj (k \<^sub>s\<^sub>v v))"
	+ using \<open>H \<^sub>m\<^sub>v v = k \<^sub>s\<^sub>v v\<close>
	+ by simp
	+ finally have "k * (v \<^sub>v\<^sub>v vec_cnj v) = cnj k (v *\<^sub>v\<^sub>v vec_cnj v)"
	+ by (simp add: mult_vv_scale_sv2)
	+ hence "k = cnj k"
	+ using \<open>v \<noteq> vec_zero\<close>
	+ using scalsquare_vv_zero[of v]
	+ by (simp add: mult_vv_commute)
	+ thus ?thesis
	+ by (metis eq_cnj_iff_real)
	+qed
	+
	+text \<open>Non-diagonal Hermitean matrices have distinct eigenvalues\<close>
	+lemma hermitean_distinct_eigenvals:
	+ assumes "hermitean H"
	+ shows "(\<exists> k\<^sub>1 k\<^sub>2. k\<^sub>1 \<noteq> k\<^sub>2 \<and> eigenval k\<^sub>1 H \<and> eigenval k\<^sub>2 H) \<or> mat_diagonal H"
	+proof-
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ show ?thesis
	+ proof (cases "B = 0")
	+ case True
	+ thus ?thesis
	+ using \<open>hermitean H\<close> hermitean_elems[of A B C D] HH
	+ by auto
	+ next
	+ case False
	+ have "(mat_trace H)\<^sup>2 \<noteq> 4 * mat_det H"
	+ proof (rule ccontr)
	+ have "C = cnj B" "is_real A" "is_real D"
	+ using hermitean_elems HH \<open>hermitean H\<close>
	+ by auto
	+ assume "\<not> ?thesis"
	+ hence "(A + D)\<^sup>2 = 4(AD - B*C)"
	+ using HH
	+ by auto
	+ hence "(A - D)\<^sup>2 = - 4Bcnj B"
	+ using \<open>C = cnj B\<close>
	+ by (auto simp add: power2_eq_square field_simps)
	+ hence "(A - D)\<^sup>2 / cor ((cmod B)\<^sup>2) = -4"
	+ using \<open>B \<noteq> 0\<close> complex_mult_cnj_cmod[of B]
	+ by (auto simp add: field_simps)
	+ hence "(Re A - Re D)\<^sup>2 / (cmod B)\<^sup>2 = -4"
	+ using \<open>is_real A\<close> \<open>is_real D\<close> \<open>B \<noteq> 0\<close>
	+ using Re_divide_real[of "cor ((cmod B)\<^sup>2)" "(A - D)\<^sup>2"]
	+ by (auto simp add: power2_eq_square)
	+ thus False
	+ by (metis abs_neg_numeral abs_power2 neg_numeral_neq_numeral power_divide)
	+ qed
	+ show ?thesis
	+ apply (rule disjI1)
	+ apply (subst eigen_equation)+
	+ using complex_quadratic_equation_monic_distinct_roots[of "-mat_trace H" "mat_det H"] \<open>(mat_trace H)\<^sup>2 \<noteq> 4 * mat_det H\<close>
	+ by auto
	+ qed
	+qed
	+
	+text \<open>Eigenvectors corresponding to different eigenvalues of Hermitean matrices are
	+orthogonal\<close>
	+lemma hermitean_ortho_eigenvecs:
	+ assumes "hermitean H"
	+ assumes "eigenpair k1 v1 H" and "eigenpair k2 v2 H" and "k1 \<noteq> k2"
	+ shows "vec_cnj v2 \<^sub>v\<^sub>v v1 = 0" and "vec_cnj v1 \<^sub>v\<^sub>v v2 = 0"
	+proof-
	+ from assms
	+ have "v1 \<noteq> vec_zero" "H \<^sub>m\<^sub>v v1 = k1 \<^sub>s\<^sub>v v1"
	+ "v2 \<noteq> vec_zero" "H \<^sub>m\<^sub>v v2 = k2 \<^sub>s\<^sub>v v2"
	+ unfolding eigenpair_def
	+ by auto
	+ have real_k: "is_real k1" "is_real k2"
	+ using assms
	+ using hermitean_eigenval_real[of H k1]
	+ using hermitean_eigenval_real[of H k2]
	+ unfolding eigenpair_def eigenval_def
	+ by blast+
	+
	+ have "vec_cnj (H \<^sub>m\<^sub>v v2) = vec_cnj (k2 \<^sub>s\<^sub>v v2)"
	+ using \<open>H \<^sub>m\<^sub>v v2 = k2 \<^sub>s\<^sub>v v2\<close>
	+ by auto
	+ hence "vec_cnj v2 \<^sub>v\<^sub>m H = k2 \<^sub>s\<^sub>v vec_cnj v2"
	+ using \<open>hermitean H\<close> real_k eq_cnj_iff_real[of k1] eq_cnj_iff_real[of k2]
	+ unfolding hermitean_def
	+ by (cases H, cases v2) (auto simp add: mat_adj_def mat_cnj_def vec_cnj_def)
	+ have "k2 * (vec_cnj v2 \<^sub>v\<^sub>v v1) = k1 (vec_cnj v2 *\<^sub>v\<^sub>v v1)"
	+ using \<open>H \<^sub>m\<^sub>v v1 = k1 \<^sub>s\<^sub>v v1\<close>
	+ using \<open>vec_cnj v2 \<^sub>v\<^sub>m H = k2 \<^sub>s\<^sub>v vec_cnj v2\<close>
	+ by (cases v1, cases v2, cases H)
	+ (metis mult_vv_mv mult_vv_scale_sv1 mult_vv_scale_sv2)
	+ thus "vec_cnj v2 *\<^sub>v\<^sub>v v1 = 0"
	+ using \<open>k1 \<noteq> k2\<close>
	+ by simp
	+ hence "cnj (vec_cnj v2 *\<^sub>v\<^sub>v v1) = 0"
	+ by simp
	+ thus "vec_cnj v1 *\<^sub>v\<^sub>v v2 = 0"
	+ by (simp add: cnj_mult_vv mult_vv_commute)
	+qed
	+
	+text \<open>Hermitean matrices are diagonizable by unitary matrices. Diagonal entries are
	+real and the sign of the determinant is preserved.\<close>
	+lemma hermitean_diagonizable:
	+ assumes "hermitean H"
	+ shows "\<exists> k1 k2 M. mat_det M \<noteq> 0 \<and> unitary M \<and> congruence M H = (k1, 0, 0, k2) \<and>
	+ is_real k1 \<and> is_real k2 \<and> sgn (Re k1 * Re k2) = sgn (Re (mat_det H))"
	+proof-
	+ from assms
	+ have "(\<exists>k\<^sub>1 k\<^sub>2. k\<^sub>1 \<noteq> k\<^sub>2 \<and> eigenval k\<^sub>1 H \<and> eigenval k\<^sub>2 H) \<or> mat_diagonal H"
	+ using hermitean_distinct_eigenvals[of H]
	+ by simp
	+ thus ?thesis
	+ proof
	+ assume "\<exists>k\<^sub>1 k\<^sub>2. k\<^sub>1 \<noteq> k\<^sub>2 \<and> eigenval k\<^sub>1 H \<and> eigenval k\<^sub>2 H"
	+ then obtain k1 k2 where "k1 \<noteq> k2" "eigenval k1 H" "eigenval k2 H"
	+ using hermitean_distinct_eigenvals
	+ by blast
	+ then obtain v1 v2 where "eigenpair k1 v1 H" "eigenpair k2 v2 H"
	+ "v1 \<noteq> vec_zero" "v2 \<noteq> vec_zero"
	+ unfolding eigenval_def eigenpair_def
	+ by blast
	+ hence : "vec_cnj v2 \<^sub>v\<^sub>v v1 = 0" "vec_cnj v1 *\<^sub>v\<^sub>v v2 = 0"
	+ using \<open>k1 \<noteq> k2\<close> hermitean_ortho_eigenvecs \<open>hermitean H\<close>
	+ by auto
	+ obtain v11 v12 v21 v22 where vv: "v1 = (v11, v12)" "v2 = (v21, v22)"
	+ by (cases v1, cases v2) auto
	+ let ?nv1' = "vec_cnj v1 \<^sub>v\<^sub>v v1" and ?nv2' = "vec_cnj v2 \<^sub>v\<^sub>v v2"
	+ let ?nv1 = "cor (sqrt (Re ?nv1'))"
	+ let ?nv2 = "cor (sqrt (Re ?nv2'))"
	+ have "?nv1' \<noteq> 0" "?nv2' \<noteq> 0"
	+ using \<open>v1 \<noteq> vec_zero\<close> \<open>v2 \<noteq> vec_zero\<close> vv
	+ by (simp add: scalsquare_vv_zero)+
	+ moreover
	+ have "is_real ?nv1'" "is_real ?nv2'"
	+ using vv
	+ by (auto simp add: vec_cnj_def)
	+ ultimately
	+ have "?nv1 \<noteq> 0" "?nv2 \<noteq> 0"
	+ using complex_eq_if_Re_eq
	+ by auto
	+ have "Re (?nv1') \<ge> 0" "Re (?nv2') \<ge> 0"
	+ using vv
	+ by (auto simp add: vec_cnj_def)
	+ obtain nv1 nv2 where "nv1 = ?nv1" "nv1 \<noteq> 0" "nv2 = ?nv2" "nv2 \<noteq> 0"
	+ using \<open>?nv1 \<noteq> 0\<close> \<open>?nv2 \<noteq> 0\<close>
	+ by auto
	+ let ?M = "(1/nv1 * v11, 1/nv2 * v21, 1/nv1 * v12, 1/nv2 * v22)"
	+
	+ have "is_real k1" "is_real k2"
	+ using \<open>eigenval k1 H\<close> \<open>eigenval k2 H\<close> \<open>hermitean H\<close>
	+ by (auto simp add: hermitean_eigenval_real)
	+ moreover
	+ have "mat_det ?M \<noteq> 0"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "v11 * v22 = v12 * v21"
	+ using \<open>nv1 \<noteq> 0\<close> \<open>nv2 \<noteq> 0\<close>
	+ by (auto simp add: field_simps)
	+ hence "\<exists> k. k \<noteq> 0 \<and> v2 = k *\<^sub>s\<^sub>v v1"
	+ using vv \<open>v1 \<noteq> vec_zero\<close> \<open>v2 \<noteq> vec_zero\<close>
	+ apply auto
	+ apply (rule_tac x="v21/v11" in exI, force simp add: field_simps)
	+ apply (rule_tac x="v21/v11" in exI, force simp add: field_simps)
	+ apply (rule_tac x="v22/v12" in exI, force simp add: field_simps)
	+ apply (rule_tac x="v22/v12" in exI, force simp add: field_simps)
	+ done
	+ thus False
	+ using * \<open>vec_cnj v1 \<^sub>v\<^sub>v v2 = 0\<close> \<open>vec_cnj v2 \<^sub>v\<^sub>v v2 \<noteq> 0\<close> vv \<open>?nv1' \<noteq> 0\<close>
	+ by (metis mult_vv_scale_sv2 mult_zero_right)
	+ qed
	+ moreover
	+ have "unitary ?M"
	+ proof-
	+ have *: "cnj nv1 nv1 = ?nv1'" "cnj nv2 * nv2 = ?nv2'"
	+ using \<open>nv1 = ?nv1\<close> \<open>nv1 \<noteq> 0\<close> \<open>nv2 = ?nv2\<close> \<open>nv2 \<noteq> 0\<close> \<open>is_real ?nv1'\<close> \<open>is_real ?nv2'\<close>
	+ using \<open>Re (?nv1') \<ge> 0\<close> \<open>Re (?nv2') \<ge> 0\<close>
	+ by auto
	+ have **: "cnj nv1 nv2 \<noteq> 0" "cnj nv2 * nv1 \<noteq> 0"
	+ using vv \<open>nv1 = ?nv1\<close> \<open>nv1 \<noteq> 0\<close> \<open>nv2 = ?nv2\<close> \<open>nv2 \<noteq> 0\<close> \<open>is_real ?nv1'\<close> \<open>is_real ?nv2'\<close>
	+ by auto
	+
	+ show ?thesis
	+ unfolding unitary_def
	+ using vv ** \<open>?nv1' \<noteq> 0\<close> \<open>?nv2' \<noteq> 0\<close> * ***
	+ unfolding mat_adj_def mat_cnj_def vec_cnj_def
	+ by simp (metis (no_types, lifting) add_divide_distrib divide_eq_0_iff divide_eq_1_iff)
	+ qed
	+ moreover
	+ have "congruence ?M H = (k1, 0, 0, k2)"
	+ proof-
	+ have "mat_inv ?M \<^sub>m\<^sub>m H \<^sub>m\<^sub>m ?M = (k1, 0, 0, k2)"
	+ proof-
	+ have : "H \<^sub>m\<^sub>m ?M = ?M *\<^sub>m\<^sub>m (k1, 0, 0, k2)"
	+ using \<open>eigenpair k1 v1 H\<close> \<open>eigenpair k2 v2 H\<close> vv \<open>?nv1 \<noteq> 0\<close> \<open>?nv2 \<noteq> 0\<close>
	+ unfolding eigenpair_def vec_cnj_def
	+ by (cases H) (smt mult_mm.simps vec_map.simps add.right_neutral add_cancel_left_left distrib_left fst_mult_sv mult.commute mult.left_commute mult_mv.simps mult_zero_right prod.sel(1) prod.sel(2) snd_mult_sv)
	+ show ?thesis
	+ using mult_mm_inv_l[of ?M "(k1, 0, 0, k2)" "H \<^sub>m\<^sub>m ?M", OF \<open>mat_det ?M \<noteq> 0\<close> [symmetric], symmetric]
	+ by (simp add: mult_mm_assoc)
	+ qed
	+ moreover
	+ have "mat_inv ?M = mat_adj ?M"
	+ using \<open>mat_det ?M \<noteq> 0\<close> \<open>unitary ?M\<close> mult_mm_inv_r[of ?M "mat_adj ?M" eye]
	+ by (simp add: unitary_def)
	+ ultimately
	+ show ?thesis
	+ by simp
	+ qed
	+ moreover
	+ have "sgn (Re k1 * Re k2) = sgn (Re (mat_det H))"
	+ using \<open>congruence ?M H = (k1, 0, 0, k2)\<close> \<open>is_real k1\<close> \<open>is_real k2\<close>
	+ using Re_det_sgn_congruence[of ?M H] \<open>mat_det ?M \<noteq> 0\<close> \<open>hermitean H\<close>
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by (rule_tac x="k1" in exI, rule_tac x="k2" in exI, rule_tac x="?M" in exI) simp
	+ next
	+ assume "mat_diagonal H"
	+ then obtain A D where "H = (A, 0, 0, D)"
	+ by (cases H) auto
	+ moreover
	+ hence "is_real A" "is_real D"
	+ using \<open>hermitean H\<close> hermitean_elems[of A 0 0 D]
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by (rule_tac x="A" in exI, rule_tac x="D" in exI, rule_tac x="eye" in exI) (simp add: unitary_def mat_adj_def mat_cnj_def)
	+ qed
	+qed
	+
	+end
	diff --git a/thys/Complex_Geometry/Homogeneous_Coordinates.thy b/thys/Complex_Geometry/Homogeneous_Coordinates.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Homogeneous_Coordinates.thy
	@@ -0,0 +1,1358 @@
	+(* ---------------------------------------------------------------------------- *)
	+section \<open>Homogeneous coordinates in extended complex plane\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Extended complex plane $\mathbb{\overline{C}}$ is complex plane with an additional element
	+(treated as the infinite point). The extended complex plane $\mathbb{\overline{C}}$ is identified
	+with a complex projective line (the one-dimensional projective space over the complex field, sometimes denoted by $\mathbb{C}P^1$).
	+Each point of $\mathbb{\overline{C}}$ is represented by a pair of complex homogeneous coordinates (not
	+both equal to zero), and two pairs of homogeneous coordinates represent the same
	+point in $\mathbb{\overline{C}}$ iff they are proportional by a non-zero complex factor.\<close>
	+
	+theory Homogeneous_Coordinates
	+imports More_Complex Matrices
	+begin
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Definition of homogeneous coordinates\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Two complex vectors are equivalent iff they are proportional.\<close>
	+
	+definition complex_cvec_eq :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> bool" (infix "\<approx>\<^sub>v" 50) where
	+ [simp]: "z1 \<approx>\<^sub>v z2 \<longleftrightarrow> (\<exists> k. k \<noteq> (0::complex) \<and> z2 = k *\<^sub>s\<^sub>v z1)"
	+
	+lemma complex_cvec_eq_mix:
	+ assumes "(z1, z2) \<noteq> vec_zero" and "(w1, w2) \<noteq> vec_zero"
	+ shows "(z1, z2) \<approx>\<^sub>v (w1, w2) \<longleftrightarrow> z1w2 = z2w1"
	+proof safe
	+ assume "(z1, z2) \<approx>\<^sub>v (w1, w2)"
	+ thus "z1 * w2 = z2 * w1"
	+ by auto
	+next
	+ assume : "z1 w2 = z2 * w1"
	+ show "(z1, z2) \<approx>\<^sub>v (w1, w2)"
	+ proof (cases "z2 = 0")
	+ case True
	+ thus ?thesis
	+ using * assms
	+ by auto
	+ next
	+ case False
	+ hence "w1 = (w2/z2)z1 \<and> w2 = (w2/z2)z2" "w2/z2 \<noteq> 0"
	+ using * assms
	+ by (auto simp add: field_simps)
	+ thus "(z1, z2) \<approx>\<^sub>v (w1, w2)"
	+ by (metis complex_cvec_eq_def mult_sv.simps)
	+ qed
	+qed
	+
	+lemma complex_eq_cvec_reflp [simp]:
	+ shows "reflp (\<approx>\<^sub>v)"
	+ unfolding reflp_def complex_cvec_eq_def
	+ by safe (rule_tac x="1" in exI, simp)
	+
	+lemma complex_eq_cvec_symp [simp]:
	+ shows "symp (\<approx>\<^sub>v)"
	+ unfolding symp_def complex_cvec_eq_def
	+ by safe (rule_tac x="1/k" in exI, simp)
	+
	+lemma complex_eq_cvec_transp [simp]:
	+ shows "transp (\<approx>\<^sub>v)"
	+ unfolding transp_def complex_cvec_eq_def
	+ by safe (rule_tac x="k*ka" in exI, simp)
	+
	+lemma complex_eq_cvec_equivp [simp]:
	+ shows "equivp (\<approx>\<^sub>v)"
	+ by (auto intro: equivpI)
	+
	+text \<open>Non-zero pairs of complex numbers (also treated as non-zero complex vectors)\<close>
	+
	+typedef complex_homo_coords = "{v::complex_vec. v \<noteq> vec_zero}"
	+ by (rule_tac x="(1, 0)" in exI, simp)
	+
	+setup_lifting type_definition_complex_homo_coords
	+
	+lift_definition complex_homo_coords_eq :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> bool" (infix "\<approx>" 50) is complex_cvec_eq
	+ done
	+
	+lemma complex_homo_coords_eq_reflp [simp]:
	+ shows "reflp (\<approx>)"
	+ using complex_eq_cvec_reflp
	+ unfolding reflp_def
	+ by transfer blast
	+
	+lemma complex_homo_coords_eq_symp [simp]:
	+ shows "symp (\<approx>)"
	+ using complex_eq_cvec_symp
	+ unfolding symp_def
	+ by transfer blast
	+
	+lemma complex_homo_coords_eq_transp [simp]:
	+ shows "transp (\<approx>)"
	+ using complex_eq_cvec_transp
	+ unfolding transp_def
	+ by transfer blast
	+
	+lemma complex_homo_coords_eq_equivp:
	+ shows "equivp (\<approx>)"
	+ by (auto intro: equivpI)
	+
	+lemma complex_homo_coords_eq_refl [simp]:
	+ shows "z \<approx> z"
	+ using complex_homo_coords_eq_reflp
	+ unfolding reflp_def refl_on_def
	+ by blast
	+
	+lemma complex_homo_coords_eq_sym:
	+ assumes "z1 \<approx> z2"
	+ shows "z2 \<approx> z1"
	+ using assms complex_homo_coords_eq_symp
	+ unfolding symp_def
	+ by blast
	+
	+lemma complex_homo_coords_eq_trans:
	+ assumes "z1 \<approx> z2" and "z2 \<approx> z3"
	+ shows "z1 \<approx> z3"
	+ using assms complex_homo_coords_eq_transp
	+ unfolding transp_def
	+ by blast
	+
	+text \<open>Quotient type of homogeneous coordinates\<close>
	+quotient_type
	+ complex_homo = complex_homo_coords / "complex_homo_coords_eq"
	+ by (rule complex_homo_coords_eq_equivp)
	+
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Some characteristic points in $\mathbb{C}P^1$\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Infinite point\<close>
	+definition inf_cvec :: "complex_vec" ("\<infinity>\<^sub>v") where
	+ [simp]: "inf_cvec = (1, 0)"
	+lift_definition inf_hcoords :: "complex_homo_coords" ("\<infinity>\<^sub>h\<^sub>c") is inf_cvec
	+ by simp
	+lift_definition inf :: "complex_homo" ("\<infinity>\<^sub>h") is inf_hcoords
	+done
	+
	+lemma inf_cvec_z2_zero_iff:
	+ assumes "(z1, z2) \<noteq> vec_zero"
	+ shows "(z1, z2) \<approx>\<^sub>v \<infinity>\<^sub>v \<longleftrightarrow> z2 = 0"
	+ using assms
	+ by auto
	+
	+text \<open>Zero\<close>
	+definition zero_cvec :: "complex_vec" ("0\<^sub>v") where
	+ [simp]: "zero_cvec = (0, 1)"
	+lift_definition zero_hcoords :: "complex_homo_coords" ("0\<^sub>h\<^sub>c") is zero_cvec
	+ by simp
	+lift_definition zero :: "complex_homo" ("0\<^sub>h") is zero_hcoords
	+ done
	+
	+lemma zero_cvec_z1_zero_iff:
	+ assumes "(z1, z2) \<noteq> vec_zero"
	+ shows "(z1, z2) \<approx>\<^sub>v 0\<^sub>v \<longleftrightarrow> z1 = 0"
	+ using assms
	+ by auto
	+
	+text \<open>One\<close>
	+definition one_cvec :: "complex_vec" ("1\<^sub>v")where
	+ [simp]: "one_cvec = (1, 1)"
	+lift_definition one_hcoords :: "complex_homo_coords" ("1\<^sub>h\<^sub>c") is one_cvec
	+ by simp
	+lift_definition one :: "complex_homo" ("1\<^sub>h") is one_hcoords
	+ done
	+
	+lemma zero_one_infty_not_equal [simp]:
	+ shows "1\<^sub>h \<noteq> \<infinity>\<^sub>h" and "0\<^sub>h \<noteq> \<infinity>\<^sub>h" and "0\<^sub>h \<noteq> 1\<^sub>h" and "1\<^sub>h \<noteq> 0\<^sub>h" and "\<infinity>\<^sub>h \<noteq> 0\<^sub>h" and "\<infinity>\<^sub>h \<noteq> 1\<^sub>h"
	+ by (transfer, transfer, simp)+
	+
	+text \<open>Imaginary unit\<close>
	+definition ii_cvec :: "complex_vec" ("ii\<^sub>v") where
	+ [simp]: "ii_cvec = (\<i>, 1)"
	+lift_definition ii_hcoords :: "complex_homo_coords" ("ii\<^sub>h\<^sub>c") is ii_cvec
	+ by simp
	+lift_definition ii :: "complex_homo" ("ii\<^sub>h") is ii_hcoords
	+ done
	+
	+lemma ex_3_different_points:
	+ fixes z::complex_homo
	+ shows "\<exists> z1 z2. z \<noteq> z1 \<and> z1 \<noteq> z2 \<and> z \<noteq> z2"
	+proof (cases "z \<noteq> 0\<^sub>h \<and> z \<noteq> 1\<^sub>h")
	+ case True
	+ thus ?thesis
	+ by (rule_tac x="0\<^sub>h" in exI, rule_tac x="1\<^sub>h" in exI, auto)
	+next
	+ case False
	+ hence "z = 0\<^sub>h \<or> z = 1\<^sub>h"
	+ by simp
	+ thus ?thesis
	+ proof
	+ assume "z = 0\<^sub>h"
	+ thus ?thesis
	+ by (rule_tac x="\<infinity>\<^sub>h" in exI, rule_tac x="1\<^sub>h" in exI, auto)
	+ next
	+ assume "z = 1\<^sub>h"
	+ thus ?thesis
	+ by (rule_tac x="\<infinity>\<^sub>h" in exI, rule_tac x="0\<^sub>h" in exI, auto)
	+ qed
	+qed
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Connection to ordinary complex plane $\mathbb{C}$\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Conversion from complex\<close>
	+
	+definition of_complex_cvec :: "complex \<Rightarrow> complex_vec" where
	+ [simp]: "of_complex_cvec z = (z, 1)"
	+lift_definition of_complex_hcoords :: "complex \<Rightarrow> complex_homo_coords" is of_complex_cvec
	+ by simp
	+lift_definition of_complex :: "complex \<Rightarrow> complex_homo" is of_complex_hcoords
	+ done
	+
	+lemma of_complex_inj:
	+ assumes "of_complex x = of_complex y"
	+ shows "x = y"
	+ using assms
	+ by (transfer, transfer, simp)
	+
	+lemma of_complex_image_inj:
	+ assumes "of_complex ` A = of_complex ` B"
	+ shows "A = B"
	+ using assms
	+ using of_complex_inj
	+ by auto
	+
	+lemma of_complex_not_inf [simp]:
	+ shows "of_complex x \<noteq> \<infinity>\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+lemma inf_not_of_complex [simp]:
	+ shows "\<infinity>\<^sub>h \<noteq> of_complex x"
	+ by (transfer, transfer, simp)
	+
	+lemma inf_or_of_complex:
	+ shows "z = \<infinity>\<^sub>h \<or> (\<exists> x. z = of_complex x)"
	+proof (transfer, transfer)
	+ fix z :: complex_vec
	+ obtain z1 z2 where *: "z = (z1, z2)"
	+ by (cases z) auto
	+ assume "z \<noteq> vec_zero"
	+ thus "z \<approx>\<^sub>v \<infinity>\<^sub>v \<or> (\<exists>x. z \<approx>\<^sub>v of_complex_cvec x)"
	+ using *
	+ by (cases "z2 = 0", auto)
	+qed
	+
	+lemma of_complex_zero [simp]:
	+ shows "of_complex 0 = 0\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+lemma of_complex_one [simp]:
	+ shows "of_complex 1 = 1\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+lemma of_complex_ii [simp]:
	+ shows "of_complex \<i> = ii\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+lemma of_complex_zero_iff [simp]:
	+ shows "of_complex x = 0\<^sub>h \<longleftrightarrow> x = 0"
	+ by (subst of_complex_zero[symmetric]) (auto simp add: of_complex_inj)
	+
	+lemma of_complex_one_iff [simp]:
	+ shows "of_complex x = 1\<^sub>h \<longleftrightarrow> x = 1"
	+ by (subst of_complex_one[symmetric]) (auto simp add: of_complex_inj)
	+
	+lemma of_complex_ii_iff [simp]:
	+ shows "of_complex x = ii\<^sub>h \<longleftrightarrow> x = \<i>"
	+ by (subst of_complex_ii[symmetric]) (auto simp add: of_complex_inj)
	+
	+text \<open>Conversion to complex\<close>
	+
	+definition to_complex_cvec :: "complex_vec \<Rightarrow> complex" where
	+ [simp]: "to_complex_cvec z = (let (z1, z2) = z in z1/z2)"
	+lift_definition to_complex_homo_coords :: "complex_homo_coords \<Rightarrow> complex" is to_complex_cvec
	+ done
	+lift_definition to_complex :: "complex_homo \<Rightarrow> complex" is to_complex_homo_coords
	+proof-
	+ fix z w
	+ assume "z \<approx> w"
	+ thus "to_complex_homo_coords z = to_complex_homo_coords w"
	+ by transfer auto
	+qed
	+
	+lemma to_complex_of_complex [simp]:
	+ shows "to_complex (of_complex z) = z"
	+ by (transfer, transfer, simp)
	+
	+lemma of_complex_to_complex [simp]:
	+ assumes "z \<noteq> \<infinity>\<^sub>h"
	+ shows "(of_complex (to_complex z)) = z"
	+ using assms
	+proof (transfer, transfer)
	+ fix z :: complex_vec
	+ obtain z1 z2 where *: "z = (z1, z2)"
	+ by (cases z, auto)
	+ assume "z \<noteq> vec_zero" "\<not> z \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ hence "z2 \<noteq> 0"
	+ using *
	+ by (simp, erule_tac x="1/z1" in allE, auto)
	+ thus "(of_complex_cvec (to_complex_cvec z)) \<approx>\<^sub>v z"
	+ using *
	+ by simp
	+qed
	+
	+lemma to_complex_zero_zero [simp]:
	+ shows "to_complex 0\<^sub>h = 0"
	+ by (metis of_complex_zero to_complex_of_complex)
	+
	+lemma to_complex_one_one [simp]:
	+ shows "to_complex 1\<^sub>h = 1"
	+ by (metis of_complex_one to_complex_of_complex)
	+
	+lemma to_complex_img_one [simp]:
	+ shows "to_complex ii\<^sub>h = \<i>"
	+ by (metis of_complex_ii to_complex_of_complex)
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Arithmetic operations\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Due to the requirement of HOL that all functions are total, we could not define the function
	+only for the well-defined cases, and in the lifting proofs we must also handle the ill-defined
	+cases. For example, $\infty_h +_h \infty_h$ is ill-defined, but we must define it, so we define it
	+arbitrarily to be $\infty_h$.\<close>
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Addition\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>$\infty_h\ +_h\ \infty_h$ is ill-defined. Since functions must be total, for formal reasons we
	+define it arbitrarily to be $\infty_h$.\<close>
	+
	+definition add_cvec :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_vec" (infixl "+\<^sub>v" 60) where
	+ [simp]: "add_cvec z w = (let (z1, z2) = z; (w1, w2) = w
	+ in if z2 \<noteq> 0 \<or> w2 \<noteq> 0 then
	+ (z1w2 + w1z2, z2*w2)
	+ else
	+ (1, 0))"
	+lift_definition add_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords" (infixl "+\<^sub>h\<^sub>c" 60) is add_cvec
	+ by (auto split: if_split_asm)
	+
	+lift_definition add :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" (infixl "+\<^sub>h" 60) is add_hcoords
	+proof transfer
	+ fix z w z' w' :: complex_vec
	+ obtain z1 z2 w1 w2 z'1 z'2 w'1 w'2 where
	+ *: "z = (z1, z2)" "w = (w1, w2)" "z' = (z'1, z'2)" "w' = (w'1, w'2)"
	+ by (cases z, auto, cases w, auto, cases z', auto, cases w', auto)
	+ assume **:
	+ "z \<noteq> vec_zero" "w \<noteq> vec_zero" "z \<approx>\<^sub>v z'"
	+ "z' \<noteq> vec_zero" "w' \<noteq> vec_zero" "w \<approx>\<^sub>v w'"
	+ show "z +\<^sub>v w \<approx>\<^sub>v z' +\<^sub>v w'"
	+ proof (cases "z2 \<noteq> 0 \<or> w2 \<noteq> 0")
	+ case True
	+ hence "z'2 \<noteq> 0 \<or> w'2 \<noteq> 0"
	+ using * **
	+ by auto
	+ show ?thesis
	+ using \<open>z2 \<noteq> 0 \<or> w2 \<noteq> 0\<close> \<open>z'2 \<noteq> 0 \<or> w'2 \<noteq> 0\<close>
	+ using * **
	+ by simp ((erule exE)+, rule_tac x="k*ka" in exI, simp add: field_simps)
	+ next
	+ case False
	+ hence "z'2 = 0 \<or> w'2 = 0"
	+ using * **
	+ by auto
	+ show ?thesis
	+ using \<open>\<not> (z2 \<noteq> 0 \<or> w2 \<noteq> 0)\<close> \<open>z'2 = 0 \<or> w'2 = 0\<close>
	+ using * **
	+ by auto
	+ qed
	+qed
	+
	+lemma add_commute:
	+ shows "z +\<^sub>h w = w +\<^sub>h z"
	+ apply (transfer, transfer)
	+ unfolding complex_cvec_eq_def
	+ by (rule_tac x="1" in exI, auto split: if_split_asm)
	+
	+lemma add_zero_right [simp]:
	+ shows "z +\<^sub>h 0\<^sub>h = z"
	+ by (transfer, transfer, force)
	+
	+lemma add_zero_left [simp]:
	+ shows "0\<^sub>h +\<^sub>h z = z"
	+ by (subst add_commute) simp
	+
	+lemma of_complex_add_of_complex [simp]:
	+ shows "(of_complex x) +\<^sub>h (of_complex y) = of_complex (x + y)"
	+ by (transfer, transfer, simp)
	+
	+lemma of_complex_add_inf [simp]:
	+ shows "(of_complex x) +\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+lemma inf_add_of_complex [simp]:
	+ shows "\<infinity>\<^sub>h +\<^sub>h (of_complex x) = \<infinity>\<^sub>h"
	+ by (subst add_commute) simp
	+
	+lemma inf_add_right:
	+ assumes "z \<noteq> \<infinity>\<^sub>h"
	+ shows "z +\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ using assms
	+ using inf_or_of_complex[of z]
	+ by auto
	+
	+lemma inf_add_left:
	+ assumes "z \<noteq> \<infinity>\<^sub>h"
	+ shows "\<infinity>\<^sub>h +\<^sub>h z = \<infinity>\<^sub>h"
	+ using assms
	+ by (subst add_commute) (rule inf_add_right, simp)
	+
	+text \<open>This is ill-defined, but holds by our definition\<close>
	+lemma inf_add_inf:
	+ shows "\<infinity>\<^sub>h +\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Unary minus\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+definition uminus_cvec :: "complex_vec \<Rightarrow> complex_vec" ("~\<^sub>v") where
	+ [simp]: "~\<^sub>v z = (let (z1, z2) = z in (-z1, z2))"
	+lift_definition uminus_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords" ("~\<^sub>h\<^sub>c") is uminus_cvec
	+ by auto
	+lift_definition uminus :: "complex_homo \<Rightarrow> complex_homo" ("~\<^sub>h") is uminus_hcoords
	+ by transfer auto
	+
	+lemma uminus_of_complex [simp]:
	+ shows "~\<^sub>h (of_complex z) = of_complex (-z)"
	+ by (transfer, transfer, simp)
	+
	+lemma uminus_zero [simp]:
	+ shows "~\<^sub>h 0\<^sub>h = 0\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+lemma uminus_inf [simp]:
	+ shows "~\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ apply (transfer, transfer)
	+ unfolding complex_cvec_eq_def
	+ by (rule_tac x="-1" in exI, simp)
	+
	+lemma uminus_inf_iff:
	+ shows "~\<^sub>h z = \<infinity>\<^sub>h \<longleftrightarrow> z = \<infinity>\<^sub>h"
	+ apply (transfer, transfer)
	+ by auto (rule_tac x="-1/a" in exI, auto)
	+
	+lemma uminus_id_iff:
	+ shows "~\<^sub>h z = z \<longleftrightarrow> z = 0\<^sub>h \<or> z = \<infinity>\<^sub>h"
	+ apply (transfer, transfer)
	+ apply auto
	+ apply (erule_tac x="1/a" in allE, simp)
	+ apply (rule_tac x="-1" in exI, simp)
	+ done
	+
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Subtraction\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Operation $\infty_h\ -_h\ \infty_h$ is ill-defined, but we define it arbitrarily to $0_h$. It breaks the connection between
	+ subtraction with addition and unary minus, but seems more intuitive.\<close>
	+
	+definition sub :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" (infixl "-\<^sub>h" 60) where
	+ "z -\<^sub>h w = (if z = \<infinity>\<^sub>h \<and> w = \<infinity>\<^sub>h then 0\<^sub>h else z +\<^sub>h (~\<^sub>h w))"
	+
	+lemma of_complex_sub_of_complex [simp]:
	+ shows "(of_complex x) -\<^sub>h (of_complex y) = of_complex (x - y)"
	+ unfolding sub_def
	+ by simp
	+
	+lemma zero_sub_right[simp]:
	+ shows "z -\<^sub>h 0\<^sub>h = z"
	+ unfolding sub_def
	+ by simp
	+
	+lemma zero_sub_left[simp]:
	+ shows "0\<^sub>h -\<^sub>h of_complex x = of_complex (-x)"
	+ by (subst of_complex_zero[symmetric], simp del: of_complex_zero)
	+
	+lemma zero_sub_one[simp]:
	+ shows "0\<^sub>h -\<^sub>h 1\<^sub>h = of_complex (-1)"
	+ by (metis of_complex_one zero_sub_left)
	+
	+lemma of_complex_sub_one [simp]:
	+ shows "of_complex x -\<^sub>h 1\<^sub>h = of_complex (x - 1)"
	+ by (metis of_complex_one of_complex_sub_of_complex)
	+
	+lemma sub_eq_zero [simp]:
	+ assumes "z \<noteq> \<infinity>\<^sub>h"
	+ shows "z -\<^sub>h z = 0\<^sub>h"
	+ using assms
	+ using inf_or_of_complex[of z]
	+ by auto
	+
	+lemma sub_eq_zero_iff:
	+ assumes "z \<noteq> \<infinity>\<^sub>h \<or> w \<noteq> \<infinity>\<^sub>h"
	+ shows "z -\<^sub>h w = 0\<^sub>h \<longleftrightarrow> z = w"
	+proof
	+ assume "z -\<^sub>h w = 0\<^sub>h"
	+ thus "z = w"
	+ using assms
	+ unfolding sub_def
	+ proof (transfer, transfer)
	+ fix z w :: complex_vec
	+ obtain z1 z2 w1 w2 where *: "z = (z1, z2)" "w = (w1, w2)"
	+ by (cases z, auto, cases w, auto)
	+ assume "z \<noteq> vec_zero" "w \<noteq> vec_zero" "\<not> z \<approx>\<^sub>v \<infinity>\<^sub>v \<or> \<not> w \<approx>\<^sub>v \<infinity>\<^sub>v" and
	+ **: "(if z \<approx>\<^sub>v \<infinity>\<^sub>v \<and> w \<approx>\<^sub>v \<infinity>\<^sub>v then 0\<^sub>v else z +\<^sub>v ~\<^sub>v w) \<approx>\<^sub>v 0\<^sub>v"
	+ have "z2 \<noteq> 0 \<or> w2 \<noteq> 0"
	+ using * \<open>\<not> z \<approx>\<^sub>v \<infinity>\<^sub>v \<or> \<not> w \<approx>\<^sub>v \<infinity>\<^sub>v\<close> \<open>z \<noteq> vec_zero\<close> \<open>w \<noteq> vec_zero\<close>
	+ apply auto
	+ apply (erule_tac x="1/z1" in allE, simp)
	+ apply (erule_tac x="1/w1" in allE, simp)
	+ done
	+
	+ thus "z \<approx>\<^sub>v w"
	+ using * **
	+ by simp (rule_tac x="w2/z2" in exI, auto simp add: field_simps)
	+ qed
	+next
	+ assume "z = w"
	+ thus "z -\<^sub>h w = 0\<^sub>h"
	+ using sub_eq_zero[of z] assms
	+ by auto
	+qed
	+
	+lemma inf_sub_left [simp]:
	+ assumes "z \<noteq> \<infinity>\<^sub>h"
	+ shows "\<infinity>\<^sub>h -\<^sub>h z = \<infinity>\<^sub>h"
	+ using assms
	+ using uminus_inf_iff
	+ using inf_or_of_complex
	+ unfolding sub_def
	+ by force
	+
	+lemma inf_sub_right [simp]:
	+ assumes "z \<noteq> \<infinity>\<^sub>h"
	+ shows "z -\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ using assms
	+ using inf_or_of_complex
	+ unfolding sub_def
	+ by force
	+
	+text \<open>This is ill-defined, but holds by our definition\<close>
	+lemma inf_sub_inf:
	+ shows "\<infinity>\<^sub>h -\<^sub>h \<infinity>\<^sub>h = 0\<^sub>h"
	+ unfolding sub_def
	+ by simp
	+
	+lemma sub_noteq_inf:
	+ assumes "z \<noteq> \<infinity>\<^sub>h" and "w \<noteq> \<infinity>\<^sub>h"
	+ shows "z -\<^sub>h w \<noteq> \<infinity>\<^sub>h"
	+ using assms
	+ using inf_or_of_complex[of z]
	+ using inf_or_of_complex[of w]
	+ using inf_or_of_complex[of "z -\<^sub>h w"]
	+ using of_complex_sub_of_complex
	+ by auto
	+
	+lemma sub_eq_inf:
	+ assumes "z -\<^sub>h w = \<infinity>\<^sub>h"
	+ shows "z = \<infinity>\<^sub>h \<or> w = \<infinity>\<^sub>h"
	+ using assms sub_noteq_inf
	+ by blast
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Multiplication\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Operations $0_h \cdot_h \infty_h$ and $\infty_h \cdot_h 0_h$ are ill defined. Since all
	+functions must be total, for formal reasons we define it arbitrarily to be $1_h$.\<close>
	+
	+definition mult_cvec :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_vec" (infixl "*\<^sub>v" 70) where
	+ [simp]: "z *\<^sub>v w = (let (z1, z2) = z; (w1, w2) = w
	+ in if (z1 = 0 \<and> w2 = 0) \<or> (w1 = 0 \<and> z2 = 0) then
	+ (1, 1)
	+ else
	+ (z1w1, z2w2))"
	+lift_definition mult_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords" (infixl "*\<^sub>h\<^sub>c" 70) is mult_cvec
	+ by (auto split: if_split_asm)
	+
	+lift_definition mult :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" (infixl "*\<^sub>h" 70) is mult_hcoords
	+proof transfer
	+ fix z w z' w' :: complex_vec
	+ obtain z1 z2 w1 w2 z'1 z'2 w'1 w'2 where
	+ *: "z = (z1, z2)" "w = (w1, w2)" "z' = (z'1, z'2)" "w' = (w'1, w'2)"
	+ by (cases z, auto, cases w, auto, cases z', auto, cases w', auto)
	+ assume **:
	+ "z \<noteq> vec_zero" "w \<noteq> vec_zero" "z \<approx>\<^sub>v z'"
	+ "z' \<noteq> vec_zero" "w' \<noteq> vec_zero" "w \<approx>\<^sub>v w'"
	+ show "z \<^sub>v w \<approx>\<^sub>v z' \<^sub>v w'"
	+ proof (cases "(z1 = 0 \<and> w2 = 0) \<or> (w1 = 0 \<and> z2 = 0)")
	+ case True
	+ hence "(z'1 = 0 \<and> w'2 = 0) \<or> (w'1 = 0 \<and> z'2 = 0)"
	+ using * **
	+ by auto
	+ show ?thesis
	+ using \<open>(z1 = 0 \<and> w2 = 0) \<or> (w1 = 0 \<and> z2 = 0)\<close> \<open>(z'1 = 0 \<and> w'2 = 0) \<or> (w'1 = 0 \<and> z'2 = 0)\<close>
	+ using * **
	+ by simp
	+ next
	+ case False
	+ hence "\<not>((z'1 = 0 \<and> w'2 = 0) \<or> (w'1 = 0 \<and> z'2 = 0))"
	+ using * **
	+ by auto
	+ hence **: "z \<^sub>v w = (z1w1, z2w2)" "z' \<^sub>v w' = (z'1w'1, z'2*w'2)"
	+ using \<open>\<not>((z1 = 0 \<and> w2 = 0) \<or> (w1 = 0 \<and> z2 = 0))\<close> \<open>\<not>((z'1 = 0 \<and> w'2 = 0) \<or> (w'1 = 0 \<and> z'2 = 0))\<close>
	+ using *
	+ by auto
	+ show ?thesis
	+ apply (subst ***)+
	+ using * **
	+ by simp ((erule exE)+, rule_tac x="k*ka" in exI, simp)
	+ qed
	+qed
	+
	+lemma of_complex_mult_of_complex [simp]:
	+ shows "(of_complex z1) \<^sub>h (of_complex z2) = of_complex (z1 z2)"
	+ by (transfer, transfer, simp)
	+
	+lemma mult_commute:
	+ shows "z1 \<^sub>h z2 = z2 \<^sub>h z1"
	+ apply (transfer, transfer)
	+ unfolding complex_cvec_eq_def
	+ by (rule_tac x="1" in exI, auto split: if_split_asm)
	+
	+lemma mult_zero_left [simp]:
	+ assumes "z \<noteq> \<infinity>\<^sub>h"
	+ shows "0\<^sub>h *\<^sub>h z = 0\<^sub>h"
	+ using assms
	+proof (transfer, transfer)
	+ fix z :: complex_vec
	+ obtain z1 z2 where *: "z = (z1, z2)"
	+ by (cases z, auto)
	+ assume "z \<noteq> vec_zero" "\<not> (z \<approx>\<^sub>v \<infinity>\<^sub>v)"
	+ hence "z2 \<noteq> 0"
	+ using *
	+ by force
	+ thus "0\<^sub>v *\<^sub>v z \<approx>\<^sub>v 0\<^sub>v"
	+ using *
	+ by simp
	+qed
	+
	+lemma mult_zero_right [simp]:
	+ assumes "z \<noteq> \<infinity>\<^sub>h"
	+ shows "z *\<^sub>h 0\<^sub>h = 0\<^sub>h"
	+ using mult_zero_left[OF assms]
	+ by (simp add: mult_commute)
	+
	+lemma mult_inf_right [simp]:
	+ assumes "z \<noteq> 0\<^sub>h"
	+ shows "z *\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+using assms
	+proof (transfer, transfer)
	+ fix z :: complex_vec
	+ obtain z1 z2 where *: "z = (z1, z2)"
	+ by (cases z, auto)
	+ assume "z \<noteq> vec_zero" "\<not> (z \<approx>\<^sub>v 0\<^sub>v)"
	+ hence "z1 \<noteq> 0"
	+ using *
	+ by force
	+ thus "z *\<^sub>v \<infinity>\<^sub>v \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ using *
	+ by simp
	+qed
	+
	+lemma mult_inf_left [simp]:
	+ assumes "z \<noteq> 0\<^sub>h"
	+ shows "\<infinity>\<^sub>h *\<^sub>h z = \<infinity>\<^sub>h"
	+ using mult_inf_right[OF assms]
	+ by (simp add: mult_commute)
	+
	+lemma mult_one_left [simp]:
	+ shows "1\<^sub>h *\<^sub>h z = z"
	+ by (transfer, transfer, force)
	+
	+lemma mult_one_right [simp]:
	+ shows "z *\<^sub>h 1\<^sub>h = z"
	+ using mult_one_left[of z]
	+ by (simp add: mult_commute)
	+
	+text \<open>This is ill-defined, but holds by our definition\<close>
	+lemma inf_mult_zero:
	+ shows "\<infinity>\<^sub>h *\<^sub>h 0\<^sub>h = 1\<^sub>h"
	+ by (transfer, transfer, simp)
	+lemma zero_mult_inf:
	+ shows "0\<^sub>h *\<^sub>h \<infinity>\<^sub>h = 1\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+lemma mult_eq_inf:
	+ assumes "z *\<^sub>h w = \<infinity>\<^sub>h"
	+ shows "z = \<infinity>\<^sub>h \<or> w = \<infinity>\<^sub>h"
	+ using assms
	+ using inf_or_of_complex[of z]
	+ using inf_or_of_complex[of w]
	+ using inf_or_of_complex[of "z *\<^sub>h w"]
	+ using of_complex_mult_of_complex
	+ by auto
	+
	+lemma mult_noteq_inf:
	+ assumes "z \<noteq> \<infinity>\<^sub>h" and "w \<noteq> \<infinity>\<^sub>h"
	+ shows "z *\<^sub>h w \<noteq> \<infinity>\<^sub>h"
	+ using assms mult_eq_inf
	+ by blast
	+
	+subsubsection \<open>Reciprocal\<close>
	+definition reciprocal_cvec :: "complex_vec \<Rightarrow> complex_vec" where
	+ [simp]: "reciprocal_cvec z = (let (z1, z2) = z in (z2, z1))"
	+lift_definition reciprocal_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords" is reciprocal_cvec
	+ by auto
	+
	+lift_definition reciprocal :: "complex_homo \<Rightarrow> complex_homo" is reciprocal_hcoords
	+ by transfer auto
	+
	+lemma reciprocal_involution [simp]: "reciprocal (reciprocal z) = z"
	+ by (transfer, transfer, auto)
	+
	+lemma reciprocal_zero [simp]: "reciprocal 0\<^sub>h = \<infinity>\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+lemma reciprocal_inf [simp]: "reciprocal \<infinity>\<^sub>h = 0\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+lemma reciprocal_one [simp]: "reciprocal 1\<^sub>h = 1\<^sub>h"
	+ by (transfer, transfer, simp)
	+
	+lemma reciprocal_inf_iff [iff]: "reciprocal z = \<infinity>\<^sub>h \<longleftrightarrow> z = 0\<^sub>h"
	+ by (transfer, transfer, auto)
	+
	+lemma reciprocal_zero_iff [iff]: "reciprocal z = 0\<^sub>h \<longleftrightarrow> z = \<infinity>\<^sub>h"
	+ by (transfer, transfer, auto)
	+
	+lemma reciprocal_of_complex [simp]:
	+ assumes "z \<noteq> 0"
	+ shows "reciprocal (of_complex z) = of_complex (1 / z)"
	+ using assms
	+ by (transfer, transfer, simp)
	+
	+lemma reciprocal_real:
	+ assumes "is_real (to_complex z)" and "z \<noteq> 0\<^sub>h" and "z \<noteq> \<infinity>\<^sub>h"
	+ shows "Re (to_complex (reciprocal z)) = 1 / Re (to_complex z)"
	+proof-
	+ obtain c where "z = of_complex c" "c \<noteq> 0" "is_real c"
	+ using assms inf_or_of_complex[of z]
	+ by auto
	+ thus ?thesis
	+ by (simp add: Re_divide_real)
	+qed
	+
	+lemma reciprocal_id_iff:
	+ shows "reciprocal z = z \<longleftrightarrow> z = of_complex 1 \<or> z = of_complex (-1)"
	+proof (cases "z = 0\<^sub>h")
	+ case True
	+ thus ?thesis
	+ by (metis inf_not_of_complex of_complex_zero_iff reciprocal_inf_iff zero_neq_neg_one zero_neq_one)
	+next
	+ case False
	+ thus ?thesis
	+ using inf_or_of_complex[of z]
	+ by (smt complex_sqrt_1 of_complex_zero_iff reciprocal_inf_iff reciprocal_of_complex to_complex_of_complex)
	+qed
	+
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Division\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Operations $0_h :_h 0_h$ and $\infty_h :_h \infty_h$ are ill-defined. For formal reasons they
	+are defined to be $1_h$ (by the definition of multiplication).\<close>
	+
	+definition divide :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" (infixl ":\<^sub>h" 70) where
	+ "x :\<^sub>h y = x *\<^sub>h (reciprocal y)"
	+
	+lemma divide_zero_right [simp]:
	+ assumes "z \<noteq> 0\<^sub>h"
	+ shows "z :\<^sub>h 0\<^sub>h = \<infinity>\<^sub>h"
	+ using assms
	+ unfolding divide_def
	+ by simp
	+
	+lemma divide_zero_left [simp]:
	+ assumes "z \<noteq> 0\<^sub>h"
	+ shows "0\<^sub>h :\<^sub>h z = 0\<^sub>h"
	+ using assms
	+ unfolding divide_def
	+ by simp
	+
	+lemma divide_inf_right [simp]:
	+ assumes "z \<noteq> \<infinity>\<^sub>h"
	+ shows "z :\<^sub>h \<infinity>\<^sub>h = 0\<^sub>h"
	+ using assms
	+ unfolding divide_def
	+ by simp
	+
	+lemma divide_inf_left [simp]:
	+ assumes "z \<noteq> \<infinity>\<^sub>h"
	+ shows "\<infinity>\<^sub>h :\<^sub>h z = \<infinity>\<^sub>h"
	+ using assms reciprocal_zero_iff[of z] mult_inf_left
	+ unfolding divide_def
	+ by simp
	+
	+lemma divide_eq_inf:
	+ assumes "z :\<^sub>h w = \<infinity>\<^sub>h"
	+ shows "z = \<infinity>\<^sub>h \<or> w = 0\<^sub>h"
	+ using assms
	+ using reciprocal_inf_iff[of w] mult_eq_inf
	+ unfolding divide_def
	+ by auto
	+
	+lemma inf_divide_zero [simp]:
	+ shows "\<infinity>\<^sub>h :\<^sub>h 0\<^sub>h = \<infinity>\<^sub>h"
	+ unfolding divide_def
	+ by (transfer, simp)
	+
	+lemma zero_divide_inf [simp]:
	+ shows "0\<^sub>h :\<^sub>h \<infinity>\<^sub>h = 0\<^sub>h"
	+ unfolding divide_def
	+ by (transfer, simp)
	+
	+lemma divide_one_right [simp]:
	+ shows "z :\<^sub>h 1\<^sub>h = z"
	+ unfolding divide_def
	+ by simp
	+
	+lemma of_complex_divide_of_complex [simp]:
	+ assumes "z2 \<noteq> 0"
	+ shows "(of_complex z1) :\<^sub>h (of_complex z2) = of_complex (z1 / z2)"
	+using assms
	+ unfolding divide_def
	+ apply transfer
	+ apply transfer
	+ by (simp, rule_tac x="1/z2" in exI, simp)
	+
	+lemma one_div_of_complex [simp]:
	+ assumes "x \<noteq> 0"
	+ shows "1\<^sub>h :\<^sub>h of_complex x = of_complex (1 / x)"
	+ using assms
	+ unfolding divide_def
	+ by simp
	+
	+text \<open> This is ill-defined, but holds by our definition\<close>
	+lemma inf_divide_inf:
	+ shows "\<infinity>\<^sub>h :\<^sub>h \<infinity>\<^sub>h = 1\<^sub>h"
	+ unfolding divide_def
	+ by (simp add: inf_mult_zero)
	+
	+text \<open> This is ill-defined, but holds by our definition\<close>
	+lemma zero_divide_zero:
	+ shows "0\<^sub>h :\<^sub>h 0\<^sub>h = 1\<^sub>h"
	+ unfolding divide_def
	+ by (simp add: zero_mult_inf)
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Conjugate\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+definition conjugate_cvec :: "complex_vec \<Rightarrow> complex_vec" where
	+ [simp]: "conjugate_cvec z = vec_cnj z"
	+lift_definition conjugate_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords" is conjugate_cvec
	+ by (auto simp add: vec_cnj_def)
	+lift_definition conjugate :: "complex_homo \<Rightarrow> complex_homo" is conjugate_hcoords
	+ by transfer (auto simp add: vec_cnj_def)
	+
	+lemma conjugate_involution [simp]:
	+ shows "conjugate (conjugate z) = z"
	+ by (transfer, transfer, auto)
	+
	+lemma conjugate_conjugate_comp [simp]:
	+ shows "conjugate \<circ> conjugate = id"
	+ by (rule ext, simp)
	+
	+lemma inv_conjugate [simp]:
	+ shows "inv conjugate = conjugate"
	+ using inv_unique_comp[of conjugate conjugate]
	+ by simp
	+
	+lemma conjugate_of_complex [simp]:
	+ shows "conjugate (of_complex z) = of_complex (cnj z)"
	+ by (transfer, transfer, simp add: vec_cnj_def)
	+
	+lemma conjugate_inf [simp]:
	+ shows "conjugate \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ by (transfer, transfer, simp add: vec_cnj_def)
	+
	+lemma conjugate_zero [simp]:
	+ shows "conjugate 0\<^sub>h = 0\<^sub>h"
	+ by (transfer, transfer, simp add: vec_cnj_def)
	+
	+lemma conjugate_one [simp]:
	+ shows "conjugate 1\<^sub>h = 1\<^sub>h"
	+ by (transfer, transfer, simp add: vec_cnj_def)
	+
	+lemma conjugate_inj:
	+ assumes "conjugate x = conjugate y"
	+ shows "x = y"
	+ using assms
	+ using conjugate_involution[of x] conjugate_involution[of y]
	+ by metis
	+
	+lemma bij_conjugate [simp]:
	+ shows "bij conjugate"
	+ unfolding bij_def inj_on_def
	+proof auto
	+ fix x y
	+ assume "conjugate x = conjugate y"
	+ thus "x = y"
	+ by (simp add: conjugate_inj)
	+next
	+ fix x
	+ show "x \<in> range conjugate"
	+ by (metis conjugate_involution range_eqI)
	+qed
	+
	+lemma conjugate_id_iff:
	+ shows "conjugate a = a \<longleftrightarrow> is_real (to_complex a) \<or> a = \<infinity>\<^sub>h"
	+ using inf_or_of_complex[of a]
	+ by (metis conjugate_inf conjugate_of_complex eq_cnj_iff_real to_complex_of_complex)
	+
	+subsubsection \<open>Inversion\<close>
	+
	+text \<open>Geometric inversion wrt. the unit circle\<close>
	+
	+definition inversion where
	+ "inversion = conjugate \<circ> reciprocal"
	+
	+lemma inversion_sym:
	+ shows "inversion = reciprocal \<circ> conjugate"
	+ unfolding inversion_def
	+ apply (rule ext, simp)
	+ apply transfer
	+ apply transfer
	+ apply (auto simp add: vec_cnj_def)
	+ using one_neq_zero
	+ by blast+
	+
	+lemma inversion_involution [simp]:
	+ shows "inversion (inversion z) = z"
	+proof-
	+ have *: "conjugate \<circ> reciprocal = reciprocal \<circ> conjugate"
	+ using inversion_sym
	+ by (simp add: inversion_def)
	+ show ?thesis
	+ unfolding inversion_def
	+ by (subst *) simp
	+qed
	+
	+lemma inversion_inversion_id [simp]:
	+ shows "inversion \<circ> inversion = id"
	+ by (rule ext, simp)
	+
	+lemma inversion_zero [simp]:
	+ shows "inversion 0\<^sub>h = \<infinity>\<^sub>h"
	+ by (simp add: inversion_def)
	+
	+lemma inversion_infty [simp]:
	+ shows "inversion \<infinity>\<^sub>h = 0\<^sub>h"
	+ by (simp add: inversion_def)
	+
	+lemma inversion_of_complex [simp]:
	+ assumes "z \<noteq> 0"
	+ shows "inversion (of_complex z) = of_complex (1 / cnj z)"
	+ using assms
	+ by (simp add: inversion_def)
	+
	+lemma is_real_inversion:
	+ assumes "is_real x" and "x \<noteq> 0"
	+ shows "is_real (to_complex (inversion (of_complex x)))"
	+ using assms eq_cnj_iff_real[of x]
	+ by simp
	+
	+lemma inversion_id_iff:
	+ shows "a = inversion a \<longleftrightarrow> a \<noteq> \<infinity>\<^sub>h \<and> (to_complex a) * cnj (to_complex a) = 1" (is "?lhs = ?rhs")
	+proof
	+ assume "a = inversion a"
	+ thus ?rhs
	+ unfolding inversion_def
	+ using inf_or_of_complex[of a]
	+ by (metis (full_types) comp_apply complex_cnj_cancel_iff complex_cnj_zero inversion_def inversion_infty inversion_of_complex inversion_sym nonzero_eq_divide_eq of_complex_zero reciprocal_zero to_complex_of_complex zero_one_infty_not_equal(5))
	+next
	+ assume ?rhs
	+ thus ?lhs
	+ using inf_or_of_complex[of a]
	+ by (metis inversion_of_complex mult_not_zero nonzero_mult_div_cancel_right one_neq_zero to_complex_of_complex)
	+qed
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Ratio and cross-ratio\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Ratio\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Ratio of points $z$, $v$ and $w$ is usually defined as
	+$\frac{z-v}{z-w}$. Our definition introduces it in homogeneous
	+coordinates. It is well-defined if $z_1 \neq z_2 \vee z_1 \neq z_3$ and $z_1 \neq \infty_h$ and
	+$z_2 \neq \infty_h \vee z_3 \neq \infty_h$\<close>
	+
	+definition ratio :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" where
	+ "ratio za zb zc = (za -\<^sub>h zb) :\<^sub>h (za -\<^sub>h zc)"
	+
	+text \<open>This is ill-defined, but holds by our definition\<close>
	+lemma
	+ assumes "zb \<noteq> \<infinity>\<^sub>h" and "zc \<noteq> \<infinity>\<^sub>h"
	+ shows "ratio \<infinity>\<^sub>h zb zc = 1\<^sub>h"
	+ using assms
	+ using inf_sub_left[OF assms(1)]
	+ using inf_sub_left[OF assms(2)]
	+ unfolding ratio_def
	+ by (simp add: inf_divide_inf)
	+
	+lemma
	+ assumes "za \<noteq> \<infinity>\<^sub>h" and "zc \<noteq> \<infinity>\<^sub>h"
	+ shows "ratio za \<infinity>\<^sub>h zc = \<infinity>\<^sub>h"
	+ using assms
	+ unfolding ratio_def
	+ using inf_sub_right[OF assms(1)]
	+ using sub_noteq_inf[OF assms]
	+ using divide_inf_left
	+ by simp
	+
	+lemma
	+ assumes "za \<noteq> \<infinity>\<^sub>h" and "zb \<noteq> \<infinity>\<^sub>h"
	+ shows "ratio za zb \<infinity>\<^sub>h = 0\<^sub>h"
	+ unfolding ratio_def
	+ using sub_noteq_inf[OF assms]
	+ using inf_sub_right[OF assms(1)]
	+ using divide_inf_right
	+ by simp
	+
	+lemma
	+ assumes "z1 \<noteq> z2" and "z1 \<noteq> \<infinity>\<^sub>h"
	+ shows "ratio z1 z2 z1 = \<infinity>\<^sub>h"
	+ using assms
	+ unfolding ratio_def
	+ using divide_zero_right[of "z1 -\<^sub>h z2"]
	+ using sub_eq_zero_iff[of z1 z2]
	+ by simp
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Cross-ratio\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>The cross-ratio is defined over 4 points $(z, u, v, w)$, usually as
	+$\frac{(z-u)(v-w)}{(z-w)(v-u)}$. We define it using homogeneous coordinates. Cross ratio is
	+ill-defined when $z = u \vee v = w$ and $z = w$ and $v = u$ i.e. when 3 points are equal. Since
	+function must be total, in that case we define it arbitrarily to 1.\<close>
	+
	+definition cross_ratio_cvec :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_vec" where
	+ [simp]: "cross_ratio_cvec z u v w =
	+ (let (z', z'') = z;
	+ (u', u'') = u;
	+ (v', v'') = v;
	+ (w', w'') = w;
	+ n1 = z'u'' - u'z'';
	+ n2 = v'w'' - w'v'';
	+ d1 = z'w'' - w'z'';
	+ d2 = v'u'' - u'v''
	+ in
	+ if n1 * n2 \<noteq> 0 \<or> d1 * d2 \<noteq> 0 then
	+ (n1 * n2, d1 * d2)
	+ else
	+ (1, 1))"
	+
	+lift_definition cross_ratio_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords" is cross_ratio_cvec
	+ by (auto split: if_split_asm)
	+
	+lift_definition cross_ratio :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" is cross_ratio_hcoords
	+proof transfer
	+ fix z u v w z' u' v' w' :: complex_vec
	+ obtain z1 z2 u1 u2 v1 v2 w1 w2 z'1 z'2 u'1 u'2 v'1 v'2 w'1 w'2
	+ where *: "z = (z1, z2)" "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
	+ "z' = (z'1, z'2)" "u' = (u'1, u'2)" "v' = (v'1, v'2)" "w' = (w'1, w'2)"
	+ by (cases z, auto, cases u, auto, cases v, auto, cases w, auto,
	+ cases z', auto, cases u', auto, cases v', auto, cases w', auto)
	+ let ?n1 = "z1u2 - u1z2"
	+ let ?n2 = "v1w2 - w1v2"
	+ let ?d1 = "z1w2 - w1z2"
	+ let ?d2 = "v1u2 - u1v2"
	+ let ?n1' = "z'1u'2 - u'1z'2"
	+ let ?n2' = "v'1w'2 - w'1v'2"
	+ let ?d1' = "z'1w'2 - w'1z'2"
	+ let ?d2' = "v'1u'2 - u'1v'2"
	+
	+ assume **:
	+ "z \<noteq> vec_zero" "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero"
	+ "z' \<noteq> vec_zero" "u' \<noteq> vec_zero" "v' \<noteq> vec_zero" "w' \<noteq> vec_zero"
	+ "z \<approx>\<^sub>v z'" "v \<approx>\<^sub>v v'" "u \<approx>\<^sub>v u'" "w \<approx>\<^sub>v w'"
	+ show "cross_ratio_cvec z u v w \<approx>\<^sub>v cross_ratio_cvec z' u' v' w'"
	+ proof (cases "?n1?n2 \<noteq> 0 \<or> ?d1?d2 \<noteq> 0")
	+ case True
	+ hence "?n1'?n2' \<noteq> 0 \<or> ?d1'?d2' \<noteq> 0"
	+ using * **
	+ by simp ((erule exE)+, simp)
	+ show ?thesis
	+ using \<open>?n1?n2 \<noteq> 0 \<or> ?d1?d2 \<noteq> 0\<close>
	+ using \<open>?n1'?n2' \<noteq> 0 \<or> ?d1'?d2' \<noteq> 0\<close>
	+ using * **
	+ by simp ((erule exE)+, rule_tac x="kkakb*kc" in exI, simp add: field_simps)
	+ next
	+ case False
	+ hence "\<not> (?n1'?n2' \<noteq> 0 \<or> ?d1'?d2' \<noteq> 0)"
	+ using * **
	+ by simp ((erule exE)+, simp)
	+ show ?thesis
	+ using \<open>\<not> (?n1?n2 \<noteq> 0 \<or> ?d1?d2 \<noteq> 0)\<close>
	+ using \<open>\<not> (?n1'?n2' \<noteq> 0 \<or> ?d1'?d2' \<noteq> 0)\<close>
	+ using * **
	+ by simp blast
	+ qed
	+qed
	+
	+lemma cross_ratio_01inf_id [simp]:
	+ shows "cross_ratio z 0\<^sub>h 1\<^sub>h \<infinity>\<^sub>h = z"
	+proof (transfer, transfer)
	+ fix z :: complex_vec
	+ obtain z1 z2 where *: "z = (z1, z2)"
	+ by (cases z, auto)
	+ assume "z \<noteq> vec_zero"
	+ thus "cross_ratio_cvec z 0\<^sub>v 1\<^sub>v \<infinity>\<^sub>v \<approx>\<^sub>v z"
	+ using *
	+ by simp (rule_tac x="-1" in exI, simp)
	+qed
	+
	+lemma cross_ratio_0:
	+ assumes "u \<noteq> v" and "u \<noteq> w"
	+ shows "cross_ratio u u v w = 0\<^sub>h"
	+ using assms
	+proof (transfer, transfer)
	+ fix u v w :: complex_vec
	+ obtain u1 u2 v1 v2 w1 w2
	+ where *: "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
	+ by (cases u, auto, cases v, auto, cases w, auto)
	+ assume "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero" "\<not> u \<approx>\<^sub>v v" "\<not> u \<approx>\<^sub>v w"
	+ thus "cross_ratio_cvec u u v w \<approx>\<^sub>v 0\<^sub>v"
	+ using * complex_cvec_eq_mix[of u1 u2 v1 v2] complex_cvec_eq_mix[of u1 u2 w1 w2]
	+ by (force simp add: mult.commute)
	+qed
	+
	+lemma cross_ratio_1:
	+ assumes "u \<noteq> v" and "v \<noteq> w"
	+ shows "cross_ratio v u v w = 1\<^sub>h"
	+ using assms
	+proof (transfer, transfer)
	+ fix u v w :: complex_vec
	+ obtain u1 u2 v1 v2 w1 w2
	+ where *: "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
	+ by (cases u, auto, cases v, auto, cases w, auto)
	+ let ?n1 = "v1u2 - u1v2"
	+ let ?n2 = "v1w2 - w1v2"
	+ assume "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero" "\<not> u \<approx>\<^sub>v v" "\<not> v \<approx>\<^sub>v w"
	+ hence "?n1 \<noteq> 0 \<and> ?n2 \<noteq> 0"
	+ using * complex_cvec_eq_mix[of u1 u2 v1 v2] complex_cvec_eq_mix[of v1 v2 w1 w2]
	+ by (auto simp add: field_simps)
	+ thus "cross_ratio_cvec v u v w \<approx>\<^sub>v 1\<^sub>v"
	+ using *
	+ by simp (rule_tac x="1 / (?n1 * ?n2)" in exI, simp)
	+qed
	+
	+lemma cross_ratio_inf:
	+ assumes "u \<noteq> w" and "v \<noteq> w"
	+ shows "cross_ratio w u v w = \<infinity>\<^sub>h"
	+ using assms
	+proof (transfer, transfer)
	+ fix u v w :: complex_vec
	+ obtain u1 u2 v1 v2 w1 w2
	+ where *: "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
	+ by (cases u, auto, cases v, auto, cases w, auto)
	+ let ?n1 = "w1u2 - u1w2"
	+ let ?n2 = "v1w2 - w1v2"
	+ assume "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero" "\<not> u \<approx>\<^sub>v w" "\<not> v \<approx>\<^sub>v w"
	+ hence "?n1 \<noteq> 0 \<and> ?n2 \<noteq> 0"
	+ using * complex_cvec_eq_mix[of u1 u2 w1 w2] complex_cvec_eq_mix[of v1 v2 w1 w2]
	+ by (auto simp add: field_simps)
	+ thus "cross_ratio_cvec w u v w \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ using *
	+ by simp
	+qed
	+
	+lemma cross_ratio_0inf:
	+ assumes "y \<noteq> 0"
	+ shows "cross_ratio (of_complex x) 0\<^sub>h (of_complex y) \<infinity>\<^sub>h = (of_complex (x / y))"
	+ using assms
	+ by (transfer, transfer) (simp, rule_tac x="-1/y" in exI, simp)
	+
	+lemma cross_ratio_commute_13:
	+ shows "cross_ratio z u v w = reciprocal (cross_ratio v u z w)"
	+ by (transfer, transfer, case_tac z, case_tac u, case_tac v, case_tac w, simp)
	+
	+lemma cross_ratio_commute_24:
	+ shows "cross_ratio z u v w = reciprocal (cross_ratio z w v u)"
	+ by (transfer, transfer, case_tac z, case_tac u, case_tac v, case_tac w, simp)
	+
	+lemma cross_ratio_not_inf:
	+ assumes "z \<noteq> w" and "u \<noteq> v"
	+ shows "cross_ratio z u v w \<noteq> \<infinity>\<^sub>h"
	+ using assms
	+proof (transfer, transfer)
	+ fix z u v w
	+ assume nz: "z \<noteq> vec_zero" "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero"
	+ obtain z1 z2 u1 u2 v1 v2 w1 w2 where *: "z = (z1, z2)" "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
	+ by (cases z, cases u, cases v, cases w, auto)
	+ obtain x1 x2 where **: "cross_ratio_cvec z u v w = (x1, x2)"
	+ by (cases "cross_ratio_cvec z u v w", auto)
	+ assume "\<not> z \<approx>\<^sub>v w" "\<not> u \<approx>\<^sub>v v"
	+ hence "z1w2 \<noteq> z2w1" "u1v2 \<noteq> u2v1"
	+ using * nz complex_cvec_eq_mix
	+ by blast+
	+ hence "x2 \<noteq> 0"
	+ using * **
	+ by (auto split: if_split_asm) (simp add: field_simps)
	+ thus "\<not> cross_ratio_cvec z u v w \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ using inf_cvec_z2_zero_iff * **
	+ by simp
	+qed
	+
	+lemma cross_ratio_not_zero:
	+ assumes "z \<noteq> u" and "v \<noteq> w"
	+ shows "cross_ratio z u v w \<noteq> 0\<^sub>h"
	+ using assms
	+proof (transfer, transfer)
	+ fix z u v w
	+ assume nz: "z \<noteq> vec_zero" "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero"
	+ obtain z1 z2 u1 u2 v1 v2 w1 w2 where *: "z = (z1, z2)" "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
	+ by (cases z, cases u, cases v, cases w, auto)
	+ obtain x1 x2 where **: "cross_ratio_cvec z u v w = (x1, x2)"
	+ by (cases "cross_ratio_cvec z u v w", auto)
	+ assume "\<not> z \<approx>\<^sub>v u" "\<not> v \<approx>\<^sub>v w"
	+ hence "z1u2 \<noteq> z2u1" "v1w2 \<noteq> v2w1"
	+ using * nz complex_cvec_eq_mix
	+ by blast+
	+ hence "x1 \<noteq> 0"
	+ using * **
	+ by (auto split: if_split_asm)
	+ thus "\<not> cross_ratio_cvec z u v w \<approx>\<^sub>v 0\<^sub>v"
	+ using zero_cvec_z1_zero_iff * **
	+ by simp
	+qed
	+
	+lemma cross_ratio_real:
	+ assumes "is_real z" and "is_real u" and "is_real v" and "is_real w"
	+ assumes "z \<noteq> u \<and> v \<noteq> w \<or> z \<noteq> w \<and> u \<noteq> v"
	+ shows "is_real (to_complex (cross_ratio (of_complex z) (of_complex u) (of_complex v) (of_complex w)))"
	+ using assms
	+ by (transfer, transfer, auto)
	+
	+lemma cross_ratio:
	+ assumes "(z \<noteq> u \<and> v \<noteq> w) \<or> (z \<noteq> w \<and> u \<noteq> v)" and
	+ "z \<noteq> \<infinity>\<^sub>h" and "u \<noteq> \<infinity>\<^sub>h" and "v \<noteq> \<infinity>\<^sub>h" and "w \<noteq> \<infinity>\<^sub>h"
	+ shows "cross_ratio z u v w = ((z -\<^sub>h u) \<^sub>h (v -\<^sub>h w)) :\<^sub>h ((z -\<^sub>h w) \<^sub>h (v -\<^sub>h u))"
	+ unfolding sub_def divide_def
	+ using assms
	+ apply transfer
	+ apply simp
	+ apply transfer
	+proof-
	+ fix z u v w :: complex_vec
	+ obtain z1 z2 u1 u2 v1 v2 w1 w2
	+ where *: "z = (z1, z2)" "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
	+ by (cases z, auto, cases u, auto, cases v, auto, cases w, auto)
	+
	+ let ?n1 = "z1u2 - u1z2"
	+ let ?n2 = "v1w2 - w1v2"
	+ let ?d1 = "z1w2 - w1z2"
	+ let ?d2 = "v1u2 - u1v2"
	+ assume **: "z \<noteq> vec_zero" "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero"
	+ "\<not> z \<approx>\<^sub>v u \<and> \<not> v \<approx>\<^sub>v w \<or> \<not> z \<approx>\<^sub>v w \<and> \<not> u \<approx>\<^sub>v v"
	+ "\<not> z \<approx>\<^sub>v \<infinity>\<^sub>v" "\<not> u \<approx>\<^sub>v \<infinity>\<^sub>v" "\<not> v \<approx>\<^sub>v \<infinity>\<^sub>v" "\<not> w \<approx>\<^sub>v \<infinity>\<^sub>v"
	+
	+ hence **: "?n1 ?n2 \<noteq> 0 \<or> ?d1 * ?d2 \<noteq> 0"
	+ using *
	+ using complex_cvec_eq_mix[of z1 z2 u1 u2] complex_cvec_eq_mix[of v1 v2 w1 w2]
	+ using complex_cvec_eq_mix[of z1 z2 w1 w2] complex_cvec_eq_mix[of u1 u2 v1 v2]
	+ by (metis eq_iff_diff_eq_0 mult.commute mult_eq_0_iff)
	+
	+ have ****: "z2 \<noteq> 0" "w2 \<noteq> 0" "u2 \<noteq> 0" "v2 \<noteq> 0"
	+ using * (1-4) (6-9)
	+ using inf_cvec_z2_zero_iff[of z1 z2]
	+ using inf_cvec_z2_zero_iff[of u1 u2]
	+ using inf_cvec_z2_zero_iff[of v1 v2]
	+ using inf_cvec_z2_zero_iff[of w1 w2]
	+ by blast+
	+
	+ have "cross_ratio_cvec z u v w = (?n1?n2, ?d1?d2)"
	+ using * ***
	+ by simp
	+ moreover
	+ let ?k = "z2u2v2*w2"
	+ have "(z +\<^sub>v ~\<^sub>v u) \<^sub>v (v +\<^sub>v ~\<^sub>v w) \<^sub>v reciprocal_cvec ((z +\<^sub>v ~\<^sub>v w) \<^sub>v (v +\<^sub>v ~\<^sub>v u)) = (?k ?n1 * ?n2, ?k * ?d1 * ?d2)"
	+ using * * **
	+ by auto
	+ ultimately
	+ show "cross_ratio_cvec z u v w \<approx>\<^sub>v
	+ (z +\<^sub>v ~\<^sub>v u) \<^sub>v (v +\<^sub>v ~\<^sub>v w) \<^sub>v reciprocal_cvec ((z +\<^sub>v ~\<^sub>v w) *\<^sub>v (v +\<^sub>v ~\<^sub>v u))"
	+ using ****
	+ unfolding complex_cvec_eq_def
	+ by (rule_tac x="?k" in exI) simp
	+qed
	+
	+end
	+
	+(*
	+(* Although it seems useful, we did not use this. *)
	+
	+text \<open>Transfer extended complex plane to complex plane\<close>
	+
	+definition HC :: "complex_homo \<Rightarrow> complex \<Rightarrow> bool"
	+ where "HC = (\<lambda> h c. h = of_complex c)"
	+
	+lemma Domainp_HC [transfer_domain_rule]: "Domainp HC = (\<lambda> x. x \<noteq> \<infinity>\<^sub>h)"
	+ unfolding HC_def Domainp_iff[abs_def]
	+ apply (rule ext)
	+ using inf_or_of_complex
	+ by auto
	+
	+lemma bi_unique_HC [transfer_rule]: "bi_unique HC"
	+ using of_complex_inj
	+ unfolding HC_def bi_unique_def
	+ by auto
	+
	+lemma right_total_HC [transfer_rule]: "right_total HC"
	+ unfolding HC_def right_total_def
	+ by auto
	+
	+lemma HC_0 [transfer_rule]: "HC 0\<^sub>h 0"
	+ unfolding HC_def
	+ by simp
	+
	+lemma HC_1 [transfer_rule]: "HC 1\<^sub>h 1"
	+ unfolding HC_def
	+ by simp
	+
	+context includes lifting_syntax
	+begin
	+lemma HC_add [transfer_rule]: "(HC ===> HC ===> HC) (op +\<^sub>h) (op +)"
	+ unfolding rel_fun_def HC_def
	+ by auto
	+
	+lemma HC_mult [transfer_rule]: "(HC ===> HC ===> HC) (op \<^sub>h) ( op )"
	+ unfolding rel_fun_def HC_def
	+ by auto
	+
	+lemma HC_All [transfer_rule]:
	+ "((HC ===> op =) ===> op =) (Ball {z. z \<noteq> \<infinity>\<^sub>h}) All"
	+ using inf_or_of_complex
	+ unfolding rel_fun_def HC_def
	+ by auto
	+
	+lemma HC_transfer_forall [transfer_rule]:
	+ "((HC ===> op =) ===> op =) (transfer_bforall (\<lambda>x. x \<noteq> \<infinity>\<^sub>h)) transfer_forall"
	+ using inf_or_of_complex
	+ unfolding transfer_forall_def transfer_bforall_def
	+ unfolding rel_fun_def HC_def
	+ by auto
	+end
	+*)
	diff --git a/thys/Complex_Geometry/Linear_Systems.thy b/thys/Complex_Geometry/Linear_Systems.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Linear_Systems.thy
	@@ -0,0 +1,217 @@
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Systems of linear equations\<close>
	+(* ---------------------------------------------------------------------------- *)
	+(* TODO: merge with matrices *)
	+
	+text \<open>In this section some simple properties of systems of linear equations with two or three unknowns are derived.
	+Existence and uniqueness of solutions of regular and singular homogenous and non-homogenous systems is characterized.\<close>
	+
	+theory Linear_Systems
	+imports Main
	+begin
	+
	+text \<open>Determinant of 2x2 matrix\<close>
	+definition det2 :: "('a::field) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
	+ [simp]: "det2 a11 a12 a21 a22 \<equiv> a11a22 - a12a21"
	+
	+text \<open>Regular homogenous system has only trivial solution\<close>
	+lemma regular_homogenous_system:
	+ fixes a11 a12 a21 a22 x1 x2 :: "'a::field"
	+ assumes "det2 a11 a12 a21 a22 \<noteq> 0"
	+ assumes "a11x1 + a12x2 = 0" and
	+ "a21x1 + a22x2 = 0"
	+ shows "x1 = 0 \<and> x2 = 0"
	+proof (cases "a11 = 0")
	+ case True
	+ with assms(1) have "a12 \<noteq> 0" "a21 \<noteq> 0"
	+ by auto
	+ thus ?thesis
	+ using \<open>a11 = 0\<close> assms(2) assms(3)
	+ by auto
	+next
	+ case False
	+ hence "x1 = - a12*x2 / a11"
	+ using assms(2)
	+ by (metis eq_neg_iff_add_eq_0 mult_minus_left nonzero_mult_div_cancel_left)
	+ hence "a21 * (- a12 * x2 / a11) + a22 * x2 = 0"
	+ using assms(3)
	+ by simp
	+ hence "a21 * (- a12 * x2) + a22 * x2 * a11 = 0"
	+ using \<open>a11 \<noteq> 0\<close>
	+ by auto
	+ hence "(a11a22 - a12a21)*x2 = 0"
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using assms(1) assms(2) \<open>a11 \<noteq> 0\<close>
	+ by auto
	+qed
	+
	+text \<open>Regular system has a unique solution\<close>
	+lemma regular_system:
	+ fixes a11 a12 a21 a22 b1 b2 :: "'a::field"
	+ assumes "det2 a11 a12 a21 a22 \<noteq> 0"
	+ shows "\<exists>! x. a11(fst x) + a12(snd x) = b1 \<and>
	+ a21(fst x) + a22(snd x) = b2"
	+proof
	+ let ?d = "a11a22 - a12a21" and ?d1 = "b1a22 - b2a12" and ?d2 = "b2a11 - b1a21"
	+ let ?x = "(?d1 / ?d, ?d2 / ?d)"
	+ have "a11 * ?d1 + a12 * ?d2 = b1?d" "a21 ?d1 + a22 * ?d2 = b2*?d"
	+ by (auto simp add: field_simps)
	+ thus "a11 * fst ?x + a12 * snd ?x = b1 \<and> a21 * fst ?x + a22 * snd ?x = b2"
	+ using assms
	+ by (metis (hide_lams, no_types) det2_def add_divide_distrib eq_divide_imp fst_eqD snd_eqD times_divide_eq_right)
	+
	+ fix x'
	+ assume "a11 * fst x' + a12 * snd x' = b1 \<and> a21 * fst x' + a22 * snd x' = b2"
	+ with \<open>a11 * fst ?x + a12 * snd ?x = b1 \<and> a21 * fst ?x + a22 * snd ?x = b2\<close>
	+ have "a11 * (fst x' - fst ?x) + a12 * (snd x' - snd ?x) = 0 \<and> a21 * (fst x' - fst ?x) + a22 * (snd x' - snd ?x) = 0"
	+ by (auto simp add: field_simps)
	+ thus "x' = ?x"
	+ using regular_homogenous_system[OF assms, of "fst x' - fst ?x" "snd x' - snd ?x"]
	+ by (cases x') auto
	+qed
	+
	+text \<open>Singular system does not have a unique solution\<close>
	+lemma singular_system:
	+ fixes a11 a12 a21 a22 ::"'a::field"
	+ assumes "det2 a11 a12 a21 a22 = 0" and "a11 \<noteq> 0 \<or> a12 \<noteq> 0"
	+ assumes x0: "a11fst x0 + a12snd x0 = b1"
	+ "a21fst x0 + a22snd x0 = b2"
	+ assumes x: "a11fst x + a12snd x = b1"
	+ shows "a21fst x + a22snd x = b2"
	+proof (cases "a11 = 0")
	+ case True
	+ with assms have "a21 = 0" "a12 \<noteq> 0"
	+ by auto
	+ let ?k = "a22 / a12"
	+ have "b2 = ?k * b1"
	+ using x0 \<open>a11 = 0\<close> \<open>a21 = 0\<close> \<open>a12 \<noteq> 0\<close>
	+ by auto
	+ thus ?thesis
	+ using \<open>a11 = 0\<close> \<open>a21 = 0\<close> \<open>a12 \<noteq> 0\<close> x
	+ by auto
	+next
	+ case False
	+ let ?k = "a21 / a11"
	+ from x
	+ have "?k * a11 * fst x + ?k * a12 * snd x = ?k * b1"
	+ using \<open>a11 \<noteq> 0\<close>
	+ by (auto simp add: field_simps)
	+ moreover
	+ have "a21 = ?k * a11" "a22 = ?k * a12" "b2 = ?k * b1"
	+ using assms(1) x0 \<open>a11 \<noteq> 0\<close>
	+ by (auto simp add: field_simps)
	+ ultimately
	+ show ?thesis
	+ by auto
	+qed
	+
	+text \<open>All solutions of a homogenous system of 2 equations with 3 unknows are proportional\<close>
	+lemma linear_system_homogenous_3_2:
	+ fixes a11 a12 a13 a21 a22 a23 x1 y1 z1 x2 y2 z2 :: "'a::field"
	+ assumes "f1 = (\<lambda> x y z. a11 * x + a12 * y + a13 * z)"
	+ assumes "f2 = (\<lambda> x y z. a21 * x + a22 * y + a23 * z)"
	+ assumes "f1 x1 y1 z1 = 0" and "f2 x1 y1 z1 = 0"
	+ assumes "f1 x2 y2 z2 = 0" and "f2 x2 y2 z2 = 0"
	+ assumes "x2 \<noteq> 0 \<or> y2 \<noteq> 0 \<or> z2 \<noteq> 0"
	+ assumes "det2 a11 a12 a21 a22 \<noteq> 0 \<or> det2 a11 a13 a21 a23 \<noteq> 0 \<or> det2 a12 a13 a22 a23 \<noteq> 0"
	+ shows "\<exists> k. x1 = k * x2 \<and> y1 = k * y2 \<and> z1 = k * z2"
	+proof-
	+ let ?Dz = "det2 a11 a12 a21 a22"
	+ let ?Dy = "det2 a11 a13 a21 a23"
	+ let ?Dx = "det2 a12 a13 a22 a23"
	+
	+ have "a21 * (f1 x1 y1 z1) - a11 * (f2 x1 y1 z1) = 0"
	+ using assms
	+ by simp
	+ hence yz1: "?Dzy1 + ?Dyz1 = 0"
	+ using assms
	+ by (simp add: field_simps)
	+
	+ have "a21 * (f1 x2 y2 z2) - a11 * (f2 x2 y2 z2) = 0"
	+ using assms
	+ by simp
	+ hence yz2: "?Dzy2 + ?Dyz2 = 0"
	+ using assms
	+ by (simp add: field_simps)
	+
	+ have "a22 * (f1 x1 y1 z1) - a12 * (f2 x1 y1 z1) = 0"
	+ using assms
	+ by simp
	+ hence xz1: "-?Dzx1 + ?Dxz1 = 0"
	+ using assms
	+ by (simp add: field_simps)
	+
	+ have "a22 * (f1 x2 y2 z2) - a12 * (f2 x2 y2 z2) = 0"
	+ using assms
	+ by simp
	+ hence xz2: "-?Dzx2 + ?Dxz2 = 0"
	+ using assms
	+ by (simp add: field_simps)
	+
	+ have "a23 * (f1 x1 y1 z1) - a13 * (f2 x1 y1 z1) = 0"
	+ using assms
	+ by simp
	+ hence xy1: "?Dyx1 + ?Dxy1 = 0"
	+ using assms
	+ by (simp add: field_simps)
	+
	+ have "a23 * (f1 x2 y2 z2) - a13 * (f2 x2 y2 z2) = 0"
	+ using assms
	+ by simp
	+ hence xy2: "?Dyx2 + ?Dxy2 = 0"
	+ using assms
	+ by (simp add: field_simps)
	+
	+ show ?thesis
	+ using `?Dz \<noteq> 0 \<or> ?Dy \<noteq> 0 \<or> ?Dx \<noteq> 0`
	+ proof safe
	+ assume "?Dz \<noteq> 0"
	+
	+ hence *:
	+ "x2 = (?Dx / ?Dz) * z2" "y2 = - (?Dy / ?Dz) * z2"
	+ "x1 = (?Dx / ?Dz) * z1" "y1 = - (?Dy / ?Dz) * z1"
	+ using xy2 xz2 xy1 xz1 yz1 yz2
	+ by (simp_all add: field_simps)
	+
	+ hence "z2 \<noteq> 0"
	+ using `x2 \<noteq> 0 \<or> y2 \<noteq> 0 \<or> z2 \<noteq> 0`
	+ by auto
	+
	+ thus ?thesis
	+ using * `?Dz \<noteq> 0`
	+ by (rule_tac x="z1/z2" in exI) auto
	+ next
	+ assume "?Dy \<noteq> 0"
	+ hence *:
	+ "x2 = - (?Dx / ?Dy) * y2" "z2 = - (?Dz / ?Dy) * y2"
	+ "x1 = - (?Dx / ?Dy) * y1" "z1 = - (?Dz / ?Dy) * y1"
	+ using xy2 xz2 xy1 xz1 yz1 yz2
	+ by (simp_all add: field_simps)
	+
	+ hence "y2 \<noteq> 0"
	+ using `x2 \<noteq> 0 \<or> y2 \<noteq> 0 \<or> z2 \<noteq> 0`
	+ by auto
	+
	+ thus ?thesis
	+ using * `?Dy \<noteq> 0`
	+ by (rule_tac x="y1/y2" in exI) auto
	+ next
	+ assume "?Dx \<noteq> 0"
	+ hence *:
	+ "y2 = - (?Dy / ?Dx) * x2" "z2 = (?Dz / ?Dx) * x2"
	+ "y1 = - (?Dy / ?Dx) * x1" "z1 = (?Dz / ?Dx) * x1"
	+ using xy2 xz2 xy1 xz1 yz1 yz2
	+ by (simp_all add: field_simps)
	+
	+ hence "x2 \<noteq> 0"
	+ using `x2 \<noteq> 0 \<or> y2 \<noteq> 0 \<or> z2 \<noteq> 0`
	+ by auto
	+
	+ thus ?thesis
	+ using * `?Dx \<noteq> 0`
	+ by (rule_tac x="x1/x2" in exI) auto
	+ qed
	+qed
	+
	+end
	diff --git a/thys/Complex_Geometry/Matrices.thy b/thys/Complex_Geometry/Matrices.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Matrices.thy
	@@ -0,0 +1,830 @@
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Vectors and Matrices in $\mathbb{C}^2$\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Representing vectors and matrices of arbitrary dimensions pose a challenge in formal theorem
	+proving \cite{harrison05}, but we only need to consider finite dimension spaces $\mathbb{C}^2$ and
	+$\mathbb{R}^3$.\<close>
	+
	+theory Matrices
	+imports More_Complex Linear_Systems Quadratic
	+begin
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Vectors in $\mathbb{C}^2$\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Type of complex vector\<close>
	+
	+type_synonym complex_vec = "complex \<times> complex"
	+
	+definition vec_zero :: "complex_vec" where
	+ [simp]: "vec_zero = (0, 0)"
	+
	+text \<open>Vector scalar multiplication\<close>
	+
	+fun mult_sv :: "complex \<Rightarrow> complex_vec \<Rightarrow> complex_vec" (infixl "*\<^sub>s\<^sub>v" 100) where
	+ "k \<^sub>s\<^sub>v (x, y) = (kx, k*y)"
	+
	+lemma fst_mult_sv [simp]:
	+ shows "fst (k \<^sub>s\<^sub>v v) = k fst v"
	+ by (cases v) simp
	+
	+lemma snd_mult_sv [simp]:
	+ shows "snd (k \<^sub>s\<^sub>v v) = k snd v"
	+ by (cases v) simp
	+
	+lemma mult_sv_mult_sv [simp]:
	+ shows "k1 \<^sub>s\<^sub>v (k2 \<^sub>s\<^sub>v v) = (k1k2) \<^sub>s\<^sub>v v"
	+ by (cases v) simp
	+
	+lemma one_mult_sv [simp]:
	+ shows "1 *\<^sub>s\<^sub>v v = v"
	+ by (cases v) simp
	+
	+lemma mult_sv_ex_id1 [simp]:
	+ shows "\<exists> k::complex. k \<noteq> 0 \<and> k *\<^sub>s\<^sub>v v = v"
	+ by (rule_tac x=1 in exI, simp)
	+
	+lemma mult_sv_ex_id2 [simp]:
	+ shows "\<exists> k::complex. k \<noteq> 0 \<and> v = k *\<^sub>s\<^sub>v v"
	+ by (rule_tac x=1 in exI, simp)
	+
	+text \<open>Scalar product of two vectors\<close>
	+
	+fun mult_vv :: "complex \<times> complex \<Rightarrow> complex \<times> complex \<Rightarrow> complex" (infixl "*\<^sub>v\<^sub>v" 100) where
	+ "(x, y) \<^sub>v\<^sub>v (a, b) = xa + y*b"
	+
	+lemma mult_vv_commute:
	+ shows "v1 \<^sub>v\<^sub>v v2 = v2 \<^sub>v\<^sub>v v1"
	+ by (cases v1, cases v2) auto
	+
	+lemma mult_vv_scale_sv1:
	+ shows "(k \<^sub>s\<^sub>v v1) \<^sub>v\<^sub>v v2 = k * (v1 *\<^sub>v\<^sub>v v2)"
	+ by (cases v1, cases v2) (auto simp add: field_simps)
	+
	+lemma mult_vv_scale_sv2:
	+ shows "v1 \<^sub>v\<^sub>v (k \<^sub>s\<^sub>v v2) = k * (v1 *\<^sub>v\<^sub>v v2)"
	+ by (cases v1, cases v2) (auto simp add: field_simps)
	+
	+text \<open>Conjugate vector\<close>
	+
	+fun vec_map where
	+ "vec_map f (x, y) = (f x, f y)"
	+
	+definition vec_cnj where
	+ "vec_cnj = vec_map cnj"
	+
	+lemma vec_cnj_vec_cnj [simp]:
	+ shows "vec_cnj (vec_cnj v) = v"
	+ by (cases v) (simp add: vec_cnj_def)
	+
	+lemma cnj_mult_vv:
	+ shows "cnj (v1 \<^sub>v\<^sub>v v2) = (vec_cnj v1) \<^sub>v\<^sub>v (vec_cnj v2)"
	+ by (cases v1, cases v2) (simp add: vec_cnj_def)
	+
	+lemma vec_cnj_sv [simp]:
	+ shows "vec_cnj (k \<^sub>s\<^sub>v A) = cnj k \<^sub>s\<^sub>v vec_cnj A"
	+ by (cases A) (auto simp add: vec_cnj_def)
	+
	+lemma scalsquare_vv_zero:
	+ shows "(vec_cnj v) *\<^sub>v\<^sub>v v = 0 \<longleftrightarrow> v = vec_zero"
	+ apply (cases v)
	+ apply (auto simp add: vec_cnj_def field_simps complex_mult_cnj_cmod power2_eq_square)
	+ apply (simp only: cor_add[symmetric] cor_mult[symmetric] of_real_eq_0_iff, simp)+
	+ done
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Matrices in $\mathbb{C}^2$\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Type of complex matrices\<close>
	+
	+type_synonym complex_mat = "complex \<times> complex \<times> complex \<times> complex"
	+
	+text \<open>Matrix scalar multiplication\<close>
	+
	+fun mult_sm :: "complex \<Rightarrow> complex_mat \<Rightarrow> complex_mat" (infixl "*\<^sub>s\<^sub>m" 100) where
	+ "k \<^sub>s\<^sub>m (a, b, c, d) = (ka, kb, kc, k*d)"
	+
	+lemma mult_sm_distribution [simp]:
	+ shows "k1 \<^sub>s\<^sub>m (k2 \<^sub>s\<^sub>m A) = (k1k2) \<^sub>s\<^sub>m A"
	+ by (cases A) auto
	+
	+lemma mult_sm_neutral [simp]:
	+ shows "1 *\<^sub>s\<^sub>m A = A"
	+ by (cases A) auto
	+
	+lemma mult_sm_inv_l:
	+ assumes "k \<noteq> 0" and "k *\<^sub>s\<^sub>m A = B"
	+ shows "A = (1/k) *\<^sub>s\<^sub>m B"
	+ using assms
	+ by auto
	+
	+lemma mult_sm_ex_id1 [simp]:
	+ shows "\<exists> k::complex. k \<noteq> 0 \<and> k *\<^sub>s\<^sub>m M = M"
	+ by (rule_tac x=1 in exI, simp)
	+
	+lemma mult_sm_ex_id2 [simp]:
	+ shows "\<exists> k::complex. k \<noteq> 0 \<and> M = k *\<^sub>s\<^sub>m M"
	+ by (rule_tac x=1 in exI, simp)
	+
	+text \<open>Matrix addition and subtraction\<close>
	+
	+definition mat_zero :: "complex_mat" where [simp]: "mat_zero = (0, 0, 0, 0)"
	+
	+fun mat_plus :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex_mat" (infixl "+\<^sub>m\<^sub>m" 100) where
	+ "mat_plus (a1, b1, c1, d1) (a2, b2, c2, d2) = (a1+a2, b1+b2, c1+c2, d1+d2)"
	+
	+fun mat_minus :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex_mat" (infixl "-\<^sub>m\<^sub>m" 100) where
	+ "mat_minus (a1, b1, c1, d1) (a2, b2, c2, d2) = (a1-a2, b1-b2, c1-c2, d1-d2)"
	+
	+fun mat_uminus :: "complex_mat \<Rightarrow> complex_mat" where
	+ "mat_uminus (a, b, c, d) = (-a, -b, -c, -d)"
	+
	+lemma nonzero_mult_real:
	+ assumes "A \<noteq> mat_zero" and "k \<noteq> 0"
	+ shows "k *\<^sub>s\<^sub>m A \<noteq> mat_zero"
	+ using assms
	+ by (cases A) simp
	+
	+text \<open>Matrix multiplication.\<close>
	+
	+fun mult_mm :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex_mat" (infixl "*\<^sub>m\<^sub>m" 100) where
	+ "(a1, b1, c1, d1) *\<^sub>m\<^sub>m (a2, b2, c2, d2) =
	+ (a1a2 + b1c2, a1b2 + b1d2, c1a2+d1c2, c1b2+d1d2)"
	+
	+lemma mult_mm_assoc:
	+ shows "A \<^sub>m\<^sub>m (B \<^sub>m\<^sub>m C) = (A \<^sub>m\<^sub>m B) \<^sub>m\<^sub>m C"
	+ by (cases A, cases B, cases C) (auto simp add: field_simps)
	+
	+lemma mult_assoc_5:
	+ shows "A \<^sub>m\<^sub>m (B \<^sub>m\<^sub>m C \<^sub>m\<^sub>m D) \<^sub>m\<^sub>m E = (A \<^sub>m\<^sub>m B) \<^sub>m\<^sub>m C \<^sub>m\<^sub>m (D \<^sub>m\<^sub>m E)"
	+ by (simp only: mult_mm_assoc)
	+
	+lemma mat_zero_r [simp]:
	+ shows "A *\<^sub>m\<^sub>m mat_zero = mat_zero"
	+ by (cases A) simp
	+
	+lemma mat_zero_l [simp]:
	+ shows "mat_zero *\<^sub>m\<^sub>m A = mat_zero"
	+ by (cases A) simp
	+
	+definition eye :: "complex_mat" where
	+ [simp]: "eye = (1, 0, 0, 1)"
	+
	+lemma mat_eye_l:
	+ shows "eye *\<^sub>m\<^sub>m A = A"
	+ by (cases A) auto
	+
	+lemma mat_eye_r:
	+ shows "A *\<^sub>m\<^sub>m eye = A"
	+ by (cases A) auto
	+
	+lemma mult_mm_sm [simp]:
	+ shows "A \<^sub>m\<^sub>m (k \<^sub>s\<^sub>m B) = k \<^sub>s\<^sub>m (A \<^sub>m\<^sub>m B)"
	+ by (cases A, cases B) (simp add: field_simps)
	+
	+lemma mult_sm_mm [simp]:
	+ shows "(k \<^sub>s\<^sub>m A) \<^sub>m\<^sub>m B = k \<^sub>s\<^sub>m (A \<^sub>m\<^sub>m B)"
	+ by (cases A, cases B) (simp add: field_simps)
	+
	+lemma mult_sm_eye_mm [simp]:
	+ shows "k \<^sub>s\<^sub>m eye \<^sub>m\<^sub>m A = k *\<^sub>s\<^sub>m A"
	+ by (cases A) simp
	+
	+text \<open>Matrix determinant\<close>
	+
	+fun mat_det where "mat_det (a, b, c, d) = ad - bc"
	+
	+lemma mat_det_mult [simp]:
	+ shows "mat_det (A \<^sub>m\<^sub>m B) = mat_det A mat_det B"
	+ by (cases A, cases B) (auto simp add: field_simps)
	+
	+lemma mat_det_mult_sm [simp]:
	+ shows "mat_det (k \<^sub>s\<^sub>m A) = (kk) * mat_det A"
	+ by (cases A) (auto simp add: field_simps)
	+
	+text \<open>Matrix inverse\<close>
	+
	+fun mat_inv :: "complex_mat \<Rightarrow> complex_mat" where
	+ "mat_inv (a, b, c, d) = (1/(ad - bc)) *\<^sub>s\<^sub>m (d, -b, -c, a)"
	+
	+lemma mat_inv_r:
	+ assumes "mat_det A \<noteq> 0"
	+ shows "A *\<^sub>m\<^sub>m (mat_inv A) = eye"
	+ using assms
	+proof (cases A, auto simp add: field_simps)
	+ fix a b c d :: complex
	+ assume "a * (a * (d * d)) + b * (b * (c * c)) = a * (b * (c * (d * 2)))"
	+ hence "(ad - bc)(ad - b*c) = 0"
	+ by (auto simp add: field_simps)
	+ hence : "ad - b*c = 0"
	+ by auto
	+ assume "ad \<noteq> bc"
	+ with * show False
	+ by auto
	+qed
	+
	+lemma mat_inv_l:
	+ assumes "mat_det A \<noteq> 0"
	+ shows "(mat_inv A) *\<^sub>m\<^sub>m A = eye"
	+ using assms
	+proof (cases A, auto simp add: field_simps)
	+ fix a b c d :: complex
	+ assume "a * (a * (d * d)) + b * (b * (c * c)) = a * (b * (c * (d * 2)))"
	+ hence "(ad - bc)(ad - b*c) = 0"
	+ by (auto simp add: field_simps)
	+ hence : "ad - b*c = 0"
	+ by auto
	+ assume "ad \<noteq> bc"
	+ with * show False
	+ by auto
	+qed
	+
	+lemma mat_det_inv:
	+ assumes "mat_det A \<noteq> 0"
	+ shows "mat_det (mat_inv A) = 1 / mat_det A"
	+proof-
	+ have "mat_det eye = mat_det A * mat_det (mat_inv A)"
	+ using mat_inv_l[OF assms, symmetric]
	+ by simp
	+ thus ?thesis
	+ using assms
	+ by (simp add: field_simps)
	+qed
	+
	+lemma mult_mm_inv_l:
	+ assumes "mat_det A \<noteq> 0" and "A *\<^sub>m\<^sub>m B = C"
	+ shows "B = mat_inv A *\<^sub>m\<^sub>m C"
	+ using assms mat_eye_l[of B]
	+ by (auto simp add: mult_mm_assoc mat_inv_l)
	+
	+lemma mult_mm_inv_r:
	+ assumes "mat_det B \<noteq> 0" and "A *\<^sub>m\<^sub>m B = C"
	+ shows "A = C *\<^sub>m\<^sub>m mat_inv B"
	+ using assms mat_eye_r[of A]
	+ by (auto simp add: mult_mm_assoc[symmetric] mat_inv_r)
	+
	+lemma mult_mm_non_zero_l:
	+ assumes "mat_det A \<noteq> 0" and "B \<noteq> mat_zero"
	+ shows "A *\<^sub>m\<^sub>m B \<noteq> mat_zero"
	+ using assms mat_zero_r
	+ using mult_mm_inv_l[OF assms(1), of B mat_zero]
	+ by auto
	+
	+lemma mat_inv_mult_mm:
	+ assumes "mat_det A \<noteq> 0" and "mat_det B \<noteq> 0"
	+ shows "mat_inv (A \<^sub>m\<^sub>m B) = mat_inv B \<^sub>m\<^sub>m mat_inv A"
	+ using assms
	+proof-
	+ have "(A \<^sub>m\<^sub>m B) \<^sub>m\<^sub>m (mat_inv B *\<^sub>m\<^sub>m mat_inv A) = eye"
	+ using assms
	+ by (metis mat_inv_r mult_mm_assoc mult_mm_inv_r)
	+ thus ?thesis
	+ using mult_mm_inv_l[of "A \<^sub>m\<^sub>m B" "mat_inv B \<^sub>m\<^sub>m mat_inv A" eye] assms mat_eye_r
	+ by simp
	+qed
	+
	+lemma mult_mm_cancel_l:
	+ assumes "mat_det M \<noteq> 0" "M \<^sub>m\<^sub>m A = M \<^sub>m\<^sub>m B"
	+ shows "A = B"
	+ using assms
	+ by (metis mult_mm_inv_l)
	+
	+lemma mult_mm_cancel_r:
	+ assumes "mat_det M \<noteq> 0" "A \<^sub>m\<^sub>m M = B \<^sub>m\<^sub>m M"
	+ shows "A = B"
	+ using assms
	+ by (metis mult_mm_inv_r)
	+
	+lemma mult_mm_non_zero_r:
	+ assumes "A \<noteq> mat_zero" and "mat_det B \<noteq> 0"
	+ shows "A *\<^sub>m\<^sub>m B \<noteq> mat_zero"
	+ using assms mat_zero_l
	+ using mult_mm_inv_r[OF assms(2), of A mat_zero]
	+ by auto
	+
	+lemma mat_inv_mult_sm:
	+ assumes "k \<noteq> 0"
	+ shows "mat_inv (k \<^sub>s\<^sub>m A) = (1 / k) \<^sub>s\<^sub>m mat_inv A"
	+proof-
	+ obtain a b c d where "A = (a, b, c, d)"
	+ by (cases A) auto
	+ thus ?thesis
	+ using assms
	+ by auto (subst mult.assoc[of k a "kd"], subst mult.assoc[of k b "kc"], subst right_diff_distrib[of k "a(kd)" "b(kc)", symmetric], simp, simp add: field_simps)+
	+qed
	+
	+lemma mat_inv_inv [simp]:
	+ assumes "mat_det M \<noteq> 0"
	+ shows "mat_inv (mat_inv M) = M"
	+proof-
	+ have "mat_inv M *\<^sub>m\<^sub>m M = eye"
	+ using mat_inv_l[OF assms]
	+ by simp
	+ thus ?thesis
	+ using assms mat_det_inv[of M]
	+ using mult_mm_inv_l[of "mat_inv M" M eye] mat_eye_r
	+ by (auto simp del: eye_def)
	+qed
	+
	+text \<open>Matrix transpose\<close>
	+
	+fun mat_transpose where
	+ "mat_transpose (a, b, c, d) = (a, c, b, d)"
	+
	+lemma mat_t_mat_t [simp]:
	+ shows "mat_transpose (mat_transpose A) = A"
	+ by (cases A) auto
	+
	+lemma mat_t_mult_sm [simp]:
	+ shows "mat_transpose (k \<^sub>s\<^sub>m A) = k \<^sub>s\<^sub>m (mat_transpose A)"
	+ by (cases A) simp
	+
	+lemma mat_t_mult_mm [simp]:
	+ shows "mat_transpose (A \<^sub>m\<^sub>m B) = mat_transpose B \<^sub>m\<^sub>m mat_transpose A"
	+ by (cases A, cases B) auto
	+
	+lemma mat_inv_transpose:
	+ shows "mat_transpose (mat_inv M) = mat_inv (mat_transpose M)"
	+ by (cases M) auto
	+
	+lemma mat_det_transpose [simp]:
	+ fixes M :: "complex_mat"
	+ shows "mat_det (mat_transpose M) = mat_det M"
	+ by (cases M) auto
	+
	+text \<open>Diagonal matrices definition\<close>
	+
	+fun mat_diagonal where
	+ "mat_diagonal (A, B, C, D) = (B = 0 \<and> C = 0)"
	+
	+text \<open>Matrix conjugate\<close>
	+
	+fun mat_map where
	+ "mat_map f (a, b, c, d) = (f a, f b, f c, f d)"
	+
	+definition mat_cnj where
	+ "mat_cnj = mat_map cnj"
	+
	+lemma mat_cnj_cnj [simp]:
	+ shows "mat_cnj (mat_cnj A) = A"
	+ unfolding mat_cnj_def
	+ by (cases A) auto
	+
	+lemma mat_cnj_sm [simp]:
	+ shows "mat_cnj (k \<^sub>s\<^sub>m A) = cnj k \<^sub>s\<^sub>m (mat_cnj A)"
	+ by (cases A) (simp add: mat_cnj_def)
	+
	+lemma mat_det_cnj [simp]:
	+ shows "mat_det (mat_cnj A) = cnj (mat_det A)"
	+ by (cases A) (simp add: mat_cnj_def)
	+
	+lemma nonzero_mat_cnj:
	+ shows "mat_cnj A = mat_zero \<longleftrightarrow> A = mat_zero"
	+ by (cases A) (auto simp add: mat_cnj_def)
	+
	+lemma mat_inv_cnj:
	+ shows "mat_cnj (mat_inv M) = mat_inv (mat_cnj M)"
	+ unfolding mat_cnj_def
	+ by (cases M) auto
	+
	+text \<open>Matrix adjoint - the conjugate traspose matrix ($A^* = \overline{A^t}$)\<close>
	+
	+definition mat_adj where
	+ "mat_adj A = mat_cnj (mat_transpose A)"
	+
	+lemma mat_adj_mult_mm [simp]:
	+ shows "mat_adj (A \<^sub>m\<^sub>m B) = mat_adj B \<^sub>m\<^sub>m mat_adj A"
	+ by (cases A, cases B) (auto simp add: mat_adj_def mat_cnj_def)
	+
	+lemma mat_adj_mult_sm [simp]:
	+ shows "mat_adj (k \<^sub>s\<^sub>m A) = cnj k \<^sub>s\<^sub>m mat_adj A"
	+ by (cases A) (auto simp add: mat_adj_def mat_cnj_def)
	+
	+lemma mat_det_adj:
	+ shows "mat_det (mat_adj A) = cnj (mat_det A)"
	+ by (cases A) (auto simp add: mat_adj_def mat_cnj_def)
	+
	+lemma mat_adj_inv:
	+ assumes "mat_det M \<noteq> 0"
	+ shows "mat_adj (mat_inv M) = mat_inv (mat_adj M)"
	+ by (cases M) (auto simp add: mat_adj_def mat_cnj_def)
	+
	+lemma mat_transpose_mat_cnj:
	+ shows "mat_transpose (mat_cnj A) = mat_adj A"
	+ by (cases A) (auto simp add: mat_adj_def mat_cnj_def)
	+
	+lemma mat_adj_adj [simp]:
	+ shows "mat_adj (mat_adj A) = A"
	+ unfolding mat_adj_def
	+ by (subst mat_transpose_mat_cnj) (simp add: mat_adj_def)
	+
	+lemma mat_adj_eye [simp]:
	+ shows "mat_adj eye = eye"
	+ by (auto simp add: mat_adj_def mat_cnj_def)
	+
	+text \<open>Matrix trace\<close>
	+
	+fun mat_trace where
	+ "mat_trace (a, b, c, d) = a + d"
	+
	+text \<open>Multiplication of matrix and a vector\<close>
	+
	+fun mult_mv :: "complex_mat \<Rightarrow> complex_vec \<Rightarrow> complex_vec" (infixl "*\<^sub>m\<^sub>v" 100) where
	+ "(a, b, c, d) \<^sub>m\<^sub>v (x, y) = (xa + yb, xc + y*d)"
	+
	+fun mult_vm :: "complex_vec \<Rightarrow> complex_mat \<Rightarrow> complex_vec" (infixl "*\<^sub>v\<^sub>m" 100) where
	+ "(x, y) \<^sub>v\<^sub>m (a, b, c, d) = (xa + yc, xb + y*d)"
	+
	+lemma eye_mv_l [simp]:
	+ shows "eye *\<^sub>m\<^sub>v v = v"
	+ by (cases v) simp
	+
	+lemma mult_mv_mv [simp]:
	+ shows "B \<^sub>m\<^sub>v (A \<^sub>m\<^sub>v v) = (B \<^sub>m\<^sub>m A) \<^sub>m\<^sub>v v"
	+ by (cases v, cases A, cases B) (auto simp add: field_simps)
	+
	+lemma mult_vm_vm [simp]:
	+ shows "(v \<^sub>v\<^sub>m A) \<^sub>v\<^sub>m B = v \<^sub>v\<^sub>m (A \<^sub>m\<^sub>m B)"
	+ by (cases v, cases A, cases B) (auto simp add: field_simps)
	+
	+lemma mult_mv_inv:
	+ assumes "x = A *\<^sub>m\<^sub>v y" and "mat_det A \<noteq> 0"
	+ shows "y = (mat_inv A) *\<^sub>m\<^sub>v x"
	+ using assms
	+ by (cases y) (simp add: mat_inv_l)
	+
	+lemma mult_vm_inv:
	+ assumes "x = y *\<^sub>v\<^sub>m A" and "mat_det A \<noteq> 0"
	+ shows "y = x *\<^sub>v\<^sub>m (mat_inv A) "
	+ using assms
	+ by (cases y) (simp add: mat_inv_r)
	+
	+lemma mult_mv_cancel_l:
	+ assumes "mat_det A \<noteq> 0" and "A \<^sub>m\<^sub>v v = A \<^sub>m\<^sub>v v'"
	+ shows "v = v'"
	+ using assms
	+ using mult_mv_inv
	+ by blast
	+
	+lemma mult_vm_cancel_r:
	+ assumes "mat_det A \<noteq> 0" and "v \<^sub>v\<^sub>m A = v' \<^sub>v\<^sub>m A"
	+ shows "v = v'"
	+ using assms
	+ using mult_vm_inv
	+ by blast
	+
	+lemma vec_zero_l [simp]:
	+ shows "A *\<^sub>m\<^sub>v vec_zero = vec_zero"
	+ by (cases A) simp
	+
	+lemma vec_zero_r [simp]:
	+ shows "vec_zero *\<^sub>v\<^sub>m A = vec_zero"
	+ by (cases A) simp
	+
	+lemma mult_mv_nonzero:
	+ assumes "v \<noteq> vec_zero" and "mat_det A \<noteq> 0"
	+ shows "A *\<^sub>m\<^sub>v v \<noteq> vec_zero"
	+ apply (rule ccontr)
	+ using assms mult_mv_inv[of vec_zero A v] mat_inv_l vec_zero_l
	+ by auto
	+
	+lemma mult_vm_nonzero:
	+ assumes "v \<noteq> vec_zero" and "mat_det A \<noteq> 0"
	+ shows "v *\<^sub>v\<^sub>m A \<noteq> vec_zero"
	+ apply (rule ccontr)
	+ using assms mult_vm_inv[of vec_zero v A] mat_inv_r vec_zero_r
	+ by auto
	+
	+lemma mult_sv_mv:
	+ shows "k \<^sub>s\<^sub>v (A \<^sub>m\<^sub>v v) = (A \<^sub>m\<^sub>v (k \<^sub>s\<^sub>v v))"
	+ by (cases A, cases v) (simp add: field_simps)
	+
	+lemma mult_mv_mult_vm:
	+ shows "A \<^sub>m\<^sub>v x = x \<^sub>v\<^sub>m (mat_transpose A)"
	+ by (cases A, cases x) auto
	+
	+lemma mult_mv_vv:
	+ shows "A \<^sub>m\<^sub>v v1 \<^sub>v\<^sub>v v2 = v1 \<^sub>v\<^sub>v (mat_transpose A \<^sub>m\<^sub>v v2)"
	+ by (cases v1, cases v2, cases A) (auto simp add: field_simps)
	+
	+lemma mult_vv_mv:
	+ shows "x \<^sub>v\<^sub>v (A \<^sub>m\<^sub>v y) = (x \<^sub>v\<^sub>m A) \<^sub>v\<^sub>v y"
	+ by (cases x, cases y, cases A) (auto simp add: field_simps)
	+
	+lemma vec_cnj_mult_mv:
	+ shows "vec_cnj (A \<^sub>m\<^sub>v x) = (mat_cnj A) \<^sub>m\<^sub>v (vec_cnj x)"
	+ by (cases A, cases x) (auto simp add: vec_cnj_def mat_cnj_def)
	+
	+lemma vec_cnj_mult_vm:
	+ shows "vec_cnj (v \<^sub>v\<^sub>m A) = vec_cnj v \<^sub>v\<^sub>m mat_cnj A"
	+ unfolding vec_cnj_def mat_cnj_def
	+ by (cases A, cases v, auto)
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Eigenvalues and eigenvectors\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+definition eigenpair where
	+ [simp]: "eigenpair k v H \<longleftrightarrow> v \<noteq> vec_zero \<and> H \<^sub>m\<^sub>v v = k \<^sub>s\<^sub>v v"
	+
	+definition eigenval where
	+ [simp]: "eigenval k H \<longleftrightarrow> (\<exists> v. v \<noteq> vec_zero \<and> H \<^sub>m\<^sub>v v = k \<^sub>s\<^sub>v v)"
	+
	+lemma eigen_equation:
	+ shows "eigenval k H \<longleftrightarrow> k\<^sup>2 - mat_trace H * k + mat_det H = 0" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof-
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ show ?thesis
	+ proof
	+ assume ?lhs
	+ then obtain v where "v \<noteq> vec_zero" "H \<^sub>m\<^sub>v v = k \<^sub>s\<^sub>v v"
	+ unfolding eigenval_def
	+ by blast
	+ obtain v1 v2 where vv: "v = (v1, v2)"
	+ by (cases v) auto
	+ from \<open>H \<^sub>m\<^sub>v v = k \<^sub>s\<^sub>v v\<close> have "(H -\<^sub>m\<^sub>m (k \<^sub>s\<^sub>m eye)) \<^sub>m\<^sub>v v = vec_zero"
	+ using HH vv
	+ by (auto simp add: field_simps)
	+ hence "mat_det (H -\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m eye)) = 0"
	+ using \<open>v \<noteq> vec_zero\<close> vv HH
	+ using regular_homogenous_system[of "A - k" B C "D - k" v1 v2]
	+ unfolding det2_def
	+ by (auto simp add: field_simps)
	+ thus ?rhs
	+ using HH
	+ by (auto simp add: power2_eq_square field_simps)
	+ next
	+ assume ?rhs
	+ hence : "mat_det (H -\<^sub>m\<^sub>m (k \<^sub>s\<^sub>m eye)) = 0"
	+ using HH
	+ by (auto simp add: field_simps power2_eq_square)
	+ show ?lhs
	+ proof (cases "H -\<^sub>m\<^sub>m (k *\<^sub>s\<^sub>m eye) = mat_zero")
	+ case True
	+ thus ?thesis
	+ using HH
	+ by (auto) (rule_tac x=1 in exI, simp)
	+ next
	+ case False
	+ hence "(A - k \<noteq> 0 \<or> B \<noteq> 0) \<or> (D - k \<noteq> 0 \<or> C \<noteq> 0)"
	+ using HH
	+ by auto
	+ thus ?thesis
	+ proof
	+ assume "A - k \<noteq> 0 \<or> B \<noteq> 0"
	+ hence "C * B + (D - k) * (k - A) = 0"
	+ using * singular_system[of "A-k" "D-k" B C "(0, 0)" 0 0 "(B, k-A)"] HH
	+ by (auto simp add: field_simps)
	+ hence "(B, k-A) \<noteq> vec_zero" "(H -\<^sub>m\<^sub>m (k \<^sub>s\<^sub>m eye)) \<^sub>m\<^sub>v (B, k-A) = vec_zero"
	+ using HH \<open>A - k \<noteq> 0 \<or> B \<noteq> 0\<close>
	+ by (auto simp add: field_simps)
	+ then obtain v where "v \<noteq> vec_zero \<and> (H -\<^sub>m\<^sub>m (k \<^sub>s\<^sub>m eye)) \<^sub>m\<^sub>v v = vec_zero"
	+ by blast
	+ thus ?thesis
	+ using HH
	+ unfolding eigenval_def
	+ by (rule_tac x="v" in exI) (case_tac v, simp add: field_simps)
	+ next
	+ assume "D - k \<noteq> 0 \<or> C \<noteq> 0"
	+ hence "C * B + (D - k) * (k - A) = 0"
	+ using * singular_system[of "D-k" "A-k" C B "(0, 0)" 0 0 "(C, k-D)"] HH
	+ by (auto simp add: field_simps)
	+ hence "(k-D, C) \<noteq> vec_zero" "(H -\<^sub>m\<^sub>m (k \<^sub>s\<^sub>m eye)) \<^sub>m\<^sub>v (k-D, C) = vec_zero"
	+ using HH \<open>D - k \<noteq> 0 \<or> C \<noteq> 0\<close>
	+ by (auto simp add: field_simps)
	+ then obtain v where "v \<noteq> vec_zero \<and> (H -\<^sub>m\<^sub>m (k \<^sub>s\<^sub>m eye)) \<^sub>m\<^sub>v v = vec_zero"
	+ by blast
	+ thus ?thesis
	+ using HH
	+ unfolding eigenval_def
	+ by (rule_tac x="v" in exI) (case_tac v, simp add: field_simps)
	+ qed
	+ qed
	+ qed
	+qed
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsubsection \<open>Bilinear and Quadratic forms, Congruence, and Similarity\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>Bilinear forms\<close>
	+
	+definition bilinear_form where
	+ [simp]: "bilinear_form v1 v2 H = (vec_cnj v1) \<^sub>v\<^sub>m H \<^sub>v\<^sub>v v2"
	+
	+lemma bilinear_form_scale_m:
	+ shows "bilinear_form v1 v2 (k \<^sub>s\<^sub>m H) = k bilinear_form v1 v2 H"
	+ by (cases v1, cases v2, cases H) (simp add: vec_cnj_def field_simps)
	+
	+lemma bilinear_form_scale_v1:
	+ shows "bilinear_form (k \<^sub>s\<^sub>v v1) v2 H = cnj k bilinear_form v1 v2 H"
	+ by (cases v1, cases v2, cases H) (simp add: vec_cnj_def field_simps)
	+
	+lemma bilinear_form_scale_v2:
	+ shows "bilinear_form v1 (k \<^sub>s\<^sub>v v2) H = k bilinear_form v1 v2 H"
	+ by (cases v1, cases v2, cases H) (simp add: vec_cnj_def field_simps)
	+
	+text \<open>Quadratic forms\<close>
	+
	+definition quad_form where
	+ [simp]: "quad_form v H = (vec_cnj v) \<^sub>v\<^sub>m H \<^sub>v\<^sub>v v"
	+
	+lemma quad_form_bilinear_form:
	+ shows "quad_form v H = bilinear_form v v H"
	+ by simp
	+
	+lemma quad_form_scale_v:
	+ shows "quad_form (k \<^sub>s\<^sub>v v) H = cor ((cmod k)\<^sup>2) quad_form v H"
	+ using bilinear_form_scale_v1 bilinear_form_scale_v2
	+ by (simp add: complex_mult_cnj_cmod field_simps)
	+
	+lemma quad_form_scale_m:
	+ shows "quad_form v (k \<^sub>s\<^sub>m H) = k quad_form v H"
	+ using bilinear_form_scale_m
	+ by simp
	+
	+lemma cnj_quad_form [simp]:
	+ shows "cnj (quad_form z H) = quad_form z (mat_adj H)"
	+ by (cases H, cases z) (auto simp add: mat_adj_def mat_cnj_def vec_cnj_def field_simps)
	+
	+text \<open>Matrix congruence\<close>
	+
	+text \<open>Two matrices are congruent iff they represent the same quadratic form with respect to different
	+bases (for example if one circline can be transformed to another by a Möbius trasformation).\<close>
	+
	+definition congruence where
	+ [simp]: "congruence M H \<equiv> mat_adj M \<^sub>m\<^sub>m H \<^sub>m\<^sub>m M"
	+
	+lemma congruence_nonzero:
	+ assumes "H \<noteq> mat_zero" and "mat_det M \<noteq> 0"
	+ shows "congruence M H \<noteq> mat_zero"
	+ using assms
	+ unfolding congruence_def
	+ by (subst mult_mm_non_zero_r, subst mult_mm_non_zero_l) (auto simp add: mat_det_adj)
	+
	+lemma congruence_congruence:
	+ shows "congruence M1 (congruence M2 H) = congruence (M2 *\<^sub>m\<^sub>m M1) H"
	+ unfolding congruence_def
	+ apply (subst mult_mm_assoc)
	+ apply (subst mult_mm_assoc)
	+ apply (subst mat_adj_mult_mm)
	+ apply (subst mult_mm_assoc)
	+ by simp
	+
	+lemma congruence_eye [simp]:
	+ shows "congruence eye H = H"
	+ by (cases H) (simp add: mat_adj_def mat_cnj_def)
	+
	+lemma congruence_congruence_inv [simp]:
	+ assumes "mat_det M \<noteq> 0"
	+ shows "congruence M (congruence (mat_inv M) H) = H"
	+ using assms congruence_congruence[of M "mat_inv M" H]
	+ using mat_inv_l[of M] mat_eye_l mat_eye_r
	+ unfolding congruence_def
	+ by (simp del: eye_def)
	+
	+lemma congruence_inv:
	+ assumes "mat_det M \<noteq> 0" and "congruence M H = H'"
	+ shows "congruence (mat_inv M) H' = H"
	+ using assms
	+ using \<open>mat_det M \<noteq> 0\<close> mult_mm_inv_l[of "mat_adj M" "H *\<^sub>m\<^sub>m M" "H'"]
	+ using mult_mm_inv_r[of M "H" "mat_inv (mat_adj M) *\<^sub>m\<^sub>m H'"]
	+ by (simp add: mat_det_adj mult_mm_assoc mat_adj_inv)
	+
	+lemma congruence_scale_m [simp]:
	+ shows "congruence M (k \<^sub>s\<^sub>m H) = k \<^sub>s\<^sub>m (congruence M H)"
	+ by (cases M, cases H) (auto simp add: mat_adj_def mat_cnj_def field_simps)
	+
	+lemma inj_congruence:
	+ assumes "mat_det M \<noteq> 0" and "congruence M H = congruence M H'"
	+ shows "H = H'"
	+proof-
	+ have "H \<^sub>m\<^sub>m M = H' \<^sub>m\<^sub>m M "
	+ using assms
	+ using mult_mm_cancel_l[of "mat_adj M" "H \<^sub>m\<^sub>m M" "H' \<^sub>m\<^sub>m M"]
	+ by (simp add: mat_det_adj mult_mm_assoc)
	+ thus ?thesis
	+ using assms
	+ using mult_mm_cancel_r[of "M" "H" "H'"]
	+ by simp
	+qed
	+
	+lemma mat_det_congruence [simp]:
	+ "mat_det (congruence M H) = (cor ((cmod (mat_det M))\<^sup>2)) * mat_det H"
	+ using complex_mult_cnj_cmod[of "mat_det M"]
	+ by (auto simp add: mat_det_adj field_simps)
	+
	+lemma det_sgn_congruence [simp]:
	+ assumes "mat_det M \<noteq> 0"
	+ shows "sgn (mat_det (congruence M H)) = sgn (mat_det H)"
	+ using assms
	+ by (subst mat_det_congruence, auto simp add: sgn_mult power2_eq_square) (simp add: sgn_of_real)
	+
	+lemma Re_det_sgn_congruence [simp]:
	+ assumes "mat_det M \<noteq> 0"
	+ shows "sgn (Re (mat_det (congruence M H))) = sgn (Re (mat_det H))"
	+proof-
	+ have : "Re (mat_det (congruence M H)) = (cmod (mat_det M))\<^sup>2 Re (mat_det H)"
	+ by (subst mat_det_congruence, subst Re_mult_real, rule Im_complex_of_real) (subst Re_complex_of_real, simp)
	+ show ?thesis
	+ using assms
	+ by (subst *) (auto simp add: sgn_mult)
	+qed
	+
	+text \<open>Transforming a matrix $H$ by a regular matrix $M$ preserves its bilinear and quadratic forms.\<close>
	+
	+lemma bilinear_form_congruence [simp]:
	+ assumes "mat_det M \<noteq> 0"
	+ shows "bilinear_form (M \<^sub>m\<^sub>v v1) (M \<^sub>m\<^sub>v v2) (congruence (mat_inv M) H) =
	+ bilinear_form v1 v2 H"
	+proof-
	+ have "mat_det (mat_adj M) \<noteq> 0"
	+ using assms
	+ by (simp add: mat_det_adj)
	+ show ?thesis
	+ unfolding bilinear_form_def congruence_def
	+ apply (subst mult_mv_mult_vm)
	+ apply (subst vec_cnj_mult_vm)
	+ apply (subst mat_adj_def[symmetric])
	+ apply (subst mult_vm_vm)
	+ apply (subst mult_vv_mv)
	+ apply (subst mult_vm_vm)
	+ apply (subst mat_adj_inv[OF \<open>mat_det M \<noteq> 0\<close>])
	+ apply (subst mult_assoc_5)
	+ apply (subst mat_inv_r[OF \<open>mat_det (mat_adj M) \<noteq> 0\<close>])
	+ apply (subst mat_inv_l[OF \<open>mat_det M \<noteq> 0\<close>])
	+ apply (subst mat_eye_l, subst mat_eye_r)
	+ by simp
	+qed
	+
	+lemma quad_form_congruence [simp]:
	+ assumes "mat_det M \<noteq> 0"
	+ shows "quad_form (M *\<^sub>m\<^sub>v z) (congruence (mat_inv M) H) = quad_form z H"
	+ using bilinear_form_congruence[OF assms]
	+ by simp
	+
	+
	+text \<open>Similar matrices\<close>
	+
	+text \<open>Two matrices are similar iff they represent the same linear operator with respect to (possibly)
	+different bases (e.g., if they represent the same Möbius transformation after changing the
	+coordinate system)\<close>
	+
	+definition similarity where
	+ "similarity A M = mat_inv A \<^sub>m\<^sub>m M \<^sub>m\<^sub>m A"
	+
	+lemma mat_det_similarity [simp]:
	+ assumes "mat_det A \<noteq> 0"
	+ shows "mat_det (similarity A M) = mat_det M"
	+ using assms
	+ unfolding similarity_def
	+ by (simp add: mat_det_inv)
	+
	+lemma mat_trace_similarity [simp]:
	+ assumes "mat_det A \<noteq> 0"
	+ shows "mat_trace (similarity A M) = mat_trace M"
	+proof-
	+ obtain a b c d where AA: "A = (a, b, c, d)"
	+ by (cases A) auto
	+ obtain mA mB mC mD where MM: "M = (mA, mB, mC, mD)"
	+ by (cases M) auto
	+ have "mA * (a * d) / (a * d - b * c) + mD * (a * d) / (a * d - b * c) =
	+ mA + mD + mA * (b * c) / (a * d - b * c) + mD * (b * c) / (a * d - b * c)"
	+ using assms AA
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using AA MM
	+ by (simp add: field_simps similarity_def)
	+qed
	+
	+lemma similarity_eye [simp]:
	+ shows "similarity eye M = M"
	+ unfolding similarity_def
	+ using mat_eye_l mat_eye_r
	+ by auto
	+
	+
	+lemma similarity_eye' [simp]:
	+ shows "similarity (1, 0, 0, 1) M = M"
	+ unfolding eye_def[symmetric]
	+ by (simp del: eye_def)
	+
	+lemma similarity_comp [simp]:
	+ assumes "mat_det A1 \<noteq> 0" and "mat_det A2 \<noteq> 0"
	+ shows "similarity A1 (similarity A2 M) = similarity (A2*\<^sub>m\<^sub>mA1) M"
	+ using assms
	+ unfolding similarity_def
	+ by (simp add: mult_mm_assoc mat_inv_mult_mm)
	+
	+lemma similarity_inv:
	+ assumes "similarity A M1 = M2" and "mat_det A \<noteq> 0"
	+ shows "similarity (mat_inv A) M2 = M1"
	+ using assms
	+ unfolding similarity_def
	+ by (metis mat_det_mult mult_mm_assoc mult_mm_inv_l mult_mm_inv_r mult_zero_left)
	+
	+end
	diff --git a/thys/Complex_Geometry/Moebius.thy b/thys/Complex_Geometry/Moebius.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Moebius.thy
	@@ -0,0 +1,1535 @@
	+(* -------------------------------------------------------------------------- *)
	+section \<open>Möbius transformations\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Möbius transformations (also called homographic, linear fractional, or bilinear
	+transformations) are the fundamental transformations of the extended complex plane. Here they are
	+introduced algebraically. Each transformation is represented by a regular (non-singular,
	+non-degenerate) $2\times 2$ matrix that acts linearly on homogeneous coordinates. As proportional
	+homogeneous coordinates represent same points of $\mathbb{\overline{C}}$, proportional matrices will
	+represent the same Möbius transformation.\<close>
	+
	+theory Moebius
	+imports Homogeneous_Coordinates
	+begin
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Definition of Möbius transformations\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+typedef moebius_mat = "{M::complex_mat. mat_det M \<noteq> 0}"
	+ by (rule_tac x="eye" in exI, simp)
	+
	+setup_lifting type_definition_moebius_mat
	+
	+definition moebius_cmat_eq :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> bool" where
	+ [simp]: "moebius_cmat_eq A B \<longleftrightarrow> (\<exists> k::complex. k \<noteq> 0 \<and> B = k *\<^sub>s\<^sub>m A)"
	+
	+lift_definition moebius_mat_eq :: "moebius_mat \<Rightarrow> moebius_mat \<Rightarrow> bool" is moebius_cmat_eq
	+ done
	+
	+lemma moebius_mat_eq_refl [simp]:
	+ shows "moebius_mat_eq x x"
	+ by transfer simp
	+
	+quotient_type moebius = moebius_mat / moebius_mat_eq
	+proof (rule equivpI)
	+ show "reflp moebius_mat_eq"
	+ unfolding reflp_def
	+ by transfer auto
	+next
	+ show "symp moebius_mat_eq"
	+ unfolding symp_def
	+ by transfer (auto simp add: symp_def, rule_tac x="1/k" in exI, simp)
	+next
	+ show "transp moebius_mat_eq"
	+ unfolding transp_def
	+ by transfer (auto simp add: transp_def, rule_tac x="ka*k" in exI, simp)
	+qed
	+
	+definition mk_moebius_cmat :: "complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> complex_mat" where
	+ [simp]: "mk_moebius_cmat a b c d =
	+ (let M = (a, b, c, d)
	+ in if mat_det M \<noteq> 0 then
	+ M
	+ else
	+ eye)"
	+
	+lift_definition mk_moebius_mat :: "complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> moebius_mat" is mk_moebius_cmat
	+ by simp
	+
	+lift_definition mk_moebius :: "complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> moebius" is mk_moebius_mat
	+ done
	+
	+lemma ex_mk_moebius:
	+ shows "\<exists> a b c d. M = mk_moebius a b c d \<and> mat_det (a, b, c, d) \<noteq> 0"
	+proof (transfer, transfer)
	+ fix M :: complex_mat
	+ assume "mat_det M \<noteq> 0"
	+ obtain a b c d where "M = (a, b, c, d)"
	+ by (cases M, auto)
	+ hence "moebius_cmat_eq M (mk_moebius_cmat a b c d) \<and> mat_det (a, b, c, d) \<noteq> 0"
	+ using \<open>mat_det M \<noteq> 0\<close>
	+ by auto (rule_tac x=1 in exI, simp)
	+ thus "\<exists>a b c d. moebius_cmat_eq M (mk_moebius_cmat a b c d) \<and> mat_det (a, b, c, d) \<noteq> 0"
	+ by blast
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Action on points\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Möbius transformations are given as the action of Möbius group on the points of the
	+extended complex plane (in homogeneous coordinates).\<close>
	+
	+definition moebius_pt_cmat_cvec :: "complex_mat \<Rightarrow> complex_vec \<Rightarrow> complex_vec" where
	+ [simp]: "moebius_pt_cmat_cvec M z = M *\<^sub>m\<^sub>v z"
	+
	+lift_definition moebius_pt_mmat_hcoords :: "moebius_mat \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords" is moebius_pt_cmat_cvec
	+ by auto algebra+
	+
	+lift_definition moebius_pt :: "moebius \<Rightarrow> complex_homo \<Rightarrow> complex_homo" is moebius_pt_mmat_hcoords
	+proof transfer
	+ fix M M' x x'
	+ assume "moebius_cmat_eq M M'" "x \<approx>\<^sub>v x'"
	+ thus "moebius_pt_cmat_cvec M x \<approx>\<^sub>v moebius_pt_cmat_cvec M' x'"
	+ by (cases "M", cases "x", auto simp add: field_simps) (rule_tac x="k*ka" in exI, simp)
	+qed
	+
	+lemma bij_moebius_pt [simp]:
	+ shows "bij (moebius_pt M)"
	+ unfolding bij_def inj_on_def surj_def
	+proof safe
	+ fix x y
	+ assume "moebius_pt M x = moebius_pt M y"
	+ thus "x = y"
	+ proof (transfer, transfer)
	+ fix M x y
	+ assume "mat_det M \<noteq> 0" "moebius_pt_cmat_cvec M x \<approx>\<^sub>v moebius_pt_cmat_cvec M y"
	+ thus "x \<approx>\<^sub>v y"
	+ using mult_sv_mv[of _ M x] mult_mv_inv[of _ M]
	+ unfolding moebius_pt_cmat_cvec_def
	+ by (metis complex_cvec_eq_def)
	+ qed
	+next
	+ fix y
	+ show "\<exists>x. y = moebius_pt M x"
	+ proof (transfer, transfer)
	+ fix y :: complex_vec and M :: complex_mat
	+ assume *: "y \<noteq> vec_zero" "mat_det M \<noteq> 0"
	+ let ?iM = "mat_inv M"
	+ let ?x = "?iM *\<^sub>m\<^sub>v y"
	+ have "?x \<noteq> vec_zero"
	+ using *
	+ by (metis mat_det_mult mat_eye_r mat_inv_r mult_cancel_right1 mult_mv_nonzero)
	+ moreover
	+ have "y \<approx>\<^sub>v moebius_pt_cmat_cvec M ?x"
	+ by (simp del: eye_def add: mat_inv_r[OF \<open>mat_det M \<noteq> 0\<close>])
	+ ultimately
	+ show "\<exists>x\<in>{v. v \<noteq> vec_zero}. y \<approx>\<^sub>v moebius_pt_cmat_cvec M x"
	+ by (rule_tac x="?x" in bexI, simp_all)
	+ qed
	+qed
	+
	+lemma moebius_pt_eq_I:
	+ assumes "moebius_pt M z1 = moebius_pt M z2"
	+ shows "z1 = z2"
	+ using assms
	+ using bij_moebius_pt[of M]
	+ unfolding bij_def inj_on_def
	+ by blast
	+
	+lemma moebius_pt_neq_I [simp]:
	+ assumes "z1 \<noteq> z2"
	+ shows "moebius_pt M z1 \<noteq> moebius_pt M z2"
	+ using assms
	+ by (auto simp add: moebius_pt_eq_I)
	+
	+definition is_moebius :: "(complex_homo \<Rightarrow> complex_homo) \<Rightarrow> bool" where
	+ "is_moebius f \<longleftrightarrow> (\<exists> M. f = moebius_pt M)"
	+
	+text \<open>In the classic literature Möbius transformations are often expressed in the form
	+$\frac{az+b}{cz+d}$. The following lemma shows that when restricted to finite points, the action
	+of Möbius transformations is bilinear.\<close>
	+
	+lemma moebius_pt_bilinear:
	+ assumes "mat_det (a, b, c, d) \<noteq> 0"
	+ shows "moebius_pt (mk_moebius a b c d) z =
	+ (if z \<noteq> \<infinity>\<^sub>h then
	+ ((of_complex a) *\<^sub>h z +\<^sub>h (of_complex b)) :\<^sub>h
	+ ((of_complex c) *\<^sub>h z +\<^sub>h (of_complex d))
	+ else
	+ (of_complex a) :\<^sub>h
	+ (of_complex c))"
	+ unfolding divide_def
	+ using assms
	+proof (transfer, transfer)
	+ fix a b c d :: complex and z :: complex_vec
	+ obtain z1 z2 where zz: "z = (z1, z2)"
	+ by (cases z, auto)
	+ assume *: "mat_det (a, b, c, d) \<noteq> 0" "z \<noteq> vec_zero"
	+ let ?oc = "of_complex_cvec"
	+ show "moebius_pt_cmat_cvec (mk_moebius_cmat a b c d) z \<approx>\<^sub>v
	+ (if \<not> z \<approx>\<^sub>v \<infinity>\<^sub>v
	+ then (?oc a \<^sub>v z +\<^sub>v ?oc b) \<^sub>v
	+ reciprocal_cvec (?oc c *\<^sub>v z +\<^sub>v ?oc d)
	+ else ?oc a *\<^sub>v
	+ reciprocal_cvec (?oc c))"
	+ proof (cases "z \<approx>\<^sub>v \<infinity>\<^sub>v")
	+ case True
	+ thus ?thesis
	+ using zz *
	+ by auto
	+ next
	+ case False
	+ hence "z2 \<noteq> 0"
	+ using zz inf_cvec_z2_zero_iff \<open>z \<noteq> vec_zero\<close>
	+ by auto
	+ thus ?thesis
	+ using zz * False
	+ using regular_homogenous_system[of a b c d z1 z2]
	+ by auto
	+ qed
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Möbius group\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Möbius elements form a group under composition. This group is called the \emph{projective
	+general linear group} and denoted by $PGL(2, \mathbb{C})$ (the group $SGL(2, \mathbb{C})$ containing elements
	+with the determinant $1$ can also be considered).\<close>
	+
	+text \<open>Identity Möbius transformation is represented by the identity matrix.\<close>
	+
	+definition id_moebius_cmat :: "complex_mat" where
	+ [simp]: "id_moebius_cmat = eye"
	+
	+lift_definition id_moebius_mmat :: "moebius_mat" is id_moebius_cmat
	+ by simp
	+
	+lift_definition id_moebius :: "moebius" is id_moebius_mmat
	+ done
	+
	+lemma moebius_pt_moebius_id [simp]:
	+ shows "moebius_pt id_moebius = id"
	+ unfolding id_def
	+ apply (rule ext, transfer, transfer)
	+ using eye_mv_l
	+ by simp
	+
	+lemma mk_moeibus_id [simp]:
	+ shows "mk_moebius a 0 0 a = id_moebius"
	+ by (transfer, transfer, simp)
	+
	+text \<open>The inverse Möbius transformation is obtained by taking the inverse representative matrix.\<close>
	+
	+definition moebius_inv_cmat :: "complex_mat \<Rightarrow> complex_mat" where
	+ [simp]: "moebius_inv_cmat M = mat_inv M"
	+
	+lift_definition moebius_inv_mmat :: "moebius_mat \<Rightarrow> moebius_mat" is moebius_inv_cmat
	+ by (simp add: mat_det_inv)
	+
	+lift_definition moebius_inv :: "moebius \<Rightarrow> moebius" is "moebius_inv_mmat"
	+proof (transfer)
	+ fix x y
	+ assume "moebius_cmat_eq x y"
	+ thus "moebius_cmat_eq (moebius_inv_cmat x) (moebius_inv_cmat y)"
	+ by (auto simp add: mat_inv_mult_sm) (rule_tac x="1/k" in exI, simp)
	+qed
	+
	+lemma moebius_inv:
	+ shows "moebius_pt (moebius_inv M) = inv (moebius_pt M)"
	+proof (rule inv_equality[symmetric])
	+ fix x
	+ show "moebius_pt (moebius_inv M) (moebius_pt M x) = x"
	+ proof (transfer, transfer)
	+ fix M::complex_mat and x::complex_vec
	+ assume "mat_det M \<noteq> 0" "x \<noteq> vec_zero"
	+ show "moebius_pt_cmat_cvec (moebius_inv_cmat M) (moebius_pt_cmat_cvec M x) \<approx>\<^sub>v x"
	+ using eye_mv_l
	+ by (simp add: mat_inv_l[OF \<open>mat_det M \<noteq> 0\<close>])
	+ qed
	+next
	+ fix y
	+ show "moebius_pt M (moebius_pt (moebius_inv M) y) = y"
	+ proof (transfer, transfer)
	+ fix M::complex_mat and y::complex_vec
	+ assume "mat_det M \<noteq> 0" "y \<noteq> vec_zero"
	+ show "moebius_pt_cmat_cvec M (moebius_pt_cmat_cvec (moebius_inv_cmat M) y) \<approx>\<^sub>v y"
	+ using eye_mv_l
	+ by (simp add: mat_inv_r[OF \<open>mat_det M \<noteq> 0\<close>])
	+ qed
	+qed
	+
	+lemma is_moebius_inv [simp]:
	+ assumes "is_moebius m"
	+ shows "is_moebius (inv m)"
	+ using assms
	+ using moebius_inv
	+ unfolding is_moebius_def
	+ by metis
	+
	+lemma moebius_inv_mk_moebus [simp]:
	+ assumes "mat_det (a, b, c, d) \<noteq> 0"
	+ shows "moebius_inv (mk_moebius a b c d) =
	+ mk_moebius (d/(ad-bc)) (-b/(ad-bc)) (-c/(ad-bc)) (a/(ad-bc))"
	+ using assms
	+ by (transfer, transfer) (auto, rule_tac x=1 in exI, simp_all add: field_simps)
	+
	+text \<open>Composition of Möbius elements is obtained by multiplying their representing matrices.\<close>
	+
	+definition moebius_comp_cmat :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex_mat" where
	+ [simp]: "moebius_comp_cmat M1 M2 = M1 *\<^sub>m\<^sub>m M2"
	+
	+lift_definition moebius_comp_mmat :: "moebius_mat \<Rightarrow> moebius_mat \<Rightarrow> moebius_mat" is moebius_comp_cmat
	+ by simp
	+
	+lift_definition moebius_comp :: "moebius \<Rightarrow> moebius \<Rightarrow> moebius" is moebius_comp_mmat
	+ by transfer (simp, (erule exE)+, rule_tac x="k*ka" in exI, simp add: field_simps)
	+
	+lemma moebius_comp:
	+ shows "moebius_pt (moebius_comp M1 M2) = moebius_pt M1 \<circ> moebius_pt M2"
	+ unfolding comp_def
	+ by (rule ext, transfer, transfer, simp)
	+
	+lemma moebius_pt_comp [simp]:
	+ shows "moebius_pt (moebius_comp M1 M2) z = moebius_pt M1 (moebius_pt M2 z)"
	+ by (auto simp add: moebius_comp)
	+
	+lemma is_moebius_comp [simp]:
	+ assumes "is_moebius m1" and "is_moebius m2"
	+ shows "is_moebius (m1 \<circ> m2)"
	+ using assms
	+ unfolding is_moebius_def
	+ using moebius_comp
	+ by metis
	+
	+lemma moebius_comp_mk_moebius [simp]:
	+ assumes "mat_det (a, b, c, d) \<noteq> 0" and "mat_det (a', b', c', d') \<noteq> 0"
	+ shows "moebius_comp (mk_moebius a b c d) (mk_moebius a' b' c' d') =
	+ mk_moebius (a * a' + b * c') (a * b' + b * d') (c * a' + d * c') (c * b' + d * d')"
	+ using mat_det_mult[of "(a, b, c, d)" "(a', b', c', d')"]
	+ using assms
	+ by (transfer, transfer) (auto, rule_tac x=1 in exI, simp)
	+
	+instantiation moebius :: group_add
	+begin
	+definition plus_moebius :: "moebius \<Rightarrow> moebius \<Rightarrow> moebius" where
	+ [simp]: "plus_moebius = moebius_comp"
	+
	+definition uminus_moebius :: "moebius \<Rightarrow> moebius" where
	+ [simp]: "uminus_moebius = moebius_inv"
	+
	+definition zero_moebius :: "moebius" where
	+ [simp]: "zero_moebius = id_moebius"
	+
	+definition minus_moebius :: "moebius \<Rightarrow> moebius \<Rightarrow> moebius" where
	+ [simp]: "minus_moebius A B = A + (-B)"
	+
	+instance proof
	+ fix a b c :: moebius
	+ show "a + b + c = a + (b + c)"
	+ unfolding plus_moebius_def
	+ proof (transfer, transfer)
	+ fix a b c :: complex_mat
	+ assume "mat_det a \<noteq> 0" "mat_det b \<noteq> 0" "mat_det c \<noteq> 0"
	+ show "moebius_cmat_eq (moebius_comp_cmat (moebius_comp_cmat a b) c) (moebius_comp_cmat a (moebius_comp_cmat b c))"
	+ by simp (rule_tac x="1" in exI, simp add: mult_mm_assoc)
	+ qed
	+next
	+ fix a :: moebius
	+ show "a + 0 = a"
	+ unfolding plus_moebius_def zero_moebius_def
	+ proof (transfer, transfer)
	+ fix A :: complex_mat
	+ assume "mat_det A \<noteq> 0"
	+ thus "moebius_cmat_eq (moebius_comp_cmat A id_moebius_cmat) A"
	+ using mat_eye_r
	+ by simp
	+ qed
	+next
	+ fix a :: moebius
	+ show "0 + a = a"
	+ unfolding plus_moebius_def zero_moebius_def
	+ proof (transfer, transfer)
	+ fix A :: complex_mat
	+ assume "mat_det A \<noteq> 0"
	+ thus "moebius_cmat_eq (moebius_comp_cmat id_moebius_cmat A) A"
	+ using mat_eye_l
	+ by simp
	+ qed
	+next
	+ fix a :: moebius
	+ show "- a + a = 0"
	+ unfolding plus_moebius_def uminus_moebius_def zero_moebius_def
	+ proof (transfer, transfer)
	+ fix a :: complex_mat
	+ assume "mat_det a \<noteq> 0"
	+ thus "moebius_cmat_eq (moebius_comp_cmat (moebius_inv_cmat a) a) id_moebius_cmat"
	+ by (simp add: mat_inv_l)
	+ qed
	+next
	+ fix a b :: moebius
	+ show "a + - b = a - b"
	+ unfolding minus_moebius_def
	+ by simp
	+qed
	+end
	+
	+text \<open>Composition with inverse\<close>
	+
	+lemma moebius_comp_inv_left [simp]:
	+ shows "moebius_comp (moebius_inv M) M = id_moebius"
	+ by (metis left_minus plus_moebius_def uminus_moebius_def zero_moebius_def)
	+
	+lemma moebius_comp_inv_right [simp]:
	+ shows "moebius_comp M (moebius_inv M) = id_moebius"
	+ by (metis right_minus plus_moebius_def uminus_moebius_def zero_moebius_def)
	+
	+lemma moebius_pt_comp_inv_left [simp]:
	+ shows "moebius_pt (moebius_inv M) (moebius_pt M z) = z"
	+ by (subst moebius_pt_comp[symmetric], simp)
	+
	+lemma moebius_pt_comp_inv_right [simp]:
	+ shows "moebius_pt M (moebius_pt (moebius_inv M) z) = z"
	+ by (subst moebius_pt_comp[symmetric], simp)
	+
	+lemma moebius_pt_comp_inv_image_left [simp]:
	+ shows "moebius_pt (moebius_inv M) ` moebius_pt M ` A = A"
	+ by force
	+
	+lemma moebius_pt_comp_inv_image_right [simp]:
	+ shows "moebius_pt M ` moebius_pt (moebius_inv M) ` A = A"
	+ by force
	+
	+lemma moebius_pt_invert:
	+ assumes "moebius_pt M z1 = z2"
	+ shows "moebius_pt (moebius_inv M) z2 = z1"
	+ using assms[symmetric]
	+ by simp
	+
	+lemma moebius_pt_moebius_inv_in_set [simp]:
	+ assumes "moebius_pt M z \<in> A"
	+ shows "z \<in> moebius_pt (moebius_inv M) ` A"
	+ using assms
	+ using image_iff
	+ by fastforce
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Special kinds of Möbius transformations\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Reciprocal (1/z) as a Möbius transformation\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+definition moebius_reciprocal :: "moebius" where
	+ "moebius_reciprocal = mk_moebius 0 1 1 0"
	+
	+lemma moebius_reciprocal [simp]:
	+ shows "moebius_pt moebius_reciprocal = reciprocal"
	+ unfolding moebius_reciprocal_def
	+ by (rule ext, transfer, transfer) (force simp add: split_def)
	+
	+lemma moebius_reciprocal_inv [simp]:
	+ shows "moebius_inv moebius_reciprocal = moebius_reciprocal"
	+ unfolding moebius_reciprocal_def
	+ by (transfer, transfer) simp
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Euclidean similarities as a Möbius transform\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text\<open>Euclidean similarities include Euclidean isometries (translations and rotations) and
	+dilatations.\<close>
	+
	+definition moebius_similarity :: "complex \<Rightarrow> complex \<Rightarrow> moebius" where
	+ "moebius_similarity a b = mk_moebius a b 0 1"
	+
	+lemma moebius_pt_moebius_similarity [simp]:
	+ assumes "a \<noteq> 0"
	+ shows "moebius_pt (moebius_similarity a b) z = (of_complex a) *\<^sub>h z +\<^sub>h (of_complex b)"
	+ unfolding moebius_similarity_def
	+ using assms
	+ using mult_inf_right[of "of_complex a"]
	+ by (subst moebius_pt_bilinear, auto)
	+
	+text \<open>Their action is a linear transformation of $\mathbb{C}.$\<close>
	+lemma moebius_pt_moebius_similarity':
	+ assumes "a \<noteq> 0"
	+ shows "moebius_pt (moebius_similarity a b) = (\<lambda> z. (of_complex a) *\<^sub>h z +\<^sub>h (of_complex b))"
	+ using moebius_pt_moebius_similarity[OF assms, symmetric]
	+ by simp
	+
	+lemma is_moebius_similarity':
	+ assumes "a \<noteq> 0\<^sub>h" and "a \<noteq> \<infinity>\<^sub>h" and "b \<noteq> \<infinity>\<^sub>h"
	+ shows "(\<lambda> z. a *\<^sub>h z +\<^sub>h b) = moebius_pt (moebius_similarity (to_complex a) (to_complex b))"
	+proof-
	+ obtain ka kb where *: "a = of_complex ka" "ka \<noteq> 0" "b = of_complex kb"
	+ using assms
	+ using inf_or_of_complex[of a] inf_or_of_complex[of b]
	+ by auto
	+ thus ?thesis
	+ unfolding is_moebius_def
	+ using moebius_pt_moebius_similarity'[of ka kb]
	+ by simp
	+qed
	+
	+lemma is_moebius_similarity:
	+ assumes "a \<noteq> 0\<^sub>h" and "a \<noteq> \<infinity>\<^sub>h" and "b \<noteq> \<infinity>\<^sub>h"
	+ shows "is_moebius (\<lambda> z. a *\<^sub>h z +\<^sub>h b)"
	+ using is_moebius_similarity'[OF assms]
	+ unfolding is_moebius_def
	+ by auto
	+
	+text \<open>Euclidean similarities form a group.\<close>
	+
	+lemma moebius_similarity_id [simp]:
	+ shows "moebius_similarity 1 0 = id_moebius"
	+ unfolding moebius_similarity_def
	+ by simp
	+
	+lemma moebius_similarity_inv [simp]:
	+ assumes "a \<noteq> 0"
	+ shows "moebius_inv (moebius_similarity a b) = moebius_similarity (1/a) (-b/a)"
	+ using assms
	+ unfolding moebius_similarity_def
	+ by simp
	+
	+lemma moebius_similarity_uminus [simp]:
	+ assumes "a \<noteq> 0"
	+ shows "- moebius_similarity a b = moebius_similarity (1/a) (-b/a)"
	+ using assms
	+ by simp
	+
	+lemma moebius_similarity_comp [simp]:
	+ assumes "a \<noteq> 0" and "c \<noteq> 0"
	+ shows "moebius_comp (moebius_similarity a b) (moebius_similarity c d) = moebius_similarity (ac) (ad+b)"
	+ using assms
	+ unfolding moebius_similarity_def
	+ by simp
	+
	+lemma moebius_similarity_plus [simp]:
	+ assumes "a \<noteq> 0" and "c \<noteq> 0"
	+ shows "moebius_similarity a b + moebius_similarity c d = moebius_similarity (ac) (ad+b)"
	+ using assms
	+ by simp
	+
	+text \<open>Euclidean similarities are the only Möbius group elements such that their action leaves the
	+$\infty_{h}$ fixed.\<close>
	+lemma moebius_similarity_inf [simp]:
	+ assumes "a \<noteq> 0"
	+ shows "moebius_pt (moebius_similarity a b) \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ using assms
	+ unfolding moebius_similarity_def
	+ by (transfer, transfer, simp)
	+
	+lemma moebius_similarity_only_inf_to_inf:
	+ assumes "a \<noteq> 0" "moebius_pt (moebius_similarity a b) z = \<infinity>\<^sub>h"
	+ shows "z = \<infinity>\<^sub>h"
	+ using assms
	+ using inf_or_of_complex[of z]
	+ by auto
	+
	+lemma moebius_similarity_inf_iff [simp]:
	+ assumes "a \<noteq> 0"
	+ shows "moebius_pt (moebius_similarity a b) z = \<infinity>\<^sub>h \<longleftrightarrow> z = \<infinity>\<^sub>h"
	+ using assms
	+ using moebius_similarity_only_inf_to_inf[of a b z]
	+ by auto
	+
	+lemma inf_fixed_only_moebius_similarity:
	+ assumes "moebius_pt M \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ shows "\<exists> a b. a \<noteq> 0 \<and> M = moebius_similarity a b"
	+ using assms
	+ unfolding moebius_similarity_def
	+proof (transfer, transfer)
	+ fix M :: complex_mat
	+ obtain a b c d where MM: "M = (a, b, c, d)"
	+ by (cases M, auto)
	+ assume "mat_det M \<noteq> 0" "moebius_pt_cmat_cvec M \<infinity>\<^sub>v \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ hence *: "c = 0" "a \<noteq> 0 \<and> d \<noteq> 0"
	+ using MM
	+ by auto
	+ show "\<exists>a b. a \<noteq> 0 \<and> moebius_cmat_eq M (mk_moebius_cmat a b 0 1)"
	+ proof (rule_tac x="a/d" in exI, rule_tac x="b/d" in exI)
	+ show "a/d \<noteq> 0 \<and> moebius_cmat_eq M (mk_moebius_cmat (a / d) (b / d) 0 1)"
	+ using MM *
	+ by simp (rule_tac x="1/d" in exI, simp)
	+ qed
	+qed
	+
	+text \<open>Euclidean similarities include translations, rotations, and dilatations.\<close>
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Translation\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+definition moebius_translation where
	+ "moebius_translation v = moebius_similarity 1 v"
	+
	+lemma moebius_translation_comp [simp]:
	+ shows "moebius_comp (moebius_translation v1) (moebius_translation v2) = moebius_translation (v1 + v2)"
	+ unfolding moebius_translation_def
	+ by (simp add: field_simps)
	+
	+lemma moebius_translation_plus [simp]:
	+ shows "(moebius_translation v1) + (moebius_translation v2) = moebius_translation (v1 + v2)"
	+ by simp
	+
	+lemma moebius_translation_zero [simp]:
	+ shows "moebius_translation 0 = id_moebius"
	+ unfolding moebius_translation_def moebius_similarity_id
	+ by simp
	+
	+lemma moebius_translation_inv [simp]:
	+ shows "moebius_inv (moebius_translation v1) = moebius_translation (-v1)"
	+ using moebius_translation_comp[of v1 "-v1"] moebius_translation_zero
	+ using minus_unique[of "moebius_translation v1" "moebius_translation (-v1)"]
	+ by simp
	+
	+lemma moebius_translation_uminus [simp]:
	+ shows "- (moebius_translation v1) = moebius_translation (-v1)"
	+ by simp
	+
	+lemma moebius_translation_inv_translation [simp]:
	+ shows "moebius_pt (moebius_translation v) (moebius_pt (moebius_translation (-v)) z) = z"
	+ using moebius_translation_inv[symmetric, of v]
	+ by (simp del: moebius_translation_inv)
	+
	+lemma moebius_inv_translation_translation [simp]:
	+ shows "moebius_pt (moebius_translation (-v)) (moebius_pt (moebius_translation v) z) = z"
	+ using moebius_translation_inv[symmetric, of v]
	+ by (simp del: moebius_translation_inv)
	+
	+lemma moebius_pt_moebius_translation [simp]:
	+ shows "moebius_pt (moebius_translation v) (of_complex z) = of_complex (z + v)"
	+ unfolding moebius_translation_def
	+ by (simp add: field_simps)
	+
	+lemma moebius_pt_moebius_translation_inf [simp]:
	+ shows "moebius_pt (moebius_translation v) \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ unfolding moebius_translation_def
	+ by simp
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Rotation\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+definition moebius_rotation where
	+ "moebius_rotation \<phi> = moebius_similarity (cis \<phi>) 0"
	+
	+lemma moebius_rotation_comp [simp]:
	+ shows "moebius_comp (moebius_rotation \<phi>1) (moebius_rotation \<phi>2) = moebius_rotation (\<phi>1 + \<phi>2)"
	+ unfolding moebius_rotation_def
	+ using moebius_similarity_comp[of "cis \<phi>1" "cis \<phi>2" 0 0]
	+ by (simp add: cis_mult)
	+
	+lemma moebius_rotation_plus [simp]:
	+ shows "(moebius_rotation \<phi>1) + (moebius_rotation \<phi>2) = moebius_rotation (\<phi>1 + \<phi>2)"
	+ by simp
	+
	+lemma moebius_rotation_zero [simp]:
	+ shows "moebius_rotation 0 = id_moebius"
	+ unfolding moebius_rotation_def
	+ using moebius_similarity_id
	+ by simp
	+
	+lemma moebius_rotation_inv [simp]:
	+ shows "moebius_inv (moebius_rotation \<phi>) = moebius_rotation (- \<phi>)"
	+ using moebius_rotation_comp[of \<phi> "-\<phi>"] moebius_rotation_zero
	+ using minus_unique[of "moebius_rotation \<phi>" "moebius_rotation (-\<phi>)"]
	+ by simp
	+
	+lemma moebius_rotation_uminus [simp]:
	+ shows "- (moebius_rotation \<phi>) = moebius_rotation (- \<phi>)"
	+ by simp
	+
	+lemma moebius_rotation_inv_rotation [simp]:
	+ shows "moebius_pt (moebius_rotation \<phi>) (moebius_pt (moebius_rotation (-\<phi>)) z) = z"
	+ using moebius_rotation_inv[symmetric, of \<phi>]
	+ by (simp del: moebius_rotation_inv)
	+
	+lemma moebius_inv_rotation_rotation [simp]:
	+ shows "moebius_pt (moebius_rotation (-\<phi>)) (moebius_pt (moebius_rotation \<phi>) z) = z"
	+ using moebius_rotation_inv[symmetric, of \<phi>]
	+ by (simp del: moebius_rotation_inv)
	+
	+lemma moebius_pt_moebius_rotation [simp]:
	+ shows "moebius_pt (moebius_rotation \<phi>) (of_complex z) = of_complex (cis \<phi> * z)"
	+ unfolding moebius_rotation_def
	+ by simp
	+
	+lemma moebius_pt_moebius_rotation_inf [simp]:
	+ shows "moebius_pt (moebius_rotation v) \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ unfolding moebius_rotation_def
	+ by simp
	+
	+lemma moebius_pt_rotation_inf_iff [simp]:
	+ shows "moebius_pt (moebius_rotation v) x = \<infinity>\<^sub>h \<longleftrightarrow> x = \<infinity>\<^sub>h"
	+ unfolding moebius_rotation_def
	+ using cis_neq_zero moebius_similarity_only_inf_to_inf
	+ by (simp del: moebius_pt_moebius_similarity)
	+
	+lemma moebius_pt_moebius_rotation_zero [simp]:
	+ shows "moebius_pt (moebius_rotation \<phi>) 0\<^sub>h = 0\<^sub>h"
	+ unfolding moebius_rotation_def
	+ by simp
	+
	+lemma moebius_pt_moebius_rotation_zero_iff [simp]:
	+ shows "moebius_pt (moebius_rotation \<phi>) x = 0\<^sub>h \<longleftrightarrow> x = 0\<^sub>h"
	+ using moebius_pt_invert[of "moebius_rotation \<phi>" x "0\<^sub>h"]
	+ by auto
	+
	+lemma moebius_rotation_preserve_cmod [simp]:
	+ assumes "u \<noteq> \<infinity>\<^sub>h"
	+ shows "cmod (to_complex (moebius_pt (moebius_rotation \<phi>) u)) = cmod (to_complex u)"
	+ using assms
	+ using inf_or_of_complex[of u]
	+ by auto
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Dilatation\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+definition moebius_dilatation where
	+ "moebius_dilatation a = moebius_similarity (cor a) 0"
	+
	+lemma moebius_dilatation_comp [simp]:
	+ assumes "a1 > 0" and "a2 > 0"
	+ shows "moebius_comp (moebius_dilatation a1) (moebius_dilatation a2) = moebius_dilatation (a1 * a2)"
	+ using assms
	+ unfolding moebius_dilatation_def
	+ by simp
	+
	+lemma moebius_dilatation_plus [simp]:
	+ assumes "a1 > 0" and "a2 > 0"
	+ shows "(moebius_dilatation a1) + (moebius_dilatation a2) = moebius_dilatation (a1 * a2)"
	+ using assms
	+ by simp
	+
	+lemma moebius_dilatation_zero [simp]:
	+ shows "moebius_dilatation 1 = id_moebius"
	+ unfolding moebius_dilatation_def
	+ using moebius_similarity_id
	+ by simp
	+
	+lemma moebius_dilatation_inverse [simp]:
	+ assumes "a > 0"
	+ shows "moebius_inv (moebius_dilatation a) = moebius_dilatation (1/a)"
	+ using assms
	+ unfolding moebius_dilatation_def
	+ by simp
	+
	+lemma moebius_dilatation_uminus [simp]:
	+ assumes "a > 0"
	+ shows "- (moebius_dilatation a) = moebius_dilatation (1/a)"
	+ using assms
	+ by simp
	+
	+lemma moebius_pt_dilatation [simp]:
	+ assumes "a \<noteq> 0"
	+ shows "moebius_pt (moebius_dilatation a) (of_complex z) = of_complex (cor a * z)"
	+ using assms
	+ unfolding moebius_dilatation_def
	+ by simp
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Rotation-dilatation\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+definition moebius_rotation_dilatation where
	+ "moebius_rotation_dilatation a = moebius_similarity a 0"
	+
	+lemma moebius_rotation_dilatation:
	+ assumes "a \<noteq> 0"
	+ shows "moebius_rotation_dilatation a = moebius_rotation (arg a) + moebius_dilatation (cmod a)"
	+ using assms
	+ unfolding moebius_rotation_dilatation_def moebius_rotation_def moebius_dilatation_def
	+ by simp
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Conjugate Möbius\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Conjugation is not a Möbius transformation, and conjugate Möbius transformations (obtained
	+by conjugating each matrix element) do not represent conjugation function (although they are
	+somewhat related).\<close>
	+
	+lift_definition conjugate_moebius_mmat :: "moebius_mat \<Rightarrow> moebius_mat" is mat_cnj
	+ by auto
	+lift_definition conjugate_moebius :: "moebius \<Rightarrow> moebius" is conjugate_moebius_mmat
	+ by transfer (auto simp add: mat_cnj_def)
	+
	+lemma conjugate_moebius:
	+ shows "conjugate \<circ> moebius_pt M = moebius_pt (conjugate_moebius M) \<circ> conjugate"
	+ apply (rule ext, simp)
	+ apply (transfer, transfer)
	+ using vec_cnj_mult_mv by auto
	+
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Decomposition of M\"obius transformations\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Every Euclidean similarity can be decomposed using translations, rotations, and dilatations.\<close>
	+lemma similarity_decomposition:
	+ assumes "a \<noteq> 0"
	+ shows "moebius_similarity a b = (moebius_translation b) + (moebius_rotation (arg a)) + (moebius_dilatation (cmod a))"
	+proof-
	+ have "moebius_similarity a b = (moebius_translation b) + (moebius_rotation_dilatation a)"
	+ using assms
	+ unfolding moebius_rotation_dilatation_def moebius_translation_def moebius_similarity_def
	+ by auto
	+ thus ?thesis
	+ using moebius_rotation_dilatation [OF assms]
	+ by (auto simp add: add.assoc simp del: plus_moebius_def)
	+qed
	+
	+text \<open>A very important fact is that every Möbius transformation can be
	+composed of Euclidean similarities and a reciprocation.\<close>
	+lemma moebius_decomposition:
	+ assumes "c \<noteq> 0" and "ad - bc \<noteq> 0"
	+ shows "mk_moebius a b c d =
	+ moebius_translation (a/c) +
	+ moebius_rotation_dilatation ((bc - ad)/(c*c)) +
	+ moebius_reciprocal +
	+ moebius_translation (d/c)"
	+ using assms
	+ unfolding moebius_rotation_dilatation_def moebius_translation_def moebius_similarity_def plus_moebius_def moebius_reciprocal_def
	+ by (simp add: field_simps) (transfer, transfer, auto simp add: field_simps, rule_tac x="1/c" in exI, simp)
	+
	+lemma moebius_decomposition_similarity:
	+ assumes "a \<noteq> 0"
	+ shows "mk_moebius a b 0 d = moebius_similarity (a/d) (b/d)"
	+ using assms
	+ unfolding moebius_similarity_def
	+ by (transfer, transfer, auto, rule_tac x="1/d" in exI, simp)
	+
	+text \<open>Decomposition is used in many proofs. Namely, to show that every Möbius transformation has
	+some property, it suffices to show that reciprocation and all Euclidean similarities have that
	+property, and that the property is preserved under compositions.\<close>
	+lemma wlog_moebius_decomposition:
	+ assumes
	+ trans: "\<And> v. P (moebius_translation v)" and
	+ rot: "\<And> \<alpha>. P (moebius_rotation \<alpha>)" and
	+ dil: "\<And> k. P (moebius_dilatation k)" and
	+ recip: "P (moebius_reciprocal)" and
	+ comp: "\<And> M1 M2. \<lbrakk>P M1; P M2\<rbrakk> \<Longrightarrow> P (M1 + M2)"
	+ shows "P M"
	+proof-
	+ obtain a b c d where "M = mk_moebius a b c d" "mat_det (a, b, c, d) \<noteq> 0"
	+ using ex_mk_moebius[of M]
	+ by auto
	+ show ?thesis
	+ proof (cases "c = 0")
	+ case False
	+ show ?thesis
	+ using moebius_decomposition[of c a d b] \<open>mat_det (a, b, c, d) \<noteq> 0\<close> \<open>c \<noteq> 0\<close> \<open>M = mk_moebius a b c d\<close>
	+ using moebius_rotation_dilatation[of "(bc - ad) / (c*c)"]
	+ using trans[of "a/c"] rot[of "arg ((bc - ad) / (cc))"] dil[of "cmod ((bc - ad) / (cc))"] recip
	+ using comp
	+ by (simp add: trans)
	+ next
	+ case True
	+ hence "M = moebius_similarity (a/d) (b/d)"
	+ using \<open>M = mk_moebius a b c d\<close> \<open>mat_det (a, b, c, d) \<noteq> 0\<close>
	+ using moebius_decomposition_similarity
	+ by auto
	+ thus ?thesis
	+ using \<open>c = 0\<close> \<open>mat_det (a, b, c, d) \<noteq> 0\<close>
	+ using similarity_decomposition[of "a/d" "b/d"]
	+ using trans[of "b/d"] rot[of "arg (a/d)"] dil[of "cmod (a/d)"] comp
	+ by simp
	+ qed
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Cross ratio and Möbius existence\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>For any fixed three points $z1$, $z2$ and $z3$, @{term "cross_ratio z z1 z2 z3"} can be seen as
	+a function of a single variable $z$.\<close>
	+
	+
	+lemma is_moebius_cross_ratio:
	+ assumes "z1 \<noteq> z2" and "z2 \<noteq> z3" and "z1 \<noteq> z3"
	+ shows "is_moebius (\<lambda> z. cross_ratio z z1 z2 z3)"
	+proof-
	+ have "\<exists> M. \<forall> z. cross_ratio z z1 z2 z3 = moebius_pt M z"
	+ using assms
	+ proof (transfer, transfer)
	+ fix z1 z2 z3
	+ assume vz: "z1 \<noteq> vec_zero" "z2 \<noteq> vec_zero" "z3 \<noteq> vec_zero"
	+ obtain z1' z1'' where zz1: "z1 = (z1', z1'')"
	+ by (cases z1, auto)
	+ obtain z2' z2'' where zz2: "z2 = (z2', z2'')"
	+ by (cases z2, auto)
	+ obtain z3' z3'' where zz3: "z3 = (z3', z3'')"
	+ by (cases z3, auto)
	+
	+ let ?m23 = "z2'z3''-z3'z2''"
	+ let ?m21 = "z2'z1''-z1'z2''"
	+ let ?m13 = "z1'z3''-z3'z1''"
	+ let ?M = "(z1''?m23, -z1'?m23, z3''?m21, -z3'?m21)"
	+ assume "\<not> z1 \<approx>\<^sub>v z2" "\<not> z2 \<approx>\<^sub>v z3" "\<not> z1 \<approx>\<^sub>v z3"
	+ hence *: "?m23 \<noteq> 0" "?m21 \<noteq> 0" "?m13 \<noteq> 0"
	+ using vz zz1 zz2 zz3
	+ using complex_cvec_eq_mix[of z1' z1'' z2' z2'']
	+ using complex_cvec_eq_mix[of z1' z1'' z3' z3'']
	+ using complex_cvec_eq_mix[of z2' z2'' z3' z3'']
	+ by (auto simp del: complex_cvec_eq_def simp add: field_simps)
	+
	+ have "mat_det ?M = ?m21?m23?m13"
	+ by (simp add: field_simps)
	+ hence "mat_det ?M \<noteq> 0"
	+ using *
	+ by simp
	+ moreover
	+ have "\<forall>z\<in>{v. v \<noteq> vec_zero}. cross_ratio_cvec z z1 z2 z3 \<approx>\<^sub>v moebius_pt_cmat_cvec ?M z"
	+ proof
	+ fix z
	+ assume "z \<in> {v. v \<noteq> vec_zero}"
	+ hence "z \<noteq> vec_zero"
	+ by simp
	+ obtain z' z'' where zz: "z = (z', z'')"
	+ by (cases z, auto)
	+
	+ let ?m01 = "z'z1''-z1'z''"
	+ let ?m03 = "z'z3''-z3'z''"
	+
	+ have "?m01 \<noteq> 0 \<or> ?m03 \<noteq> 0"
	+ proof (cases "z'' = 0 \<or> z1'' = 0 \<or> z3'' = 0")
	+ case True
	+ thus ?thesis
	+ using * \<open>z \<noteq> vec_zero\<close> zz
	+ by auto
	+ next
	+ case False
	+ hence 1: "z'' \<noteq> 0 \<and> z1'' \<noteq> 0 \<and> z3'' \<noteq> 0"
	+ by simp
	+ show ?thesis
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "z' * z1'' - z1' * z'' = 0" "z' * z3'' - z3' * z'' = 0"
	+ by auto
	+ hence "z1'/z1'' = z3'/z3''"
	+ using 1 zz \<open>z \<noteq> vec_zero\<close>
	+ by (metis frac_eq_eq right_minus_eq)
	+ thus False
	+ using * 1
	+ using frac_eq_eq
	+ by auto
	+ qed
	+ qed
	+ note * = * this
	+ show "cross_ratio_cvec z z1 z2 z3 \<approx>\<^sub>v moebius_pt_cmat_cvec ?M z"
	+ using * zz zz1 zz2 zz3 mult_mv_nonzero[of "z" ?M] \<open>mat_det ?M \<noteq> 0\<close>
	+ by simp (rule_tac x="1" in exI, simp add: field_simps)
	+ qed
	+ ultimately
	+ show "\<exists>M\<in>{M. mat_det M \<noteq> 0}.
	+ \<forall>z\<in>{v. v \<noteq> vec_zero}. cross_ratio_cvec z z1 z2 z3 \<approx>\<^sub>v moebius_pt_cmat_cvec M z"
	+ by blast
	+ qed
	+ thus ?thesis
	+ by (auto simp add: is_moebius_def)
	+qed
	+
	+text \<open>Using properties of the cross-ratio, it is shown that there is a Möbius transformation
	+mapping any three different points to $0_{hc}$, $1_{hc}$ and $\infty_{hc}$, respectively.\<close>
	+lemma ex_moebius_01inf:
	+ assumes "z1 \<noteq> z2" and "z1 \<noteq> z3" and "z2 \<noteq> z3"
	+ shows "\<exists> M. ((moebius_pt M z1 = 0\<^sub>h) \<and> (moebius_pt M z2 = 1\<^sub>h) \<and> (moebius_pt M z3 = \<infinity>\<^sub>h))"
	+ using assms
	+ using is_moebius_cross_ratio[OF \<open>z1 \<noteq> z2\<close> \<open>z2 \<noteq> z3\<close> \<open>z1 \<noteq> z3\<close>]
	+ using cross_ratio_0[OF \<open>z1 \<noteq> z2\<close> \<open>z1 \<noteq> z3\<close>] cross_ratio_1[OF \<open>z1 \<noteq> z2\<close> \<open>z2 \<noteq> z3\<close>] cross_ratio_inf[OF \<open>z1 \<noteq> z3\<close> \<open>z2 \<noteq> z3\<close>]
	+ by (metis is_moebius_def)
	+
	+text \<open>There is a Möbius transformation mapping any three different points to any three different
	+points.\<close>
	+lemma ex_moebius:
	+ assumes "z1 \<noteq> z2" and "z1 \<noteq> z3" and "z2 \<noteq> z3"
	+ "w1 \<noteq> w2" and "w1 \<noteq> w3" and "w2 \<noteq> w3"
	+ shows "\<exists> M. ((moebius_pt M z1 = w1) \<and> (moebius_pt M z2 = w2) \<and> (moebius_pt M z3 = w3))"
	+proof-
	+ obtain M1 where *: "moebius_pt M1 z1 = 0\<^sub>h \<and> moebius_pt M1 z2 = 1\<^sub>h \<and> moebius_pt M1 z3 = \<infinity>\<^sub>h"
	+ using ex_moebius_01inf[OF assms(1-3)]
	+ by auto
	+ obtain M2 where **: "moebius_pt M2 w1 = 0\<^sub>h \<and> moebius_pt M2 w2 = 1\<^sub>h \<and> moebius_pt M2 w3 = \<infinity>\<^sub>h"
	+ using ex_moebius_01inf[OF assms(4-6)]
	+ by auto
	+ let ?M = "moebius_comp (moebius_inv M2) M1"
	+ show ?thesis
	+ using * **
	+ by (rule_tac x="?M" in exI, auto simp add: moebius_pt_invert)
	+qed
	+
	+lemma ex_moebius_1:
	+ shows "\<exists> M. moebius_pt M z1 = w1"
	+proof-
	+ obtain z2 z3 where "z1 \<noteq> z2" "z1 \<noteq> z3" "z2 \<noteq> z3"
	+ using ex_3_different_points[of z1]
	+ by auto
	+ moreover
	+ obtain w2 w3 where "w1 \<noteq> w2" "w1 \<noteq> w3" "w2 \<noteq> w3"
	+ using ex_3_different_points[of w1]
	+ by auto
	+ ultimately
	+ show ?thesis
	+ using ex_moebius[of z1 z2 z3 w1 w2 w3]
	+ by auto
	+qed
	+
	+text \<open>The next lemma turns out to have very important applications in further proof development, as
	+it enables so called ,,without-loss-of-generality (wlog)'' reasoning \cite{wlog}. Namely, if the
	+property is preserved under Möbius transformations, then instead of three arbitrary different
	+points one can consider only the case of points $0_{hc}$, $1_{hc}$, and $\infty_{hc}$.\<close>
	+lemma wlog_moebius_01inf:
	+ fixes M::moebius
	+ assumes "P 0\<^sub>h 1\<^sub>h \<infinity>\<^sub>h" and "z1 \<noteq> z2" and "z2 \<noteq> z3" and "z1 \<noteq> z3"
	+ "\<And> M a b c. P a b c \<Longrightarrow> P (moebius_pt M a) (moebius_pt M b) (moebius_pt M c)"
	+ shows "P z1 z2 z3"
	+proof-
	+ from assms obtain M where *:
	+ "moebius_pt M z1 = 0\<^sub>h" "moebius_pt M z2 = 1\<^sub>h" "moebius_pt M z3 = \<infinity>\<^sub>h"
	+ using ex_moebius_01inf[of z1 z2 z3]
	+ by auto
	+ have **: "moebius_pt (moebius_inv M) 0\<^sub>h = z1" "moebius_pt (moebius_inv M) 1\<^sub>h = z2" "moebius_pt (moebius_inv M) \<infinity>\<^sub>h = z3"
	+ by (subst *[symmetric], simp)+
	+ thus ?thesis
	+ using assms
	+ by auto
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Fixed points and Möbius transformation uniqueness\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+lemma three_fixed_points_01inf:
	+ assumes "moebius_pt M 0\<^sub>h = 0\<^sub>h" and "moebius_pt M 1\<^sub>h = 1\<^sub>h" and "moebius_pt M \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ shows "M = id_moebius"
	+ using assms
	+ by (transfer, transfer, auto)
	+
	+lemma three_fixed_points:
	+ assumes "z1 \<noteq> z2" and "z1 \<noteq> z3" and "z2 \<noteq> z3"
	+ assumes "moebius_pt M z1 = z1" and "moebius_pt M z2 = z2" and "moebius_pt M z3 = z3"
	+ shows "M = id_moebius"
	+proof-
	+ from assms obtain M' where *: "moebius_pt M' z1 = 0\<^sub>h" "moebius_pt M' z2 = 1\<^sub>h" "moebius_pt M' z3 = \<infinity>\<^sub>h"
	+ using ex_moebius_01inf[of z1 z2 z3]
	+ by auto
	+ have **: "moebius_pt (moebius_inv M') 0\<^sub>h = z1" "moebius_pt (moebius_inv M') 1\<^sub>h = z2" "moebius_pt (moebius_inv M') \<infinity>\<^sub>h = z3"
	+ by (subst *[symmetric], simp)+
	+
	+ have "M' + M + (-M') = 0"
	+ unfolding zero_moebius_def
	+ apply (rule three_fixed_points_01inf)
	+ using * ** assms
	+ by (simp add: moebius_comp[symmetric])+
	+ thus ?thesis
	+ by (metis eq_neg_iff_add_eq_0 minus_add_cancel zero_moebius_def)
	+qed
	+
	+lemma unique_moebius_three_points:
	+ assumes "z1 \<noteq> z2" and "z1 \<noteq> z3" and "z2 \<noteq> z3"
	+ assumes "moebius_pt M1 z1 = w1" and "moebius_pt M1 z2 = w2" and "moebius_pt M1 z3 = w3"
	+ "moebius_pt M2 z1 = w1" and "moebius_pt M2 z2 = w2" and "moebius_pt M2 z3 = w3"
	+ shows "M1 = M2"
	+proof-
	+ let ?M = "moebius_comp (moebius_inv M2) M1"
	+ have "moebius_pt ?M z1 = z1"
	+ using \<open>moebius_pt M1 z1 = w1\<close> \<open>moebius_pt M2 z1 = w1\<close>
	+ by (auto simp add: moebius_pt_invert)
	+ moreover
	+ have "moebius_pt ?M z2 = z2"
	+ using \<open>moebius_pt M1 z2 = w2\<close> \<open>moebius_pt M2 z2 = w2\<close>
	+ by (auto simp add: moebius_pt_invert)
	+ moreover
	+ have "moebius_pt ?M z3 = z3"
	+ using \<open>moebius_pt M1 z3 = w3\<close> \<open>moebius_pt M2 z3 = w3\<close>
	+ by (auto simp add: moebius_pt_invert)
	+ ultimately
	+ have "?M = id_moebius"
	+ using assms three_fixed_points
	+ by auto
	+ thus ?thesis
	+ by (metis add_minus_cancel left_minus plus_moebius_def uminus_moebius_def zero_moebius_def)
	+qed
	+
	+text \<open>There is a unique Möbius transformation mapping three different points to other three
	+different points.\<close>
	+
	+lemma ex_unique_moebius_three_points:
	+ assumes "z1 \<noteq> z2" and "z1 \<noteq> z3" and "z2 \<noteq> z3"
	+ "w1 \<noteq> w2" and "w1 \<noteq> w3" and "w2 \<noteq> w3"
	+ shows "\<exists>! M. ((moebius_pt M z1 = w1) \<and> (moebius_pt M z2 = w2) \<and> (moebius_pt M z3 = w3))"
	+proof-
	+ obtain M where *: "moebius_pt M z1 = w1 \<and> moebius_pt M z2 = w2 \<and> moebius_pt M z3 = w3"
	+ using ex_moebius[OF assms]
	+ by auto
	+ show ?thesis
	+ unfolding Ex1_def
	+ proof (rule_tac x="M" in exI, rule)
	+ show "\<forall>y. moebius_pt y z1 = w1 \<and> moebius_pt y z2 = w2 \<and> moebius_pt y z3 = w3 \<longrightarrow> y = M"
	+ using *
	+ using unique_moebius_three_points[OF assms(1-3)]
	+ by simp
	+ qed (simp add: *)
	+qed
	+
	+lemma ex_unique_moebius_three_points_fun:
	+ assumes "z1 \<noteq> z2" and "z1 \<noteq> z3" and "z2 \<noteq> z3"
	+ "w1 \<noteq> w2" and "w1 \<noteq> w3" and "w2 \<noteq> w3"
	+ shows "\<exists>! f. is_moebius f \<and> (f z1 = w1) \<and> (f z2 = w2) \<and> (f z3 = w3)"
	+proof-
	+ obtain M where "moebius_pt M z1 = w1" "moebius_pt M z2 = w2" "moebius_pt M z3 = w3"
	+ using ex_unique_moebius_three_points[OF assms]
	+ by auto
	+ thus ?thesis
	+ using ex_unique_moebius_three_points[OF assms]
	+ unfolding Ex1_def
	+ by (rule_tac x="moebius_pt M" in exI) (auto simp add: is_moebius_def)
	+qed
	+
	+text \<open>Different Möbius transformations produce different actions.\<close>
	+lemma unique_moebius_pt:
	+ assumes "moebius_pt M1 = moebius_pt M2"
	+ shows "M1 = M2"
	+ using assms unique_moebius_three_points[of "0\<^sub>h" "1\<^sub>h" "\<infinity>\<^sub>h"]
	+ by auto
	+
	+lemma is_cross_ratio_01inf:
	+ assumes "z1 \<noteq> z2" and "z1 \<noteq> z3" and "z2 \<noteq> z3" and "is_moebius f"
	+ assumes "f z1 = 0\<^sub>h" and "f z2 = 1\<^sub>h" and "f z3 = \<infinity>\<^sub>h"
	+ shows "f = (\<lambda> z. cross_ratio z z1 z2 z3)"
	+ using assms
	+ using cross_ratio_0[OF \<open>z1 \<noteq> z2\<close> \<open>z1 \<noteq> z3\<close>] cross_ratio_1[OF \<open>z1 \<noteq> z2\<close> \<open>z2 \<noteq> z3\<close>] cross_ratio_inf[OF \<open>z1 \<noteq> z3\<close> \<open>z2 \<noteq> z3\<close>]
	+ using is_moebius_cross_ratio[OF \<open>z1 \<noteq> z2\<close> \<open>z2 \<noteq> z3\<close> \<open>z1 \<noteq> z3\<close>]
	+ using ex_unique_moebius_three_points_fun[OF \<open>z1 \<noteq> z2\<close> \<open>z1 \<noteq> z3\<close> \<open>z2 \<noteq> z3\<close>, of "0\<^sub>h" "1\<^sub>h" "\<infinity>\<^sub>h"]
	+ by auto
	+
	+text \<open>Möbius transformations preserve cross-ratio.\<close>
	+lemma moebius_preserve_cross_ratio [simp]:
	+ assumes "z1 \<noteq> z2" and "z1 \<noteq> z3" and "z2 \<noteq> z3"
	+ shows "cross_ratio (moebius_pt M z) (moebius_pt M z1) (moebius_pt M z2) (moebius_pt M z3) =
	+ cross_ratio z z1 z2 z3"
	+proof-
	+ let ?f = "\<lambda> z. cross_ratio z z1 z2 z3"
	+ let ?M = "moebius_pt M"
	+ let ?iM = "inv ?M"
	+ have "(?f \<circ> ?iM) (?M z1) = 0\<^sub>h"
	+ using bij_moebius_pt[of M] cross_ratio_0[OF \<open>z1 \<noteq> z2\<close> \<open>z1 \<noteq> z3\<close>]
	+ by (simp add: bij_def)
	+ moreover
	+ have "(?f \<circ> ?iM) (?M z2) = 1\<^sub>h"
	+ using bij_moebius_pt[of M] cross_ratio_1[OF \<open>z1 \<noteq> z2\<close> \<open>z2 \<noteq> z3\<close>]
	+ by (simp add: bij_def)
	+ moreover
	+ have "(?f \<circ> ?iM) (?M z3) = \<infinity>\<^sub>h"
	+ using bij_moebius_pt[of M] cross_ratio_inf[OF \<open>z1 \<noteq> z3\<close> \<open>z2 \<noteq> z3\<close>]
	+ by (simp add: bij_def)
	+ moreover
	+ have "is_moebius (?f \<circ> ?iM)"
	+ by (rule is_moebius_comp, rule is_moebius_cross_ratio[OF \<open>z1 \<noteq> z2\<close> \<open>z2 \<noteq> z3\<close> \<open>z1 \<noteq> z3\<close>], rule is_moebius_inv, auto simp add: is_moebius_def)
	+ moreover
	+ have "?M z1 \<noteq> ?M z2" "?M z1 \<noteq> ?M z3" "?M z2 \<noteq> ?M z3"
	+ using assms
	+ by simp_all
	+ ultimately
	+ have "?f \<circ> ?iM = (\<lambda> z. cross_ratio z (?M z1) (?M z2) (?M z3))"
	+ using assms
	+ using is_cross_ratio_01inf[of "?M z1" "?M z2" "?M z3" "?f \<circ> ?iM"]
	+ by simp
	+ moreover
	+ have "(?f \<circ> ?iM) (?M z) = cross_ratio z z1 z2 z3"
	+ using bij_moebius_pt[of M]
	+ by (simp add: bij_def)
	+ moreover
	+ have "(\<lambda> z. cross_ratio z (?M z1) (?M z2) (?M z3)) (?M z) = cross_ratio (?M z) (?M z1) (?M z2) (?M z3)"
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by simp
	+qed
	+
	+lemma conjugate_cross_ratio [simp]:
	+ assumes "z1 \<noteq> z2" and "z1 \<noteq> z3" and "z2 \<noteq> z3"
	+ shows "cross_ratio (conjugate z) (conjugate z1) (conjugate z2) (conjugate z3) =
	+ conjugate (cross_ratio z z1 z2 z3)"
	+proof-
	+ let ?f = "\<lambda> z. cross_ratio z z1 z2 z3"
	+ let ?M = "conjugate"
	+ let ?iM = "conjugate"
	+ have "(conjugate \<circ> ?f \<circ> ?iM) (?M z1) = 0\<^sub>h"
	+ using cross_ratio_0[OF \<open>z1 \<noteq> z2\<close> \<open>z1 \<noteq> z3\<close>]
	+ by simp
	+ moreover
	+ have "(conjugate \<circ> ?f \<circ> ?iM) (?M z2) = 1\<^sub>h"
	+ using cross_ratio_1[OF \<open>z1 \<noteq> z2\<close> \<open>z2 \<noteq> z3\<close>]
	+ by simp
	+ moreover
	+ have "(conjugate \<circ> ?f \<circ> ?iM) (?M z3) = \<infinity>\<^sub>h"
	+ using cross_ratio_inf[OF \<open>z1 \<noteq> z3\<close> \<open>z2 \<noteq> z3\<close>]
	+ by simp
	+ moreover
	+ have "is_moebius (conjugate \<circ> ?f \<circ> ?iM)"
	+ proof-
	+ obtain M where "?f = moebius_pt M"
	+ using is_moebius_cross_ratio[OF \<open>z1 \<noteq> z2\<close> \<open>z2 \<noteq> z3\<close> \<open>z1 \<noteq> z3\<close>]
	+ by (auto simp add: is_moebius_def)
	+ thus ?thesis
	+ using conjugate_moebius[of M]
	+ by (auto simp add: comp_assoc is_moebius_def)
	+ qed
	+ moreover
	+ have "?M z1 \<noteq> ?M z2" "?M z1 \<noteq> ?M z3" "?M z2 \<noteq> ?M z3"
	+ using assms
	+ by (auto simp add: conjugate_inj)
	+ ultimately
	+ have "conjugate \<circ> ?f \<circ> ?iM = (\<lambda> z. cross_ratio z (?M z1) (?M z2) (?M z3))"
	+ using assms
	+ using is_cross_ratio_01inf[of "?M z1" "?M z2" "?M z3" "conjugate \<circ> ?f \<circ> ?iM"]
	+ by simp
	+ moreover
	+ have "(conjugate \<circ> ?f \<circ> ?iM) (?M z) = conjugate (cross_ratio z z1 z2 z3)"
	+ by simp
	+ moreover
	+ have "(\<lambda> z. cross_ratio z (?M z1) (?M z2) (?M z3)) (?M z) = cross_ratio (?M z) (?M z1) (?M z2) (?M z3)"
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by simp
	+qed
	+
	+lemma cross_ratio_reciprocal [simp]:
	+ assumes "u \<noteq> v" and "v \<noteq> w" and "u \<noteq> w"
	+ shows "cross_ratio (reciprocal z) (reciprocal u) (reciprocal v) (reciprocal w) =
	+ cross_ratio z u v w"
	+ using assms
	+ by (subst moebius_reciprocal[symmetric])+ (simp del: moebius_reciprocal)
	+
	+lemma cross_ratio_inversion [simp]:
	+ assumes "u \<noteq> v" and "v \<noteq> w" and "u \<noteq> w"
	+ shows "cross_ratio (inversion z) (inversion u) (inversion v) (inversion w) =
	+ conjugate (cross_ratio z u v w)"
	+proof-
	+ have "reciprocal u \<noteq> reciprocal v" "reciprocal u \<noteq> reciprocal w" "reciprocal v \<noteq> reciprocal w"
	+ using assms
	+ by ((subst moebius_reciprocal[symmetric])+, simp del: moebius_reciprocal)+
	+ thus ?thesis
	+ using assms
	+ unfolding inversion_def
	+ by simp
	+qed
	+
	+
	+lemma fixed_points_0inf':
	+ assumes "moebius_pt M 0\<^sub>h = 0\<^sub>h" and "moebius_pt M \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ shows "\<exists> k::complex_homo. (k \<noteq> 0\<^sub>h \<and> k \<noteq> \<infinity>\<^sub>h) \<and> (\<forall> z. moebius_pt M z = k *\<^sub>h z)"
	+using assms
	+proof (transfer, transfer)
	+ fix M :: complex_mat
	+ assume "mat_det M \<noteq> 0"
	+ obtain a b c d where MM: "M = (a, b, c, d)"
	+ by (cases M) auto
	+ assume "moebius_pt_cmat_cvec M 0\<^sub>v \<approx>\<^sub>v 0\<^sub>v" "moebius_pt_cmat_cvec M \<infinity>\<^sub>v \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ hence *: "b = 0" "c = 0" "a \<noteq> 0 \<and> d \<noteq> 0"
	+ using MM
	+ by auto
	+ let ?z = "(a, d)"
	+ have "?z \<noteq> vec_zero"
	+ using *
	+ by simp
	+ moreover
	+ have "\<not> ?z \<approx>\<^sub>v 0\<^sub>v \<and> \<not> ?z \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ using *
	+ by simp
	+ moreover
	+ have "\<forall>z\<in>{v. v \<noteq> vec_zero}. moebius_pt_cmat_cvec M z \<approx>\<^sub>v ?z *\<^sub>v z"
	+ using MM \<open>mat_det M \<noteq> 0\<close> *
	+ by force
	+ ultimately
	+ show "\<exists>k\<in>{v. v \<noteq> vec_zero}.
	+ (\<not> k \<approx>\<^sub>v 0\<^sub>v \<and> \<not> k \<approx>\<^sub>v \<infinity>\<^sub>v) \<and>
	+ (\<forall>z\<in>{v. v \<noteq> vec_zero}. moebius_pt_cmat_cvec M z \<approx>\<^sub>v k *\<^sub>v z)"
	+ by blast
	+qed
	+
	+lemma fixed_points_0inf:
	+ assumes "moebius_pt M 0\<^sub>h = 0\<^sub>h" and "moebius_pt M \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ shows "\<exists> k::complex_homo. (k \<noteq> 0\<^sub>h \<and> k \<noteq> \<infinity>\<^sub>h) \<and> moebius_pt M = (\<lambda> z. k *\<^sub>h z)"
	+ using fixed_points_0inf'[OF assms]
	+ by auto
	+
	+lemma ex_cross_ratio:
	+ assumes "u \<noteq> v" and "u \<noteq> w" and "v \<noteq> w"
	+ shows "\<exists> z. cross_ratio z u v w = c"
	+proof-
	+ obtain M where "(\<lambda> z. cross_ratio z u v w) = moebius_pt M"
	+ using assms is_moebius_cross_ratio[of u v w]
	+ unfolding is_moebius_def
	+ by auto
	+ hence *: "\<forall> z. cross_ratio z u v w = moebius_pt M z"
	+ by metis
	+ let ?z = "moebius_pt (-M) c"
	+ have "cross_ratio ?z u v w = c"
	+ using *
	+ by auto
	+ thus ?thesis
	+ by auto
	+qed
	+
	+lemma unique_cross_ratio:
	+ assumes "u \<noteq> v" and "v \<noteq> w" and "u \<noteq> w"
	+ assumes "cross_ratio z u v w = cross_ratio z' u v w"
	+ shows "z = z'"
	+proof-
	+ obtain M where "(\<lambda> z. cross_ratio z u v w) = moebius_pt M"
	+ using is_moebius_cross_ratio[OF assms(1-3)]
	+ unfolding is_moebius_def
	+ by auto
	+ hence "moebius_pt M z = moebius_pt M z'"
	+ using assms(4)
	+ by metis
	+ thus ?thesis
	+ using moebius_pt_eq_I
	+ by metis
	+qed
	+
	+lemma ex1_cross_ratio:
	+ assumes "u \<noteq> v" and "u \<noteq> w" and "v \<noteq> w"
	+ shows "\<exists>! z. cross_ratio z u v w = c"
	+ using assms ex_cross_ratio[OF assms, of c] unique_cross_ratio[of u v w]
	+ by blast
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Pole\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+definition is_pole :: "moebius \<Rightarrow> complex_homo \<Rightarrow> bool" where
	+ "is_pole M z \<longleftrightarrow> moebius_pt M z = \<infinity>\<^sub>h"
	+
	+lemma ex1_pole:
	+ shows "\<exists>! z. is_pole M z"
	+ using bij_moebius_pt[of M]
	+ unfolding is_pole_def bij_def inj_on_def surj_def
	+ unfolding Ex1_def
	+ by (metis UNIV_I)
	+
	+definition pole :: "moebius \<Rightarrow> complex_homo" where
	+ "pole M = (THE z. is_pole M z)"
	+
	+lemma pole_mk_moebius:
	+ assumes "is_pole (mk_moebius a b c d) z" and "c \<noteq> 0" and "ad - bc \<noteq> 0"
	+ shows "z = of_complex (-d/c)"
	+proof-
	+ let ?t1 = "moebius_translation (a / c)"
	+ let ?rd = "moebius_rotation_dilatation ((b * c - a * d) / (c * c))"
	+ let ?r = "moebius_reciprocal"
	+ let ?t2 = "moebius_translation (d / c)"
	+ have "moebius_pt (?rd + ?r + ?t2) z = \<infinity>\<^sub>h"
	+ using assms
	+ unfolding is_pole_def
	+ apply (subst (asm) moebius_decomposition)
	+ apply (auto simp add: moebius_comp[symmetric] moebius_translation_def)
	+ apply (subst moebius_similarity_only_inf_to_inf[of 1 "a/c"], auto)
	+ done
	+ hence "moebius_pt (?r + ?t2) z = \<infinity>\<^sub>h"
	+ using \<open>ad - bc \<noteq> 0\<close> \<open>c \<noteq> 0\<close>
	+ unfolding moebius_rotation_dilatation_def
	+ by (simp del: moebius_pt_moebius_similarity)
	+ hence "moebius_pt ?t2 z = 0\<^sub>h"
	+ by simp
	+ thus ?thesis
	+ using moebius_pt_invert[of ?t2 z "0\<^sub>h"]
	+ by simp ((subst (asm) of_complex_zero[symmetric])+, simp del: of_complex_zero)
	+qed
	+
	+lemma pole_similarity:
	+ assumes "is_pole (moebius_similarity a b) z" and "a \<noteq> 0"
	+ shows "z = \<infinity>\<^sub>h"
	+ using assms
	+ unfolding is_pole_def
	+ using moebius_similarity_only_inf_to_inf[of a b z]
	+ by simp
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Homographies and antihomographies\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Inversion is not a Möbius transformation (it is a canonical example of so called
	+anti-Möbius transformations, or antihomographies). All antihomographies are compositions of
	+homographies and conjugation. The fundamental theorem of projective geometry (that we shall not
	+prove) states that all automorphisms (bijective functions that preserve the cross-ratio) of
	+$\mathbb{C}P^1$ are either homographies or antihomographies.\<close>
	+
	+definition is_homography :: "(complex_homo \<Rightarrow> complex_homo) \<Rightarrow> bool" where
	+ "is_homography f \<longleftrightarrow> is_moebius f"
	+
	+definition is_antihomography :: "(complex_homo \<Rightarrow> complex_homo) \<Rightarrow> bool" where
	+ "is_antihomography f \<longleftrightarrow> (\<exists> f'. is_moebius f' \<and> f = f' \<circ> conjugate)"
	+
	+text \<open>Conjugation is not a Möbius transformation, but is antihomograhpy.\<close>
	+lemma not_moebius_conjugate:
	+ shows "\<not> is_moebius conjugate"
	+proof
	+ assume "is_moebius conjugate"
	+ then obtain M where *: "moebius_pt M = conjugate"
	+ unfolding is_moebius_def
	+ by metis
	+ hence "moebius_pt M 0\<^sub>h = 0\<^sub>h" "moebius_pt M 1\<^sub>h = 1\<^sub>h" "moebius_pt M \<infinity>\<^sub>h = \<infinity>\<^sub>h"
	+ by auto
	+ hence "M = id_moebius"
	+ using three_fixed_points_01inf
	+ by auto
	+ hence "conjugate = id"
	+ using *
	+ by simp
	+ moreover
	+ have "conjugate ii\<^sub>h \<noteq> ii\<^sub>h"
	+ using of_complex_inj[of "\<i>" "-\<i>"]
	+ by (subst of_complex_ii[symmetric])+ (auto simp del: of_complex_ii)
	+ ultimately
	+ show False
	+ by simp
	+qed
	+
	+lemma conjugation_is_antihomography[simp]:
	+ shows "is_antihomography conjugate"
	+ unfolding is_antihomography_def
	+ by (rule_tac x="id" in exI, metis fun.map_id0 id_apply is_moebius_def moebius_pt_moebius_id)
	+
	+lemma inversion_is_antihomography [simp]:
	+ shows "is_antihomography inversion"
	+ using moebius_reciprocal
	+ unfolding inversion_sym is_antihomography_def is_moebius_def
	+ by metis
	+
	+text \<open>Functions cannot simultaneously be homographies and antihomographies - the disjunction is exclusive.\<close>
	+lemma homography_antihomography_exclusive:
	+ assumes "is_antihomography f"
	+ shows "\<not> is_homography f"
	+proof
	+ assume "is_homography f"
	+ then obtain M where "f = moebius_pt M"
	+ unfolding is_homography_def is_moebius_def
	+ by auto
	+ then obtain M' where "moebius_pt M = moebius_pt M' \<circ> conjugate"
	+ using assms
	+ unfolding is_antihomography_def is_moebius_def
	+ by auto
	+ hence "conjugate = moebius_pt (-M') \<circ> moebius_pt M"
	+ by auto
	+ hence "conjugate = moebius_pt (-M' + M)"
	+ by (simp add: moebius_comp)
	+ thus False
	+ using not_moebius_conjugate
	+ unfolding is_moebius_def
	+ by metis
	+qed
	+
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Classification of Möbius transformations\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Möbius transformations can be classified to parabolic, elliptic and loxodromic. We do not
	+develop this part of the theory in depth.\<close>
	+
	+lemma similarity_scale_1:
	+ assumes "k \<noteq> 0"
	+ shows "similarity (k *\<^sub>s\<^sub>m I) M = similarity I M"
	+ using assms
	+ unfolding similarity_def
	+ using mat_inv_mult_sm[of k I]
	+ by simp
	+
	+lemma similarity_scale_2:
	+ shows "similarity I (k \<^sub>s\<^sub>m M) = k \<^sub>s\<^sub>m (similarity I M)"
	+ unfolding similarity_def
	+ by auto
	+
	+lemma mat_trace_mult_sm [simp]:
	+ shows "mat_trace (k \<^sub>s\<^sub>m M) = k mat_trace M"
	+ by (cases M) (simp add: field_simps)
	+
	+definition moebius_mb_cmat :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex_mat" where
	+ [simp]: "moebius_mb_cmat I M = similarity I M"
	+
	+lift_definition moebius_mb_mmat :: "moebius_mat \<Rightarrow> moebius_mat \<Rightarrow> moebius_mat" is moebius_mb_cmat
	+ by (simp add: similarity_def mat_det_inv)
	+
	+lift_definition moebius_mb :: "moebius \<Rightarrow> moebius \<Rightarrow> moebius" is moebius_mb_mmat
	+proof transfer
	+ fix M M' I I'
	+ assume "moebius_cmat_eq M M'" "moebius_cmat_eq I I'"
	+ thus "moebius_cmat_eq (moebius_mb_cmat I M) (moebius_mb_cmat I' M')"
	+ by (auto simp add: similarity_scale_1 similarity_scale_2)
	+qed
	+
	+definition similarity_invar_cmat :: "complex_mat \<Rightarrow> complex" where
	+ [simp]: "similarity_invar_cmat M = (mat_trace M)\<^sup>2 / mat_det M - 4"
	+
	+lift_definition similarity_invar_mmat :: "moebius_mat \<Rightarrow> complex" is similarity_invar_cmat
	+ done
	+
	+lift_definition similarity_invar :: "moebius \<Rightarrow> complex" is similarity_invar_mmat
	+ by transfer (auto simp add: power2_eq_square field_simps)
	+
	+lemma similarity_invar_moeibus_mb:
	+ shows "similarity_invar (moebius_mb I M) = similarity_invar M"
	+ by (transfer, transfer, simp)
	+
	+definition similar :: "moebius \<Rightarrow> moebius \<Rightarrow> bool" where
	+ "similar M1 M2 \<longleftrightarrow> (\<exists> I. moebius_mb I M1 = M2)"
	+
	+lemma similar_refl [simp]:
	+ shows "similar M M"
	+ unfolding similar_def
	+ by (rule_tac x="id_moebius" in exI) (transfer, transfer, simp)
	+
	+lemma similar_sym:
	+ assumes "similar M1 M2"
	+ shows "similar M2 M1"
	+proof-
	+ from assms obtain I where "M2 = moebius_mb I M1"
	+ unfolding similar_def
	+ by auto
	+ hence "M1 = moebius_mb (moebius_inv I) M2"
	+ proof (transfer, transfer)
	+ fix M2 I M1
	+ assume "moebius_cmat_eq M2 (moebius_mb_cmat I M1)" "mat_det I \<noteq> 0"
	+ then obtain k where "k \<noteq> 0" "similarity I M1 = k *\<^sub>s\<^sub>m M2"
	+ by auto
	+ thus "moebius_cmat_eq M1 (moebius_mb_cmat (moebius_inv_cmat I) M2)"
	+ using similarity_inv[of I M1 "k *\<^sub>s\<^sub>m M2", OF _ \<open>mat_det I \<noteq> 0\<close>]
	+ by (auto simp add: similarity_scale_2) (rule_tac x="1/k" in exI, simp)
	+ qed
	+ thus ?thesis
	+ unfolding similar_def
	+ by auto
	+qed
	+
	+lemma similar_trans:
	+ assumes "similar M1 M2" and "similar M2 M3"
	+ shows "similar M1 M3"
	+proof-
	+ obtain I1 I2 where "moebius_mb I1 M1 = M2" "moebius_mb I2 M2 = M3"
	+ using assms
	+ by (auto simp add: similar_def)
	+ thus ?thesis
	+ unfolding similar_def
	+ proof (rule_tac x="moebius_comp I1 I2" in exI, transfer, transfer)
	+ fix I1 I2 M1 M2 M3
	+ assume "moebius_cmat_eq (moebius_mb_cmat I1 M1) M2"
	+ "moebius_cmat_eq (moebius_mb_cmat I2 M2) M3"
	+ "mat_det I1 \<noteq> 0" "mat_det I2 \<noteq> 0"
	+ thus "moebius_cmat_eq (moebius_mb_cmat (moebius_comp_cmat I1 I2) M1) M3"
	+ by (auto simp add: similarity_scale_2) (rule_tac x="ka*k" in exI, simp)
	+ qed
	+qed
	+
	+end
	diff --git a/thys/Complex_Geometry/More_Complex.thy b/thys/Complex_Geometry/More_Complex.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/More_Complex.thy
	@@ -0,0 +1,1264 @@
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Library Additions for Complex Numbers\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Some additional lemmas about complex numbers.\<close>
	+
	+theory More_Complex
	+ imports Complex_Main More_Transcendental Canonical_Angle
	+begin
	+
	+text \<open>Conjugation and @{term cis}\<close>
	+
	+declare cis_cnj[simp]
	+
	+lemma rcis_cnj:
	+ shows "cnj a = rcis (cmod a) (- arg a)"
	+ by (subst rcis_cmod_arg[of a, symmetric]) (simp add: rcis_def)
	+
	+lemmas complex_cnj = complex_cnj_diff complex_cnj_mult complex_cnj_add complex_cnj_divide complex_cnj_minus
	+
	+text \<open>Some properties for @{term complex_of_real}. Also, since it is often used in our
	+formalization we abbreviate it to @{term cor}.\<close>
	+
	+abbreviation cor :: "real \<Rightarrow> complex" where
	+ "cor \<equiv> complex_of_real"
	+
	+lemma cor_neg_one [simp]:
	+ shows "cor (-1) = -1"
	+ by simp
	+
	+lemma neg_cor_neg_one [simp]:
	+ shows "- cor (-1) = 1"
	+ by simp
	+
	+lemma cmod_cis [simp]:
	+ assumes "a \<noteq> 0"
	+ shows "cor (cmod a) * cis (arg a) = a"
	+ using assms
	+ by (metis rcis_cmod_arg rcis_def)
	+
	+lemma cis_cmod [simp]:
	+ assumes "a \<noteq> 0"
	+ shows "cis (arg a) * cor (cmod a) = a"
	+ using assms cmod_cis[of a]
	+ by (simp add: field_simps)
	+
	+lemma cor_add:
	+ shows "cor (a + b) = cor a + cor b"
	+ by (rule of_real_add)
	+
	+lemma cor_mult:
	+ shows "cor (a * b) = cor a * cor b"
	+ by (rule of_real_mult)
	+
	+lemma cor_squared:
	+ shows "(cor x)\<^sup>2 = cor (x\<^sup>2)"
	+ by (simp add: power2_eq_square)
	+
	+lemma cor_sqrt_mult_cor_sqrt [simp]:
	+ shows "cor (sqrt A) * cor (sqrt A) = cor \<bar>A\<bar>"
	+ by (metis cor_mult real_sqrt_abs2 real_sqrt_mult)
	+
	+lemma cor_eq_0: "cor x + \<i> * cor y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
	+ by (metis Complex_eq Im_complex_of_real Im_i_times Re_complex_of_real add_cancel_left_left of_real_eq_0_iff plus_complex.sel(2) zero_complex.code)
	+
	+lemma one_plus_square_neq_zero [simp]:
	+ shows "1 + (cor x)\<^sup>2 \<noteq> 0"
	+ by (metis (hide_lams, no_types) of_real_1 of_real_add of_real_eq_0_iff of_real_power power_one sum_power2_eq_zero_iff zero_neq_one)
	+
	+text \<open>Additional lemmas about @{term Complex} constructor. Following newer versions of Isabelle,
	+these should be deprecated.\<close>
	+
	+lemma complex_real_two [simp]:
	+ shows "Complex 2 0 = 2"
	+ by (simp add: Complex_eq)
	+
	+lemma complex_double [simp]:
	+ shows "(Complex a b) * 2 = Complex (2a) (2b)"
	+ by (simp add: Complex_eq)
	+
	+lemma complex_half [simp]:
	+ shows "(Complex a b) / 2 = Complex (a/2) (b/2)"
	+ by (subst complex_eq_iff) auto
	+
	+lemma Complex_scale1:
	+ shows "Complex (a * b) (a * c) = cor a * Complex b c"
	+ unfolding complex_of_real_def
	+ unfolding Complex_eq
	+ by (auto simp add: field_simps)
	+
	+lemma Complex_scale2:
	+ shows "Complex (a * c) (b * c) = Complex a b * cor c"
	+ unfolding complex_of_real_def
	+ unfolding Complex_eq
	+ by (auto simp add: field_simps)
	+
	+lemma Complex_scale3:
	+ shows "Complex (a / b) (a / c) = cor a * Complex (1 / b) (1 / c)"
	+ unfolding complex_of_real_def
	+ unfolding Complex_eq
	+ by (auto simp add: field_simps)
	+
	+lemma Complex_scale4:
	+ shows "c \<noteq> 0 \<Longrightarrow> Complex (a / c) (b / c) = Complex a b / cor c"
	+ unfolding complex_of_real_def
	+ unfolding Complex_eq
	+ by (auto simp add: field_simps power2_eq_square)
	+
	+lemma Complex_Re_express_cnj:
	+ shows "Complex (Re z) 0 = (z + cnj z) / 2"
	+ by (cases z) (simp add: Complex_eq)
	+
	+lemma Complex_Im_express_cnj:
	+ shows "Complex 0 (Im z) = (z - cnj z)/2"
	+ by (cases z) (simp add: Complex_eq)
	+
	+text \<open>Additional properties of @{term cmod}.\<close>
	+
	+lemma complex_mult_cnj_cmod:
	+ shows "z * cnj z = cor ((cmod z)\<^sup>2)"
	+ using complex_norm_square
	+ by auto
	+
	+lemma cmod_square:
	+ shows "(cmod z)\<^sup>2 = Re (z * cnj z)"
	+ using complex_mult_cnj_cmod[of z]
	+ by (simp add: power2_eq_square)
	+
	+lemma cor_cmod_power_4 [simp]:
	+ shows "cor (cmod z) ^ 4 = (z * cnj z)\<^sup>2"
	+ by (metis complex_norm_square cor_squared numeral_times_numeral power2_eq_square semiring_norm(11) semiring_norm(13) semiring_normalization_rules(36))
	+
	+lemma cnjE:
	+ assumes "x \<noteq> 0"
	+ shows "cnj x = cor ((cmod x)\<^sup>2) / x"
	+ using complex_mult_cnj_cmod[of x] assms
	+ by (auto simp add: field_simps)
	+
	+lemma cmod_mult [simp]:
	+ shows "cmod (a * b) = cmod a * cmod b"
	+ by (rule norm_mult)
	+
	+lemma cmod_divide [simp]:
	+ shows "cmod (a / b) = cmod a / cmod b"
	+ by (rule norm_divide)
	+
	+lemma cmod_cor_divide [simp]:
	+ shows "cmod (z / cor k) = cmod z / \<bar>k\<bar>"
	+ by auto
	+
	+lemma cmod_mult_minus_left_distrib [simp]:
	+ shows "cmod (zz1 - zz2) = cmod z * cmod(z1 - z2)"
	+ by (metis bounded_bilinear.diff_right bounded_bilinear_mult cmod_mult)
	+
	+lemma cmod_eqI:
	+ assumes "z1 * cnj z1 = z2 * cnj z2"
	+ shows "cmod z1 = cmod z2"
	+ using assms
	+ by (subst complex_mod_sqrt_Re_mult_cnj)+ auto
	+
	+lemma cmod_eqE:
	+ assumes "cmod z1 = cmod z2"
	+ shows "z1 * cnj z1 = z2 * cnj z2"
	+proof-
	+ from assms have "cor ((cmod z1)\<^sup>2) = cor ((cmod z2)\<^sup>2)"
	+ by auto
	+ thus ?thesis
	+ using complex_mult_cnj_cmod
	+ by auto
	+qed
	+
	+lemma cmod_eq_one [simp]:
	+ shows "cmod a = 1 \<longleftrightarrow> a*cnj a = 1"
	+ by (metis cmod_eqE cmod_eqI complex_cnj_one monoid_mult_class.mult.left_neutral norm_one)
	+
	+text \<open>We introduce @{term is_real} (the imaginary part of complex number is zero) and @{term is_imag}
	+(real part of complex number is zero) operators and prove some of their properties.\<close>
	+
	+abbreviation is_real where
	+ "is_real z \<equiv> Im z = 0"
	+
	+abbreviation is_imag where
	+ "is_imag z \<equiv> Re z = 0"
	+
	+lemma real_imag_0:
	+ assumes "is_real a" "is_imag a"
	+ shows "a = 0"
	+ using assms
	+ by (simp add: complex.expand)
	+
	+lemma complex_eq_if_Re_eq:
	+ assumes "is_real z1" and "is_real z2"
	+ shows "z1 = z2 \<longleftrightarrow> Re z1 = Re z2"
	+ using assms
	+ by (cases z1, cases z2) auto
	+
	+lemma mult_reals [simp]:
	+ assumes "is_real a" and "is_real b"
	+ shows "is_real (a * b)"
	+ using assms
	+ by auto
	+
	+lemma div_reals [simp]:
	+ assumes "is_real a" and "is_real b"
	+ shows "is_real (a / b)"
	+ using assms
	+ by (simp add: complex_is_Real_iff)
	+
	+lemma complex_of_real_Re [simp]:
	+ assumes "is_real k"
	+ shows "cor (Re k) = k"
	+ using assms
	+ by (cases k) (auto simp add: complex_of_real_def)
	+
	+lemma cor_cmod_real:
	+ assumes "is_real a"
	+ shows "cor (cmod a) = a \<or> cor (cmod a) = -a"
	+ using assms
	+ unfolding cmod_def
	+ by (cases "Re a > 0") auto
	+
	+lemma eq_cnj_iff_real:
	+ shows "cnj z = z \<longleftrightarrow> is_real z"
	+ by (cases z) (simp add: Complex_eq)
	+
	+lemma eq_minus_cnj_iff_imag:
	+ shows "cnj z = -z \<longleftrightarrow> is_imag z"
	+ by (cases z) (simp add: Complex_eq)
	+
	+lemma Re_divide_real:
	+ assumes "is_real b" and "b \<noteq> 0"
	+ shows "Re (a / b) = (Re a) / (Re b)"
	+ using assms
	+ by (simp add: complex_is_Real_iff)
	+
	+lemma Re_mult_real:
	+ assumes "is_real a"
	+ shows "Re (a * b) = (Re a) * (Re b)"
	+ using assms
	+ by simp
	+
	+lemma Im_mult_real:
	+ assumes "is_real a"
	+ shows "Im (a * b) = (Re a) * (Im b)"
	+ using assms
	+ by simp
	+
	+lemma Im_divide_real:
	+ assumes "is_real b" and "b \<noteq> 0"
	+ shows "Im (a / b) = (Im a) / (Re b)"
	+ using assms
	+ by (simp add: complex_is_Real_iff)
	+
	+lemma Re_half [simp]:
	+ shows "Re (x / 2) = Re x / 2"
	+ by (rule Re_divide_numeral)
	+
	+lemma Re_double [simp]:
	+ shows "Re (2 * x) = 2 * Re x"
	+ using Re_mult_real[of "2" x]
	+ by simp
	+
	+lemma Im_half [simp]:
	+ shows "Im (z / 2) = Im z / 2"
	+ by (subst Im_divide_real, auto)
	+
	+lemma Im_double [simp]:
	+ shows "Im (2 * z) = 2 * Im z"
	+ using Im_mult_real[of "2" z]
	+ by simp
	+
	+lemma Re_sgn:
	+ assumes "is_real R"
	+ shows "Re (sgn R) = sgn (Re R)"
	+ using assms
	+ by (metis Re_sgn complex_of_real_Re norm_of_real real_sgn_eq)
	+
	+lemma is_real_div:
	+ assumes "b \<noteq> 0"
	+ shows "is_real (a / b) \<longleftrightarrow> acnj b = bcnj a"
	+ using assms
	+ by (metis complex_cnj_divide complex_cnj_zero_iff eq_cnj_iff_real frac_eq_eq mult.commute)
	+
	+lemma is_real_mult_real:
	+ assumes "is_real a" and "a \<noteq> 0"
	+ shows "is_real b \<longleftrightarrow> is_real (a * b)"
	+ using assms
	+ by (cases a, auto simp add: Complex_eq)
	+
	+lemma Im_express_cnj:
	+ shows "Im z = (z - cnj z) / (2 * \<i>)"
	+ by (simp add: complex_diff_cnj field_simps)
	+
	+lemma Re_express_cnj:
	+ shows "Re z = (z + cnj z) / 2"
	+ by (simp add: complex_add_cnj)
	+
	+text \<open>Rotation of complex number for 90 degrees in the positive direction.\<close>
	+
	+abbreviation rot90 where
	+ "rot90 z \<equiv> Complex (-Im z) (Re z)"
	+
	+lemma rot90_ii:
	+ shows "rot90 z = z * \<i>"
	+ by (metis Complex_mult_i complex_surj)
	+
	+text \<open>With @{term cnj_mix} we introduce scalar product between complex vectors. This operation shows
	+to be useful to succinctly express some conditions.\<close>
	+
	+abbreviation cnj_mix where
	+ "cnj_mix z1 z2 \<equiv> cnj z1 * z2 + z1 * cnj z2"
	+
	+abbreviation scalprod where
	+ "scalprod z1 z2 \<equiv> cnj_mix z1 z2 / 2"
	+
	+lemma cnj_mix_minus:
	+ shows "cnj z1z2 - z1cnj z2 = \<i> * cnj_mix (rot90 z1) z2"
	+ by (cases z1, cases z2) (simp add: Complex_eq field_simps)
	+
	+lemma cnj_mix_minus':
	+ shows "cnj z1z2 - z1cnj z2 = rot90 (cnj_mix (rot90 z1) z2)"
	+ by (cases z1, cases z2) (simp add: Complex_eq field_simps)
	+
	+lemma cnj_mix_real [simp]:
	+ shows "is_real (cnj_mix z1 z2)"
	+ by (cases z1, cases z2) simp
	+
	+lemma scalprod_real [simp]:
	+ shows "is_real (scalprod z1 z2)"
	+ using cnj_mix_real
	+ by simp
	+
	+text \<open>Additional properties of @{term cis} function.\<close>
	+
	+lemma cis_minus_pi2 [simp]:
	+ shows "cis (-pi/2) = -\<i>"
	+ by (simp add: cis_inverse[symmetric])
	+
	+lemma cis_pi2_minus_x [simp]:
	+ shows "cis (pi/2 - x) = \<i> * cis(-x)"
	+ using cis_divide[of "pi/2" x, symmetric]
	+ using cis_divide[of 0 x, symmetric]
	+ by simp
	+
	+lemma cis_pm_pi [simp]:
	+ shows "cis (x - pi) = - cis x" and "cis (x + pi) = - cis x"
	+ by (simp add: cis.ctr complex_minus)+
	+
	+
	+lemma cis_times_cis_opposite [simp]:
	+ shows "cis \<phi> * cis (- \<phi>) = 1"
	+ by (simp add: cis_mult)
	+
	+text \<open>@{term cis} repeats only after $2k\pi$\<close>
	+lemma cis_eq:
	+ assumes "cis a = cis b"
	+ shows "\<exists> k::int. a - b = 2 * k * pi"
	+ using assms sin_cos_eq[of a b]
	+ using cis.sel[of a] cis.sel[of b]
	+ by (cases "cis a", cases "cis b") auto
	+
	+text \<open>@{term cis} is injective on $(-\pi, \pi]$.\<close>
	+lemma cis_inj:
	+ assumes "-pi < \<alpha>" and "\<alpha> \<le> pi" and "-pi < \<alpha>'" and "\<alpha>' \<le> pi"
	+ assumes "cis \<alpha> = cis \<alpha>'"
	+ shows "\<alpha> = \<alpha>'"
	+ using assms
	+ by (metis arg_unique sgn_cis)
	+
	+text \<open>@{term cis} of an angle combined with @{term cis} of the opposite angle\<close>
	+
	+lemma cis_diff_cis_opposite [simp]:
	+ shows "cis \<phi> - cis (- \<phi>) = 2 * \<i> * sin \<phi>"
	+ using Im_express_cnj[of "cis \<phi>"]
	+ by simp
	+
	+lemma cis_opposite_diff_cis [simp]:
	+ shows "cis (-\<phi>) - cis (\<phi>) = - 2 * \<i> * sin \<phi>"
	+ using cis_diff_cis_opposite[of "-\<phi>"]
	+ by simp
	+
	+lemma cis_add_cis_opposite [simp]:
	+ shows "cis \<phi> + cis (-\<phi>) = 2 * cos \<phi>"
	+proof-
	+ have "2 * cos \<phi> = (cis \<phi> + cnj (cis \<phi>))"
	+ using Re_express_cnj[of "cis \<phi>"]
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ by simp
	+qed
	+
	+text \<open>@{term cis} equal to 1 or -1\<close>
	+lemma cis_one [simp]:
	+ assumes "sin \<phi> = 0" and "cos \<phi> = 1"
	+ shows "cis \<phi> = 1"
	+ using assms
	+ by (auto simp add: cis.ctr one_complex.code)
	+
	+lemma cis_minus_one [simp]:
	+ assumes "sin \<phi> = 0" and "cos \<phi> = -1"
	+ shows "cis \<phi> = -1"
	+ using assms
	+ by (auto simp add: cis.ctr Complex_eq_neg_1)
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Additional properties of complex number argument\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>@{term arg} of real numbers\<close>
	+
	+lemma is_real_arg1:
	+ assumes "arg z = 0 \<or> arg z = pi"
	+ shows "is_real z"
	+ using assms
	+ using rcis_cmod_arg[of z] Im_rcis[of "cmod z" "arg z"]
	+ by auto
	+
	+lemma is_real_arg2:
	+ assumes "is_real z"
	+ shows "arg z = 0 \<or> arg z = pi"
	+proof (cases "z = 0")
	+ case True
	+ thus ?thesis
	+ by (auto simp add: arg_zero)
	+next
	+ case False
	+ hence "sin (arg z) = 0"
	+ using assms rcis_cmod_arg[of z] Im_rcis[of "cmod z" "arg z"]
	+ by auto
	+ thus ?thesis
	+ using arg_bounded[of z]
	+ using sin_0_iff_canon
	+ by simp
	+qed
	+
	+lemma arg_complex_of_real_positive [simp]:
	+ assumes "k > 0"
	+ shows "arg (cor k) = 0"
	+proof-
	+ have "cos (arg (Complex k 0)) > 0"
	+ using assms
	+ using rcis_cmod_arg[of "Complex k 0"] Re_rcis[of "cmod (Complex k 0)" "arg (Complex k 0)"]
	+ by (smt complex.sel(1) mult_nonneg_nonpos norm_ge_zero)
	+ thus ?thesis
	+ using assms is_real_arg2[of "cor k"]
	+ unfolding complex_of_real_def
	+ by auto
	+qed
	+
	+lemma arg_complex_of_real_negative [simp]:
	+ assumes "k < 0"
	+ shows "arg (cor k) = pi"
	+proof-
	+ have "cos (arg (Complex k 0)) < 0"
	+ using \<open>k < 0\<close> rcis_cmod_arg[of "Complex k 0"] Re_rcis[of "cmod (Complex k 0)" "arg (Complex k 0)"]
	+ by (smt complex.sel(1) mult_nonneg_nonneg norm_ge_zero)
	+ thus ?thesis
	+ using assms is_real_arg2[of "cor k"]
	+ unfolding complex_of_real_def
	+ by auto
	+qed
	+
	+lemma arg_0_iff:
	+ shows "z \<noteq> 0 \<and> arg z = 0 \<longleftrightarrow> is_real z \<and> Re z > 0"
	+ by (smt arg_complex_of_real_negative arg_complex_of_real_positive arg_zero complex_of_real_Re is_real_arg1 pi_gt_zero zero_complex.simps)
	+
	+lemma arg_pi_iff:
	+ shows "arg z = pi \<longleftrightarrow> is_real z \<and> Re z < 0"
	+ by (smt arg_complex_of_real_negative arg_complex_of_real_positive arg_zero complex_of_real_Re is_real_arg1 pi_gt_zero zero_complex.simps)
	+
	+
	+text \<open>@{term arg} of imaginary numbers\<close>
	+
	+lemma is_imag_arg1:
	+ assumes "arg z = pi/2 \<or> arg z = -pi/2"
	+ shows "is_imag z"
	+ using assms
	+ using rcis_cmod_arg[of z] Re_rcis[of "cmod z" "arg z"]
	+ by (metis cos_minus cos_pi_half minus_divide_left mult_eq_0_iff)
	+
	+lemma is_imag_arg2:
	+ assumes "is_imag z" and "z \<noteq> 0"
	+ shows "arg z = pi/2 \<or> arg z = -pi/2"
	+proof-
	+ have "cos (arg z) = 0"
	+ using assms
	+ by (metis Re_rcis no_zero_divisors norm_eq_zero rcis_cmod_arg)
	+ thus ?thesis
	+ using arg_bounded[of z]
	+ using cos_0_iff_canon[of "arg z"]
	+ by simp
	+qed
	+
	+lemma arg_complex_of_real_times_i_positive [simp]:
	+ assumes "k > 0"
	+ shows "arg (cor k * \<i>) = pi / 2"
	+proof-
	+ have "sin (arg (Complex 0 k)) > 0"
	+ using \<open>k > 0\<close> rcis_cmod_arg[of "Complex 0 k"] Im_rcis[of "cmod (Complex 0 k)" "arg (Complex 0 k)"]
	+ by (smt complex.sel(2) mult_nonneg_nonpos norm_ge_zero)
	+ thus ?thesis
	+ using assms is_imag_arg2[of "cor k * \<i>"]
	+ using arg_zero complex_of_real_i
	+ by force
	+qed
	+
	+lemma arg_complex_of_real_times_i_negative [simp]:
	+ assumes "k < 0"
	+ shows "arg (cor k * \<i>) = - pi / 2"
	+proof-
	+ have "sin (arg (Complex 0 k)) < 0"
	+ using \<open>k < 0\<close> rcis_cmod_arg[of "Complex 0 k"] Im_rcis[of "cmod (Complex 0 k)" "arg (Complex 0 k)"]
	+ by (smt complex.sel(2) mult_nonneg_nonneg norm_ge_zero)
	+ thus ?thesis
	+ using assms is_imag_arg2[of "cor k * \<i>"]
	+ using arg_zero complex_of_real_i[of k]
	+ by (smt complex.sel(1) sin_pi_half sin_zero)
	+qed
	+
	+lemma arg_pi2_iff:
	+ shows "z \<noteq> 0 \<and> arg z = pi / 2 \<longleftrightarrow> is_imag z \<and> Im z > 0"
	+ by (smt Im_rcis Re_i_times Re_rcis arcsin_minus_1 cos_pi_half divide_minus_left mult.commute mult_cancel_right1 rcis_cmod_arg is_imag_arg2 sin_arcsin sin_pi_half zero_less_mult_pos zero_less_norm_iff)
	+
	+lemma arg_minus_pi2_iff:
	+ shows "z \<noteq> 0 \<and> arg z = - pi / 2 \<longleftrightarrow> is_imag z \<and> Im z < 0"
	+ by (smt arg_pi2_iff complex.expand divide_cancel_right pi_neq_zero is_imag_arg1 is_imag_arg2 zero_complex.simps(1) zero_complex.simps(2))
	+
	+lemma arg_ii [simp]:
	+ shows "arg \<i> = pi/2"
	+proof-
	+ have "\<i> = cis (arg \<i>)"
	+ using rcis_cmod_arg[of \<i>]
	+ by (simp add: rcis_def)
	+ hence "cos (arg \<i>) = 0" "sin (arg \<i>) = 1"
	+ by (metis cis.simps(1) imaginary_unit.simps(1), metis cis.simps(2) imaginary_unit.simps(2))
	+ thus ?thesis
	+ using cos_0_iff_canon[of "arg \<i>"] arg_bounded[of \<i>]
	+ by auto
	+qed
	+
	+lemma arg_minus_ii [simp]:
	+ shows "arg (-\<i>) = -pi/2"
	+proof-
	+ have "-\<i> = cis (arg (- \<i>))"
	+ using rcis_cmod_arg[of "-\<i>"]
	+ by (simp add: rcis_def)
	+ hence "cos (arg (-\<i>)) = 0" "sin (arg (-\<i>)) = -1"
	+ using cis.simps[of "arg (-\<i>)"]
	+ by auto
	+ thus ?thesis
	+ using cos_0_iff_canon[of "arg (-\<i>)"] arg_bounded[of "-\<i>"]
	+ by fastforce
	+qed
	+
	+text \<open>Argument is a canonical angle\<close>
	+
	+lemma canon_ang_arg:
	+ shows "\<downharpoonright>arg z\<downharpoonleft> = arg z"
	+ using canon_ang_id[of "arg z"] arg_bounded
	+ by simp
	+
	+lemma arg_cis:
	+ shows "arg (cis \<phi>) = \<downharpoonright>\<phi>\<downharpoonleft>"
	+proof (rule canon_ang_eqI[symmetric])
	+ show "- pi < arg (cis \<phi>) \<and> arg (cis \<phi>) \<le> pi"
	+ using arg_bounded
	+ by simp
	+next
	+ show "\<exists> k::int. arg (cis \<phi>) - \<phi> = 2kpi"
	+ proof-
	+ have "cis (arg (cis \<phi>)) = cis \<phi>"
	+ using cis_arg[of "cis \<phi>"]
	+ by auto
	+ thus ?thesis
	+ using cis_eq
	+ by auto
	+ qed
	+qed
	+
	+text \<open>Cosine and sine of @{term arg}\<close>
	+
	+lemma cos_arg:
	+ assumes "z \<noteq> 0"
	+ shows "cos (arg z) = Re z / cmod z"
	+ by (metis Complex.Re_sgn cis.simps(1) assms cis_arg)
	+
	+lemma sin_arg:
	+ assumes "z \<noteq> 0"
	+ shows "sin (arg z) = Im z / cmod z"
	+ by (metis Complex.Im_sgn cis.simps(2) assms cis_arg)
	+
	+text \<open>Argument of product\<close>
	+
	+lemma cis_arg_mult:
	+ assumes "z1 * z2 \<noteq> 0"
	+ shows "cis (arg (z1 * z2)) = cis (arg z1 + arg z2)"
	+proof-
	+ have "z1 * z2 = cor (cmod z1) * cor (cmod z2) * cis (arg z1) * cis (arg z2)"
	+ using rcis_cmod_arg[of z1, symmetric] rcis_cmod_arg[of z2, symmetric]
	+ unfolding rcis_def
	+ by algebra
	+ hence "z1 * z2 = cor (cmod (z1 * z2)) * cis (arg z1 + arg z2)"
	+ using cis_mult[of "arg z1" "arg z2"]
	+ by auto
	+ hence "cor (cmod (z1 * z2)) * cis (arg z1 + arg z2) = cor (cmod (z1 * z2)) * cis (arg (z1 * z2))"
	+ using assms
	+ using rcis_cmod_arg[of "z1*z2"]
	+ unfolding rcis_def
	+ by auto
	+ thus ?thesis
	+ using mult_cancel_left[of "cor (cmod (z1 * z2))" "cis (arg z1 + arg z2)" "cis (arg (z1 * z2))"]
	+ using assms
	+ by auto
	+qed
	+
	+lemma arg_mult_2kpi:
	+ assumes "z1 * z2 \<noteq> 0"
	+ shows "\<exists> k::int. arg (z1 * z2) = arg z1 + arg z2 + 2kpi"
	+proof-
	+ have "cis (arg (z1*z2)) = cis (arg z1 + arg z2)"
	+ by (rule cis_arg_mult[OF assms])
	+ thus ?thesis
	+ using cis_eq[of "arg (z1*z2)" "arg z1 + arg z2"]
	+ by (auto simp add: field_simps)
	+qed
	+
	+lemma arg_mult:
	+ assumes "z1 * z2 \<noteq> 0"
	+ shows "arg(z1 * z2) = \<downharpoonright>arg z1 + arg z2\<downharpoonleft>"
	+proof-
	+ obtain k::int where "arg(z1 * z2) = arg z1 + arg z2 + 2kpi"
	+ using arg_mult_2kpi[of z1 z2]
	+ using assms
	+ by auto
	+ hence "\<downharpoonright>arg(z1 * z2)\<downharpoonleft> = \<downharpoonright>arg z1 + arg z2\<downharpoonleft>"
	+ using canon_ang_eq
	+ by(simp add:field_simps)
	+ thus ?thesis
	+ using canon_ang_arg[of "z1*z2"]
	+ by auto
	+qed
	+
	+lemma arg_mult_real_positive [simp]:
	+ assumes "k > 0"
	+ shows "arg (cor k * z) = arg z"
	+proof (cases "z = 0")
	+ case True
	+ thus ?thesis
	+ by (auto simp add: arg_zero)
	+next
	+ case False
	+ thus ?thesis
	+ using assms
	+ using arg_mult[of "cor k" z]
	+ by (auto simp add: canon_ang_arg)
	+qed
	+
	+lemma arg_mult_real_negative [simp]:
	+ assumes "k < 0"
	+ shows "arg (cor k * z) = arg (-z)"
	+proof (cases "z = 0")
	+ case True
	+ thus ?thesis
	+ by (auto simp add: arg_zero)
	+next
	+ case False
	+ thus ?thesis
	+ using assms
	+ using arg_mult[of "cor k" z]
	+ using arg_mult[of "-1" z]
	+ using arg_complex_of_real_negative[of k] arg_complex_of_real_negative[of "-1"]
	+ by auto
	+qed
	+
	+lemma arg_div_real_positive [simp]:
	+ assumes "k > 0"
	+ shows "arg (z / cor k) = arg z"
	+proof(cases "z = 0")
	+ case True
	+ thus ?thesis
	+ by auto
	+next
	+ case False
	+ thus ?thesis
	+ using assms
	+ using arg_mult_real_positive[of "1/k" z]
	+ by auto
	+qed
	+
	+lemma arg_div_real_negative [simp]:
	+ assumes "k < 0"
	+ shows "arg (z / cor k) = arg (-z)"
	+proof(cases "z = 0")
	+ case True
	+ thus ?thesis
	+ by auto
	+next
	+ case False
	+ thus ?thesis
	+ using assms
	+ using arg_mult_real_negative[of "1/k" z]
	+ by auto
	+qed
	+
	+lemma arg_mult_eq:
	+ assumes "z * z1 \<noteq> 0" and "z * z2 \<noteq> 0"
	+ assumes "arg (z * z1) = arg (z * z2)"
	+ shows "arg z1 = arg z2"
	+proof-
	+ from assms have "\<downharpoonright>arg z + arg z1\<downharpoonleft> = \<downharpoonright>arg z + arg z2\<downharpoonleft>"
	+ by (simp add: arg_mult)
	+ then obtain x::int where : "arg z1 - arg z2 = 2 x * pi"
	+ using canon_ang_eqE[of "arg z + arg z1" "arg z + arg z2"]
	+ by auto
	+ moreover
	+ have "arg z1 - arg z2 < 2pi" "arg z1 - arg z2 > -2pi"
	+ using arg_bounded[of z1] arg_bounded[of z2]
	+ by auto
	+ ultimately
	+ have "-1 < x" "x < 1"
	+ using divide_strict_right_mono[of "-pi" "pi * x" pi]
	+ by auto
	+ hence "x = 0"
	+ by auto
	+ thus ?thesis
	+ using *
	+ by simp
	+qed
	+
	+text \<open>Argument of conjugate\<close>
	+
	+lemma arg_cnj_pi:
	+ assumes "arg z = pi"
	+ shows "arg (cnj z) = pi"
	+proof-
	+ have "cos (arg (cnj z)) = cos (arg z)"
	+ using rcis_cmod_arg[of z, symmetric] Re_rcis[of "cmod z" "arg z"]
	+ using rcis_cmod_arg[of "cnj z", symmetric] Re_rcis[of "cmod (cnj z)" "arg (cnj z)"]
	+ by auto
	+ hence "arg (cnj z) = arg z \<or> arg(cnj z) = -arg z"
	+ using arg_bounded[of z] arg_bounded[of "cnj z"]
	+ by (metis arccos_cos arccos_cos2 less_eq_real_def linorder_le_cases minus_minus)
	+ thus ?thesis
	+ using assms
	+ using arg_bounded[of "cnj z"]
	+ by auto
	+qed
	+
	+lemma arg_cnj_not_pi:
	+ assumes "arg z \<noteq> pi"
	+ shows "arg (cnj z) = -arg z"
	+proof(cases "arg z = 0")
	+ case True
	+ thus ?thesis
	+ using eq_cnj_iff_real[of z] is_real_arg1[of z] by force
	+next
	+ case False
	+ have "cos (arg (cnj z)) = cos (arg z)"
	+ using rcis_cmod_arg[of z] Re_rcis[of "cmod z" "arg z"]
	+ using rcis_cmod_arg[of "cnj z"] Re_rcis[of "cmod (cnj z)" "arg (cnj z)"]
	+ by auto
	+ hence "arg (cnj z) = arg z \<or> arg(cnj z) = -arg z"
	+ using arg_bounded[of z] arg_bounded[of "cnj z"]
	+ by (metis arccos_cos arccos_cos2 less_eq_real_def linorder_le_cases minus_minus)
	+ moreover
	+ have "sin (arg (cnj z)) = -sin (arg z)"
	+ using rcis_cmod_arg[of z] Im_rcis[of "cmod z" "arg z"]
	+ using rcis_cmod_arg[of "cnj z"] Im_rcis[of "cmod (cnj z)" "arg (cnj z)"]
	+ using calculation eq_cnj_iff_real is_real_arg2
	+ by force
	+ hence "arg (cnj z) \<noteq> arg z"
	+ using sin_0_iff_canon[of "arg (cnj z)"] arg_bounded False assms
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by auto
	+qed
	+
	+text \<open>Argument of reciprocal\<close>
	+
	+lemma arg_inv_not_pi:
	+ assumes "z \<noteq> 0" and "arg z \<noteq> pi"
	+ shows "arg (1 / z) = - arg z"
	+proof-
	+ have "1/z = cnj z / cor ((cmod z)\<^sup>2 )"
	+ using \<open>z \<noteq> 0\<close> complex_mult_cnj_cmod[of z]
	+ by (auto simp add:field_simps)
	+ thus ?thesis
	+ using arg_div_real_positive[of "(cmod z)\<^sup>2" "cnj z"] \<open>z \<noteq> 0\<close>
	+ using arg_cnj_not_pi[of z] \<open>arg z \<noteq> pi\<close>
	+ by auto
	+qed
	+
	+lemma arg_inv_pi:
	+ assumes "z \<noteq> 0" and "arg z = pi"
	+ shows "arg (1 / z) = pi"
	+proof-
	+ have "1/z = cnj z / cor ((cmod z)\<^sup>2 )"
	+ using \<open>z \<noteq> 0\<close> complex_mult_cnj_cmod[of z]
	+ by (auto simp add:field_simps)
	+ thus ?thesis
	+ using arg_div_real_positive[of "(cmod z)\<^sup>2" "cnj z"] \<open>z \<noteq> 0\<close>
	+ using arg_cnj_pi[of z] \<open>arg z = pi\<close>
	+ by auto
	+qed
	+
	+lemma arg_inv_2kpi:
	+ assumes "z \<noteq> 0"
	+ shows "\<exists> k::int. arg (1 / z) = - arg z + 2kpi"
	+ using arg_inv_pi[OF assms]
	+ using arg_inv_not_pi[OF assms]
	+ by (cases "arg z = pi") (rule_tac x="1" in exI, simp, rule_tac x="0" in exI, simp)
	+
	+lemma arg_inv:
	+ assumes "z \<noteq> 0"
	+ shows "arg (1 / z) = \<downharpoonright>- arg z\<downharpoonleft>"
	+proof-
	+ obtain k::int where "arg(1 / z) = - arg z + 2kpi"
	+ using arg_inv_2kpi[of z]
	+ using assms
	+ by auto
	+ hence "\<downharpoonright>arg(1 / z)\<downharpoonleft> = \<downharpoonright>- arg z\<downharpoonleft>"
	+ using canon_ang_eq
	+ by(simp add:field_simps)
	+ thus ?thesis
	+ using canon_ang_arg[of "1 / z"]
	+ by auto
	+qed
	+
	+text \<open>Argument of quotient\<close>
	+
	+lemma arg_div_2kpi:
	+ assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
	+ shows "\<exists> k::int. arg (z1 / z2) = arg z1 - arg z2 + 2kpi"
	+proof-
	+ obtain x1 where "arg (z1 * (1 / z2)) = arg z1 + arg (1 / z2) + 2 * real_of_int x1 * pi"
	+ using assms arg_mult_2kpi[of z1 "1/z2"]
	+ by auto
	+ moreover
	+ obtain x2 where "arg (1 / z2) = - arg z2 + 2 * real_of_int x2 * pi"
	+ using assms arg_inv_2kpi[of z2]
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by (rule_tac x="x1 + x2" in exI, simp add: field_simps)
	+qed
	+
	+lemma arg_div:
	+ assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
	+ shows "arg(z1 / z2) = \<downharpoonright>arg z1 - arg z2\<downharpoonleft>"
	+proof-
	+ obtain k::int where "arg(z1 / z2) = arg z1 - arg z2 + 2kpi"
	+ using arg_div_2kpi[of z1 z2]
	+ using assms
	+ by auto
	+ hence "canon_ang(arg(z1 / z2)) = canon_ang(arg z1 - arg z2)"
	+ using canon_ang_eq
	+ by(simp add:field_simps)
	+ thus ?thesis
	+ using canon_ang_arg[of "z1/z2"]
	+ by auto
	+qed
	+
	+text \<open>Argument of opposite\<close>
	+
	+lemma arg_uminus:
	+ assumes "z \<noteq> 0"
	+ shows "arg (-z) = \<downharpoonright>arg z + pi\<downharpoonleft>"
	+ using assms
	+ using arg_mult[of "-1" z]
	+ using arg_complex_of_real_negative[of "-1"]
	+ by (auto simp add: field_simps)
	+
	+lemma arg_uminus_opposite_sign:
	+ assumes "z \<noteq> 0"
	+ shows "arg z > 0 \<longleftrightarrow> \<not> arg (-z) > 0"
	+proof (cases "arg z = 0")
	+ case True
	+ thus ?thesis
	+ using assms
	+ by (simp add: arg_uminus)
	+next
	+ case False
	+ show ?thesis
	+ proof (cases "arg z > 0")
	+ case True
	+ thus ?thesis
	+ using assms
	+ using arg_bounded[of z]
	+ using canon_ang_plus_pi1[of "arg z"]
	+ by (simp add: arg_uminus)
	+ next
	+ case False
	+ thus ?thesis
	+ using \<open>arg z \<noteq> 0\<close>
	+ using assms
	+ using arg_bounded[of z]
	+ using canon_ang_plus_pi2[of "arg z"]
	+ by (simp add: arg_uminus)
	+ qed
	+qed
	+
	+text \<open>Sign of argument is the same as the sign of the Imaginary part\<close>
	+
	+lemma arg_Im_sgn:
	+ assumes "\<not> is_real z"
	+ shows "sgn (arg z) = sgn (Im z)"
	+proof-
	+ have "z \<noteq> 0"
	+ using assms
	+ by auto
	+ then obtain r \<phi> where polar: "z = cor r * cis \<phi>" "\<phi> = arg z" "r > 0"
	+ by (smt cmod_cis mult_eq_0_iff norm_ge_zero of_real_0)
	+ hence "Im z = r * sin \<phi>"
	+ by (metis Im_mult_real Re_complex_of_real cis.simps(2) Im_complex_of_real)
	+ hence "Im z > 0 \<longleftrightarrow> sin \<phi> > 0" "Im z < 0 \<longleftrightarrow> sin \<phi> < 0"
	+ using \<open>r > 0\<close>
	+ using mult_pos_pos mult_nonneg_nonneg zero_less_mult_pos mult_less_cancel_left
	+ by smt+
	+ moreover
	+ have "\<phi> \<noteq> pi" "\<phi> \<noteq> 0"
	+ using \<open>\<not> is_real z\<close> polar cis_pi
	+ by force+
	+ hence "sin \<phi> > 0 \<longleftrightarrow> \<phi> > 0" "\<phi> < 0 \<longleftrightarrow> sin \<phi> < 0"
	+ using \<open>\<phi> = arg z\<close> \<open>\<phi> \<noteq> 0\<close> \<open>\<phi> \<noteq> pi\<close>
	+ using arg_bounded[of z]
	+ by (smt sin_gt_zero sin_le_zero sin_pi_minus sin_0_iff_canon sin_ge_zero)+
	+ ultimately
	+ show ?thesis
	+ using \<open>\<phi> = arg z\<close>
	+ by auto
	+qed
	+
	+
	+subsubsection \<open>Complex square root\<close>
	+
	+definition
	+ "ccsqrt z = rcis (sqrt (cmod z)) (arg z / 2)"
	+
	+lemma square_ccsqrt [simp]:
	+ shows "(ccsqrt x)\<^sup>2 = x"
	+ unfolding ccsqrt_def
	+ by (subst DeMoivre2) (simp add: rcis_cmod_arg)
	+
	+lemma ex_complex_sqrt:
	+ shows "\<exists> s::complex. s*s = z"
	+ unfolding power2_eq_square[symmetric]
	+ by (rule_tac x="csqrt z" in exI) simp
	+
	+lemma ccsqrt:
	+ assumes "s * s = z"
	+ shows "s = ccsqrt z \<or> s = -ccsqrt z"
	+proof (cases "s = 0")
	+ case True
	+ thus ?thesis
	+ using assms
	+ unfolding ccsqrt_def
	+ by simp
	+next
	+ case False
	+ then obtain k::int where "cmod s * cmod s = cmod z" "2 * arg s - arg z = 2kpi"
	+ using assms
	+ using rcis_cmod_arg[of z] rcis_cmod_arg[of s]
	+ using arg_mult[of s s]
	+ using canon_ang(3)[of "2*arg s"]
	+ by (auto simp add: norm_mult arg_mult)
	+ have *: "sqrt (cmod z) = cmod s"
	+ using \<open>cmod s * cmod s = cmod z\<close>
	+ by (smt norm_not_less_zero real_sqrt_abs2)
	+
	+ have *: "arg z / 2 = arg s - kpi"
	+ using \<open>2 * arg s - arg z = 2kpi\<close>
	+ by simp
	+
	+ have "cis (arg s - kpi) = cis (arg s) \<or> cis (arg s - kpi) = -cis (arg s)"
	+ proof (cases "even k")
	+ case True
	+ hence "cis (arg s - k*pi) = cis (arg s)"
	+ by (simp add: cis_def complex.corec cos_diff sin_diff)
	+ thus ?thesis
	+ by simp
	+ next
	+ case False
	+ hence "cis (arg s - k*pi) = -cis (arg s)"
	+ by (simp add: cis_def complex.corec Complex_eq cos_diff sin_diff)
	+ thus ?thesis
	+ by simp
	+ qed
	+ thus ?thesis
	+ proof
	+ assume **: "cis (arg s - k pi) = cis (arg s)"
	+ hence "s = ccsqrt z"
	+ using rcis_cmod_arg[of s]
	+ unfolding ccsqrt_def rcis_def
	+ by (subst , subst , subst **, simp)
	+ thus ?thesis
	+ by simp
	+ next
	+ assume **: "cis (arg s - k pi) = -cis (arg s)"
	+ hence "s = - ccsqrt z"
	+ using rcis_cmod_arg[of s]
	+ unfolding ccsqrt_def rcis_def
	+ by (subst , subst , subst **, simp)
	+ thus ?thesis
	+ by simp
	+ qed
	+qed
	+
	+lemma null_ccsqrt [simp]:
	+ shows "ccsqrt x = 0 \<longleftrightarrow> x = 0"
	+ unfolding ccsqrt_def
	+ by auto
	+
	+lemma ccsqrt_mult:
	+ shows "ccsqrt (a * b) = ccsqrt a * ccsqrt b \<or>
	+ ccsqrt (a * b) = - ccsqrt a * ccsqrt b"
	+proof (cases "a = 0 \<or> b = 0")
	+ case True
	+ thus ?thesis
	+ by auto
	+next
	+ case False
	+ obtain k::int where "arg a + arg b - \<downharpoonright>arg a + arg b\<downharpoonleft> = 2 * real_of_int k * pi"
	+ using canon_ang(3)[of "arg a + arg b"]
	+ by auto
	+ hence : "\<downharpoonright>arg a + arg b\<downharpoonleft> = arg a + arg b - 2 (real_of_int k) * pi"
	+ by (auto simp add: field_simps)
	+
	+ have "cis (\<downharpoonright>arg a + arg b\<downharpoonleft> / 2) = cis (arg a / 2 + arg b / 2) \<or> cis (\<downharpoonright>arg a + arg b\<downharpoonleft> / 2) = - cis (arg a / 2 + arg b / 2)"
	+ using cos_even_kpi[of k] cos_odd_kpi[of k]
	+ by ((subst *)+, (subst diff_divide_distrib)+, (subst add_divide_distrib)+)
	+ (cases "even k", auto simp add: cis_def complex.corec Complex_eq cos_diff sin_diff)
	+ thus ?thesis
	+ using False
	+ unfolding ccsqrt_def
	+ by (simp add: rcis_mult real_sqrt_mult arg_mult)
	+ (auto simp add: rcis_def)
	+qed
	+
	+lemma csqrt_real:
	+ assumes "is_real x"
	+ shows "(Re x \<ge> 0 \<and> ccsqrt x = cor (sqrt (Re x))) \<or>
	+ (Re x < 0 \<and> ccsqrt x = \<i> * cor (sqrt (- (Re x))))"
	+proof (cases "x = 0")
	+ case True
	+ thus ?thesis
	+ by auto
	+next
	+ case False
	+ show ?thesis
	+ proof (cases "Re x > 0")
	+ case True
	+ hence "arg x = 0"
	+ using \<open>is_real x\<close>
	+ by (metis arg_complex_of_real_positive complex_of_real_Re)
	+ thus ?thesis
	+ using \<open>Re x > 0\<close> \<open>is_real x\<close>
	+ unfolding ccsqrt_def
	+ by (simp add: cmod_eq_Re)
	+ next
	+ case False
	+ hence "Re x < 0"
	+ using \<open>x \<noteq> 0\<close> \<open>is_real x\<close>
	+ using complex_eq_if_Re_eq by auto
	+ hence "arg x = pi"
	+ using \<open>is_real x\<close>
	+ by (metis arg_complex_of_real_negative complex_of_real_Re)
	+ thus ?thesis
	+ using \<open>Re x < 0\<close> \<open>is_real x\<close>
	+ unfolding ccsqrt_def rcis_def
	+ by (simp add: cis_def complex.corec Complex_eq cmod_eq_Re)
	+ qed
	+qed
	+
	+
	+text \<open>Rotation of complex vector to x-axis.\<close>
	+
	+lemma is_real_rot_to_x_axis:
	+ assumes "z \<noteq> 0"
	+ shows "is_real (cis (-arg z) * z)"
	+proof (cases "arg z = pi")
	+ case True
	+ thus ?thesis
	+ using is_real_arg1[of z]
	+ by auto
	+next
	+ case False
	+ hence "\<downharpoonright>- arg z\<downharpoonleft> = - arg z"
	+ using canon_ang_eqI[of "- arg z" "-arg z"]
	+ using arg_bounded[of z]
	+ by (auto simp add: field_simps)
	+ hence "arg (cis (- (arg z)) * z) = 0"
	+ using arg_mult[of "cis (- (arg z))" z] \<open>z \<noteq> 0\<close>
	+ using arg_cis[of "- arg z"]
	+ by simp
	+ thus ?thesis
	+ using is_real_arg1[of "cis (- arg z) * z"]
	+ by auto
	+qed
	+
	+lemma positive_rot_to_x_axis:
	+ assumes "z \<noteq> 0"
	+ shows "Re (cis (-arg z) * z) > 0"
	+ using assms
	+ by (smt Re_complex_of_real cis_rcis_eq mult_cancel_right1 rcis_cmod_arg rcis_mult rcis_zero_arg zero_less_norm_iff)
	+
	+text \<open>Inequalities involving @{term cmod}.\<close>
	+
	+lemma cmod_1_plus_mult_le:
	+ shows "cmod (1 + zw) \<le> sqrt((1 + (cmod z)\<^sup>2) (1 + (cmod w)\<^sup>2))"
	+proof-
	+ have "Re ((1+zw)(1+cnj zcnj w)) \<le> Re (1+zcnj z)* Re (1+w*cnj w)"
	+ proof-
	+ have "Re ((w - cnj z)*cnj(w - cnj z)) \<ge> 0"
	+ by (subst complex_mult_cnj_cmod) (simp add: power2_eq_square)
	+ hence "Re (zw + cnj z cnj w) \<le> Re (wcnj w) + Re(zcnj z)"
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ by (simp add: field_simps)
	+ qed
	+ hence "(cmod (1 + z * w))\<^sup>2 \<le> (1 + (cmod z)\<^sup>2) * (1 + (cmod w)\<^sup>2)"
	+ by (subst cmod_square)+ simp
	+ thus ?thesis
	+ by (metis abs_norm_cancel real_sqrt_abs real_sqrt_le_iff)
	+qed
	+
	+lemma cmod_diff_ge:
	+ shows "cmod (b - c) \<ge> sqrt (1 + (cmod b)\<^sup>2) - sqrt (1 + (cmod c)\<^sup>2)"
	+proof-
	+ have "(cmod (b - c))\<^sup>2 + (1/2Im(bcnj c - c*cnj b))\<^sup>2 \<ge> 0"
	+ by simp
	+ hence "(cmod (b - c))\<^sup>2 \<ge> - (1/2Im(bcnj c - c*cnj b))\<^sup>2"
	+ by simp
	+ hence "(cmod (b - c))\<^sup>2 \<ge> (1/2Re(bcnj c + ccnj b))\<^sup>2 - Re(bcnj bccnj c) "
	+ by (auto simp add: power2_eq_square field_simps)
	+ hence "Re ((b - c)(cnj b - cnj c)) \<ge> (1/2Re(bcnj c + ccnj b))\<^sup>2 - Re(bcnj bc*cnj c)"
	+ by (subst (asm) cmod_square) simp
	+ moreover
	+ have "(1 + (cmod b)\<^sup>2) * (1 + (cmod c)\<^sup>2) = 1 + Re(bcnj b) + Re(ccnj c) + Re(bcnj bc*cnj c)"
	+ by (subst cmod_square)+ (simp add: field_simps power2_eq_square)
	+ moreover
	+ have "(1 + Re (scalprod b c))\<^sup>2 = 1 + 2*Re(scalprod b c) + ((Re (scalprod b c))\<^sup>2)"
	+ by (subst power2_sum) simp
	+ hence "(1 + Re (scalprod b c))\<^sup>2 = 1 + Re(bcnj c + ccnj b) + (1/2 * Re (bcnj c + ccnj b))\<^sup>2"
	+ by simp
	+ ultimately
	+ have "(1 + (cmod b)\<^sup>2) * (1 + (cmod c)\<^sup>2) \<ge> (1 + Re (scalprod b c))\<^sup>2"
	+ by (simp add: field_simps)
	+ moreover
	+ have "sqrt((1 + (cmod b)\<^sup>2) * (1 + (cmod c)\<^sup>2)) \<ge> 0"
	+ by (metis one_power2 real_sqrt_sum_squares_mult_ge_zero)
	+ ultimately
	+ have "sqrt((1 + (cmod b)\<^sup>2) * (1 + (cmod c)\<^sup>2)) \<ge> 1 + Re (scalprod b c)"
	+ by (metis power2_le_imp_le real_sqrt_ge_0_iff real_sqrt_pow2_iff)
	+ hence "Re ((b - c) * (cnj b - cnj c)) \<ge> 1 + Re (ccnj c) + 1 + Re (bcnj b) - 2sqrt((1 + (cmod b)\<^sup>2) (1 + (cmod c)\<^sup>2))"
	+ by (simp add: field_simps)
	+ hence *: "(cmod (b - c))\<^sup>2 \<ge> (sqrt (1 + (cmod b)\<^sup>2) - sqrt (1 + (cmod c)\<^sup>2))\<^sup>2"
	+ apply (subst cmod_square)+
	+ apply (subst (asm) cmod_square)+
	+ apply (subst power2_diff)
	+ apply (subst real_sqrt_pow2, simp)
	+ apply (subst real_sqrt_pow2, simp)
	+ apply (simp add: real_sqrt_mult)
	+ done
	+ thus ?thesis
	+ proof (cases "sqrt (1 + (cmod b)\<^sup>2) - sqrt (1 + (cmod c)\<^sup>2) > 0")
	+ case True
	+ thus ?thesis
	+ using power2_le_imp_le[OF *]
	+ by simp
	+ next
	+ case False
	+ hence "0 \<ge> sqrt (1 + (cmod b)\<^sup>2) - sqrt (1 + (cmod c)\<^sup>2)"
	+ by (metis less_eq_real_def linorder_neqE_linordered_idom)
	+ moreover
	+ have "cmod (b - c) \<ge> 0"
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by (metis add_increasing monoid_add_class.add.right_neutral)
	+ qed
	+qed
	+
	+lemma cmod_diff_le:
	+ shows "cmod (b - c) \<le> sqrt (1 + (cmod b)\<^sup>2) + sqrt (1 + (cmod c)\<^sup>2)"
	+proof-
	+ have "(cmod (b + c))\<^sup>2 + (1/2Im(bcnj c - c*cnj b))\<^sup>2 \<ge> 0"
	+ by simp
	+ hence "(cmod (b + c))\<^sup>2 \<ge> - (1/2Im(bcnj c - c*cnj b))\<^sup>2"
	+ by simp
	+ hence "(cmod (b + c))\<^sup>2 \<ge> (1/2Re(bcnj c + ccnj b))\<^sup>2 - Re(bcnj bccnj c) "
	+ by (auto simp add: power2_eq_square field_simps)
	+ hence "Re ((b + c)(cnj b + cnj c)) \<ge> (1/2Re(bcnj c + ccnj b))\<^sup>2 - Re(bcnj bc*cnj c)"
	+ by (subst (asm) cmod_square) simp
	+ moreover
	+ have "(1 + (cmod b)\<^sup>2) * (1 + (cmod c)\<^sup>2) = 1 + Re(bcnj b) + Re(ccnj c) + Re(bcnj bc*cnj c)"
	+ by (subst cmod_square)+ (simp add: field_simps power2_eq_square)
	+ moreover
	+ have ++: "2Re(scalprod b c) = Re(bcnj c + c*cnj b)"
	+ by simp
	+ have "(1 - Re (scalprod b c))\<^sup>2 = 1 - 2*Re(scalprod b c) + ((Re (scalprod b c))\<^sup>2)"
	+ by (subst power2_diff) simp
	+ hence "(1 - Re (scalprod b c))\<^sup>2 = 1 - Re(bcnj c + ccnj b) + (1/2 * Re (bcnj c + ccnj b))\<^sup>2"
	+ by (subst ++[symmetric]) simp
	+ ultimately
	+ have "(1 + (cmod b)\<^sup>2) * (1 + (cmod c)\<^sup>2) \<ge> (1 - Re (scalprod b c))\<^sup>2"
	+ by (simp add: field_simps)
	+ moreover
	+ have "sqrt((1 + (cmod b)\<^sup>2) * (1 + (cmod c)\<^sup>2)) \<ge> 0"
	+ by (metis one_power2 real_sqrt_sum_squares_mult_ge_zero)
	+ ultimately
	+ have "sqrt((1 + (cmod b)\<^sup>2) * (1 + (cmod c)\<^sup>2)) \<ge> 1 - Re (scalprod b c)"
	+ by (metis power2_le_imp_le real_sqrt_ge_0_iff real_sqrt_pow2_iff)
	+ hence "Re ((b - c) * (cnj b - cnj c)) \<le> 1 + Re (ccnj c) + 1 + Re (bcnj b) + 2sqrt((1 + (cmod b)\<^sup>2) (1 + (cmod c)\<^sup>2))"
	+ by (simp add: field_simps)
	+ hence *: "(cmod (b - c))\<^sup>2 \<le> (sqrt (1 + (cmod b)\<^sup>2) + sqrt (1 + (cmod c)\<^sup>2))\<^sup>2"
	+ apply (subst cmod_square)+
	+ apply (subst (asm) cmod_square)+
	+ apply (subst power2_sum)
	+ apply (subst real_sqrt_pow2, simp)
	+ apply (subst real_sqrt_pow2, simp)
	+ apply (simp add: real_sqrt_mult)
	+ done
	+ thus ?thesis
	+ using power2_le_imp_le[OF *]
	+ by simp
	+qed
	+
	+
	+text \<open>Definition of Euclidean distance between two complex numbers.\<close>
	+
	+definition cdist where
	+ [simp]: "cdist z1 z2 \<equiv> cmod (z2 - z1)"
	+
	+text \<open>Misc. properties of complex numbers.\<close>
	+
	+lemma ex_complex_to_complex [simp]:
	+ fixes z1 z2 :: complex
	+ assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
	+ shows "\<exists>k. k \<noteq> 0 \<and> z2 = k * z1"
	+ using assms
	+ by (rule_tac x="z2/z1" in exI) simp
	+
	+lemma ex_complex_to_one [simp]:
	+ fixes z::complex
	+ assumes "z \<noteq> 0"
	+ shows "\<exists>k. k \<noteq> 0 \<and> k * z = 1"
	+ using assms
	+ by (rule_tac x="1/z" in exI) simp
	+
	+lemma ex_complex_to_complex2 [simp]:
	+ fixes z::complex
	+ shows "\<exists>k. k \<noteq> 0 \<and> k * z = z"
	+ by (rule_tac x="1" in exI) simp
	+
	+lemma complex_sqrt_1:
	+ fixes z::complex
	+ assumes "z \<noteq> 0"
	+ shows "z = 1 / z \<longleftrightarrow> z = 1 \<or> z = -1"
	+ using assms
	+ using nonzero_eq_divide_eq square_eq_iff
	+ by fastforce
	+
	+end
	diff --git a/thys/Complex_Geometry/More_Set.thy b/thys/Complex_Geometry/More_Set.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/More_Set.thy
	@@ -0,0 +1,123 @@
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Library Aditions for Set Cardinality\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>In this sections some additional simple lemmas about set cardinality are proved.\<close>
	+
	+theory More_Set
	+imports Main
	+begin
	+
	+text \<open>Every infinite set has at least two different elements\<close>
	+lemma infinite_contains_2_elems:
	+ assumes "infinite A"
	+ shows "\<exists> x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A"
	+proof(rule ccontr)
	+ assume *: " \<nexists>x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A"
	+ have "\<exists> x. x \<in> A "
	+ using assms
	+ by (simp add: ex_in_conv infinite_imp_nonempty)
	+ hence "card A = 1"
	+ using *
	+ by (metis assms ex_in_conv finite_insert infinite_imp_nonempty insertCI mk_disjoint_insert)
	+ thus False
	+ using assms
	+ by simp
	+qed
	+
	+text \<open>Every infinite set has at least three different elements\<close>
	+lemma infinite_contains_3_elems:
	+ assumes "infinite A"
	+ shows "\<exists> x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A"
	+proof(rule ccontr)
	+ assume " \<nexists>x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A"
	+ hence "card A = 2"
	+ by (smt DiffE assms finite_insert infinite_contains_2_elems insert_Diff insert_iff)
	+ thus False
	+ using assms
	+ by simp
	+qed
	+
	+text \<open>Every set with cardinality greater than 1 has at least two different elements\<close>
	+lemma card_geq_2_iff_contains_2_elems:
	+ shows "card A \<ge> 2 \<longleftrightarrow> finite A \<and> (\<exists> x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A)"
	+proof
	+ assume *: "finite A \<and> (\<exists> x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A)"
	+ thus "card A \<ge> 2"
	+ proof -
	+ obtain a :: 'a and b :: 'a where
	+ f1: "a \<noteq> b \<and> a \<in> A \<and> b \<in> A"
	+ using *
	+ by blast
	+ then have "0 < card (A - {b})"
	+ by (metis * card_eq_0_iff ex_in_conv finite_insert insertE insert_Diff neq0_conv)
	+ then show ?thesis
	+ using f1 by (simp add: *)
	+ qed
	+next
	+ assume *: " 2 \<le> card A"
	+ hence "finite A"
	+ using card_infinite
	+ by force
	+ moreover
	+ have "\<exists>x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A"
	+ proof(rule ccontr)
	+ assume " \<nexists>x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A"
	+ hence "card A \<le> 1"
	+ by (metis One_nat_def card.empty card.insert card_mono finite.emptyI finite_insert insertCI le_SucI subsetI)
	+ thus False
	+ using *
	+ by auto
	+ qed
	+ ultimately
	+ show "finite A \<and> (\<exists> x y. x \<noteq> y \<and> x \<in> A \<and> y \<in> A)"
	+ by simp
	+qed
	+
	+text \<open>Set cardinality is at least 3 if and only if it contains three different elements\<close>
	+lemma card_geq_3_iff_contains_3_elems:
	+ shows "card A \<ge> 3 \<longleftrightarrow> finite A \<and> (\<exists> x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A)"
	+proof
	+ assume *: "card A \<ge> 3"
	+ hence "finite A"
	+ using card_infinite
	+ by force
	+ moreover
	+ have "\<exists> x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A"
	+ proof(rule ccontr)
	+ assume "\<nexists>x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A"
	+ hence "card A \<le> 2"
	+ by (smt DiffE Suc_leI card.remove card_geq_2_iff_contains_2_elems insert_iff le_cases not_le)
	+ thus False
	+ using *
	+ by auto
	+ qed
	+ ultimately
	+ show "finite A \<and> (\<exists> x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A)"
	+ by simp
	+next
	+ assume *: "finite A \<and> (\<exists> x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A)"
	+ thus "card A \<ge> 3"
	+ by (smt "*" Suc_eq_numeral Suc_le_mono card.remove card_geq_2_iff_contains_2_elems finite_insert insert_Diff insert_iff pred_numeral_simps(3))
	+qed
	+
	+text \<open>Set cardinality of A is equal to 2 if and only if A={x, y} for two different elements x and y\<close>
	+lemma card_eq_2_iff_doubleton: "card A = 2 \<longleftrightarrow> (\<exists> x y. x \<noteq> y \<and> A = {x, y})"
	+ using card_geq_2_iff_contains_2_elems[of A]
	+ using card_geq_3_iff_contains_3_elems[of A]
	+ by auto (rule_tac x=x in exI, rule_tac x=y in exI, auto)
	+
	+lemma card_eq_2_doubleton:
	+ assumes "card A = 2" and "x \<noteq> y" and "x \<in> A" and "y \<in> A"
	+ shows "A = {x, y}"
	+ using assms
	+ using card_eq_2_iff_doubleton[of A]
	+ by auto
	+
	+text \<open>Bijections map singleton to singleton sets\<close>
	+
	+lemma bij_image_singleton:
	+ shows "\<lbrakk>f ` A = {b}; f a = b; bij f\<rbrakk> \<Longrightarrow> A = {a}"
	+ by (metis (mono_tags) bij_betw_imp_inj_on image_empty image_insert inj_vimage_image_eq)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Complex_Geometry/More_Transcendental.thy b/thys/Complex_Geometry/More_Transcendental.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/More_Transcendental.thy
	@@ -0,0 +1,409 @@
	+(* ---------------------------------------------------------------------------- *)
	+section \<open>Introduction\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>The complex plane or some of its parts (e.g., the unit disc or the upper half plane) are often
	+taken as the domain in which models of various geometries (both Euclidean and non-Euclidean ones)
	+are formalized. The complex plane gives simpler and more compact formulas than the Cartesian plane.
	+Within complex plane is easier to describe geometric objects and perform the calculations (usually
	+shedding some new light on the subject). We give a formalization of the extended complex
	+plane (given both as a complex projective space and as the Riemann sphere), its objects (points,
	+circles and lines), and its transformations (Möbius transformations).\<close>
	+
	+(* ---------------------------------------------------------------------------- *)
	+section \<open>Related work\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text\<open>During the last decade, there have been many results in formalizing
	+geometry in proof-assistants. Parts of Hilbert’s seminal book
	+,,Foundations of Geometry'' \cite{hilbert} have been formalized both
	+in Coq and Isabelle/Isar. Formalization of first two groups of axioms
	+in Coq, in an intuitionistic setting was done by Dehlinger et
	+al. \cite{hilbert-coq}. First formalization in Isabelle/HOL was done
	+by Fleuriot and Meikele \cite{hilbert-isabelle}, and some further
	+developments were made in master thesis of Scott \cite{hilbert-scott}.
	+Large fragments of Tarski's geometry \cite{tarski} have been
	+formalized in Coq by Narboux et al. \cite{narboux-tarski}. Within Coq,
	+there are also formalizations of von Plato’s constructive geometry by
	+Kahn \cite{vonPlato,von-plato-formalization}, French high school
	+geometry by Guilhot \cite{guilhot} and ruler and compass geometry by
	+Duprat \cite{duprat2008}, etc.
	+
	+In our previous work \cite{petrovic2012formalizing}, we have already
	+formally investigated a Cartesian model of Euclidean geometry.
	+\<close>
	+
	+(* ---------------------------------------------------------------------------- *)
	+section \<open>Background theories\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>In this section we introduce some basic mathematical notions and prove some lemmas needed in the rest of our
	+formalization. We describe:
	+
	+ \<^item> trigonometric functions,
	+
	+ \<^item> complex numbers,
	+
	+ \<^item> systems of two and three linear equations with two unknowns (over arbitrary fields),
	+
	+ \<^item> quadratic equations (over real and complex numbers), systems of quadratic and real
	+ equations, and systems of two quadratic equations,
	+
	+ \<^item> two-dimensional vectors and matrices over complex numbers.
	+\<close>
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Library Additions for Trigonometric Functions\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+theory More_Transcendental
	+ imports Complex_Main
	+begin
	+
	+text \<open>Additional properties of @{term sin} and @{term cos} functions that are later used in proving
	+conjectures for argument of complex number.\<close>
	+
	+text \<open>Sign of trigonometric functions on some characteristic intervals.\<close>
	+
	+lemma cos_lt_zero_on_pi2_pi [simp]:
	+ assumes "x > pi/2" and "x \<le> pi"
	+ shows "cos x < 0"
	+ using cos_gt_zero_pi[of "pi - x"] assms
	+ by simp
	+
	+text \<open>Value of trigonometric functions in points $k\pi$ and $\frac{\pi}{2} + k\pi$.\<close>
	+
	+lemma sin_kpi [simp]:
	+ fixes k::int
	+ shows "sin (k * pi) = 0"
	+ by (simp add: sin_zero_iff_int2)
	+
	+lemma cos_odd_kpi [simp]:
	+ fixes k::int
	+ assumes "odd k"
	+ shows "cos (k * pi) = -1"
	+proof (cases "k \<ge> 0")
	+ case True
	+ hence "odd (nat k)"
	+ using \<open>odd k\<close>
	+ by (auto simp add: even_nat_iff)
	+ thus ?thesis
	+ using \<open>k \<ge> 0\<close> cos_npi[of "nat k"]
	+ by auto
	+next
	+ case False
	+ hence "-k \<ge> 0" "odd (nat (-k))"
	+ using \<open>odd k\<close>
	+ by (auto simp add: even_nat_iff)
	+ thus ?thesis
	+ using cos_npi[of "nat (-k)"]
	+ by auto
	+qed
	+
	+lemma cos_even_kpi [simp]:
	+ fixes k::int
	+ assumes "even k"
	+ shows "cos (k * pi) = 1"
	+proof (cases "k \<ge> 0")
	+ case True
	+ hence "even (nat k)"
	+ using \<open>even k\<close>
	+ by (simp add: even_nat_iff)
	+ thus ?thesis
	+ using \<open>k \<ge> 0\<close> cos_npi[of "nat k"]
	+ by auto
	+next
	+ case False
	+ hence "-k \<ge> 0" "even (nat (-k))"
	+ using \<open>even k\<close>
	+ by (auto simp add: even_nat_iff)
	+ thus ?thesis
	+ using cos_npi[of "nat (-k)"]
	+ by auto
	+qed
	+
	+lemma sin_pi2_plus_odd_kpi [simp]:
	+ fixes k::int
	+ assumes "odd k"
	+ shows "sin (pi / 2 + k * pi) = -1"
	+ using assms
	+ by (simp add: sin_add)
	+
	+lemma sin_pi2_plus_even_kpi [simp]:
	+ fixes k::int
	+ assumes "even k"
	+ shows "sin (pi / 2 + k * pi) = 1"
	+ using assms
	+ by (simp add: sin_add)
	+
	+text \<open>Solving trigonometric equations and systems with special values (0, 1, or -1) of sine and cosine functions\<close>
	+
	+lemma cos_0_iff_canon:
	+ assumes "cos \<phi> = 0" and "-pi < \<phi>" and "\<phi> \<le> pi"
	+ shows "\<phi> = pi/2 \<or> \<phi> = -pi/2"
	+proof-
	+ obtain k::int where "odd k" "\<phi> = k * pi/2"
	+ using cos_zero_iff_int[of \<phi>] assms(1)
	+ by auto
	+ thus ?thesis
	+ proof (cases "k > 1 \<or> k < -1")
	+ case True
	+ hence "k \<ge> 3 \<or> k \<le> -3"
	+ using \<open>odd k\<close>
	+ by (smt dvd_refl even_minus)
	+ hence "\<phi> \<ge> 3pi/2 \<or> \<phi> \<le> -3pi/2"
	+ using mult_right_mono[of k "-3" "pi / 2"]
	+ using \<open>\<phi> = k * pi/2\<close>
	+ by auto
	+ thus ?thesis
	+ using \<open>- pi < \<phi>\<close> \<open>\<phi> \<le> pi\<close>
	+ by auto
	+ next
	+ case False
	+ hence "k = -1 \<or> k = 0 \<or> k = 1"
	+ by auto
	+ hence "k = -1 \<or> k = 1"
	+ using \<open>odd k\<close>
	+ by auto
	+ thus ?thesis
	+ using \<open>\<phi> = k * pi/2\<close>
	+ by auto
	+ qed
	+qed
	+
	+lemma sin_0_iff_canon:
	+ assumes "sin \<phi> = 0" and "-pi < \<phi>" and "\<phi> \<le> pi"
	+ shows "\<phi> = 0 \<or> \<phi> = pi"
	+proof-
	+ obtain k::int where "even k" "\<phi> = k * pi/2"
	+ using sin_zero_iff_int[of \<phi>] assms(1)
	+ by auto
	+ thus ?thesis
	+ proof (cases "k > 2 \<or> k < 0")
	+ case True
	+ hence "k \<ge> 4 \<or> k \<le> -2"
	+ using \<open>even k\<close>
	+ by (smt evenE)
	+ hence "\<phi> \<ge> 2*pi \<or> \<phi> \<le> -pi"
	+ proof
	+ assume "4 \<le> k"
	+ hence "4 * pi/2 \<le> \<phi>"
	+ using mult_right_mono[of "4" "k" "pi/2"]
	+ by (subst \<open>\<phi> = k * pi/2\<close>) auto
	+ thus ?thesis
	+ by simp
	+ next
	+ assume "k \<le> -2"
	+ hence "-2*pi/2 \<ge> \<phi>"
	+ using mult_right_mono[of "k" "-2" "pi/2"]
	+ by (subst \<open>\<phi> = k * pi/2\<close>, auto)
	+ thus ?thesis
	+ by simp
	+ qed
	+ thus ?thesis
	+ using \<open>- pi < \<phi>\<close> \<open>\<phi> \<le> pi\<close>
	+ by auto
	+ next
	+ case False
	+ hence "k = 0 \<or> k = 1 \<or> k = 2"
	+ by auto
	+ hence "k = 0 \<or> k = 2"
	+ using \<open>even k\<close>
	+ by auto
	+ thus ?thesis
	+ using \<open>\<phi> = k * pi/2\<close>
	+ by auto
	+ qed
	+qed
	+
	+lemma cos0_sin1:
	+ assumes "cos \<phi> = 0" and "sin \<phi> = 1"
	+ shows "\<exists> k::int. \<phi> = pi/2 + 2kpi"
	+proof-
	+ from \<open>cos \<phi> = 0\<close>
	+ obtain k::int where "odd k" "\<phi> = k * (pi / 2)"
	+ using cos_zero_iff_int[of "\<phi>"]
	+ by auto
	+ then obtain k'::int where "k = 2*k' + 1"
	+ using oddE by blast
	+ hence "\<phi> = pi/2 + (k' * pi)"
	+ using \<open>\<phi> = k * (pi / 2)\<close>
	+ by (auto simp add: field_simps)
	+ hence "even k'"
	+ using \<open>sin \<phi> = 1\<close> sin_pi2_plus_odd_kpi[of k']
	+ by auto
	+ thus ?thesis
	+ using \<open>\<phi> = pi /2 + (k' * pi)\<close>
	+ unfolding even_iff_mod_2_eq_zero
	+ by auto
	+qed
	+
	+lemma cos1_sin0:
	+ assumes "cos \<phi> = 1" and "sin \<phi> = 0"
	+ shows "\<exists> k::int. \<phi> = 2kpi"
	+proof-
	+ from \<open>sin \<phi> = 0\<close>
	+ obtain k::int where "even k" "\<phi> = k * (pi / 2)"
	+ using sin_zero_iff_int[of "\<phi>"]
	+ by auto
	+ then obtain k'::int where "k = 2*k'"
	+ using evenE by blast
	+ hence "\<phi> = k' * pi"
	+ using \<open>\<phi> = k * (pi / 2)\<close>
	+ by (auto simp add: field_simps)
	+ hence "even k'"
	+ using \<open>cos \<phi> = 1\<close> cos_odd_kpi[of k']
	+ by auto
	+ thus ?thesis
	+ using \<open>\<phi> = k' * pi\<close>
	+ using assms(1) cos_one_2pi_int by auto
	+qed
	+
	+(* TODO: add lemmas for cos = -1, sin = 0 and cos = 0, sin = -1 *)
	+
	+
	+text \<open>Sine is injective on $[-\frac{\pi}{2}, \frac{\pi}{2}]$\<close>
	+
	+lemma sin_inj:
	+ assumes "-pi/2 \<le> \<alpha> \<and> \<alpha> \<le> pi/2" and "-pi/2 \<le> \<alpha>' \<and> \<alpha>' \<le> pi/2"
	+ assumes "\<alpha> \<noteq> \<alpha>'"
	+ shows "sin \<alpha> \<noteq> sin \<alpha>'"
	+ using assms
	+ using sin_monotone_2pi[of \<alpha> \<alpha>'] sin_monotone_2pi[of \<alpha>' \<alpha>]
	+ by (cases "\<alpha> < \<alpha>'") auto
	+
	+text \<open>Periodicity of trigonometric functions\<close>
	+
	+text \<open>The following are available in HOL-Decision\_Procs.Approximation\_Bounds, but we want to avoid
	+that dependency\<close>
	+
	+lemma sin_periodic_nat [simp]:
	+ fixes n :: nat
	+ shows "sin (x + n * (2 * pi)) = sin x"
	+proof (induct n arbitrary: x)
	+ case (Suc n)
	+ have split_pi_off: "x + (Suc n) * (2 * pi) = (x + n * (2 * pi)) + 2 * pi"
	+ unfolding Suc_eq_plus1 distrib_right
	+ by (auto simp add: field_simps)
	+ show ?case unfolding split_pi_off using Suc by auto
	+qed auto
	+
	+lemma sin_periodic_int [simp]:
	+ fixes i :: int
	+ shows "sin (x + i * (2 * pi)) = sin x"
	+proof(cases "0 \<le> i")
	+ case True
	+ thus ?thesis
	+ using sin_periodic_nat[of x "nat i"]
	+ by auto
	+next
	+ case False hence i_nat: "i = - real (nat (-i))" by auto
	+ have "sin x = sin (x + i * (2 * pi) - i * (2 * pi))" by auto
	+ also have "\<dots> = sin (x + i * (2 * pi))"
	+ unfolding i_nat mult_minus_left diff_minus_eq_add by (rule sin_periodic_nat)
	+ finally show ?thesis by auto
	+qed
	+
	+lemma cos_periodic_nat [simp]:
	+ fixes n :: nat
	+ shows "cos (x + n * (2 * pi)) = cos x"
	+proof (induct n arbitrary: x)
	+ case (Suc n)
	+ have split_pi_off: "x + (Suc n) * (2 * pi) = (x + n * (2 * pi)) + 2 * pi"
	+ unfolding Suc_eq_plus1 distrib_right
	+ by (auto simp add: field_simps)
	+ show ?case unfolding split_pi_off using Suc by auto
	+qed auto
	+
	+lemma cos_periodic_int [simp]:
	+ fixes i :: int
	+ shows "cos (x + i * (2 * pi)) = cos x"
	+proof(cases "0 \<le> i")
	+ case True
	+ thus ?thesis
	+ using cos_periodic_nat[of x "nat i"]
	+ by auto
	+next
	+ case False hence i_nat: "i = - real (nat (-i))" by auto
	+ have "cos x = cos (x + i * (2 * pi) - i * (2 * pi))" by auto
	+ also have "\<dots> = cos (x + i * (2 * pi))"
	+ unfolding i_nat mult_minus_left diff_minus_eq_add by (rule cos_periodic_nat)
	+ finally show ?thesis by auto
	+qed
	+
	+text \<open>Values of both sine and cosine are repeated only after multiples of $2\cdot \pi$\<close>
	+
	+lemma sin_cos_eq:
	+ fixes a b :: real
	+ assumes "cos a = cos b" and "sin a = sin b"
	+ shows "\<exists> k::int. a - b = 2kpi"
	+proof-
	+ from assms have "sin (a - b) = 0" "cos (a - b) = 1"
	+ using sin_diff[of a b] cos_diff[of a b]
	+ by auto
	+ thus ?thesis
	+ using cos1_sin0
	+ by auto
	+qed
	+
	+text \<open>The following two lemmas are consequences of surjectivity of cosine for the range $[-1, 1]$.\<close>
	+
	+lemma ex_cos_eq:
	+ assumes "-pi/2 \<le> \<alpha> \<and> \<alpha> \<le> pi/2"
	+ assumes "a \<ge> 0" and "a < 1"
	+ shows "\<exists> \<alpha>'. -pi/2 \<le> \<alpha>' \<and> \<alpha>' \<le> pi/2 \<and> \<alpha>' \<noteq> \<alpha> \<and> cos (\<alpha> - \<alpha>') = a"
	+proof-
	+ have "arccos a > 0" "arccos a \<le> pi/2"
	+ using \<open>a \<ge> 0\<close> \<open>a < 1\<close>
	+ using arccos_lt_bounded arccos_le_pi2
	+ by auto
	+
	+ show ?thesis
	+ proof (cases "\<alpha> - arccos a \<ge> - pi/2")
	+ case True
	+ thus ?thesis
	+ using assms \<open>arccos a > 0\<close> \<open>arccos a \<le> pi/2\<close>
	+ by (rule_tac x = "\<alpha> - arccos a" in exI) auto
	+ next
	+ case False
	+ thus ?thesis
	+ using assms \<open>arccos a > 0\<close> \<open>arccos a \<le> pi/2\<close>
	+ by (rule_tac x = "\<alpha> + arccos a" in exI) auto
	+ qed
	+qed
	+
	+lemma ex_cos_gt:
	+ assumes "-pi/2 \<le> \<alpha> \<and> \<alpha> \<le> pi/2"
	+ assumes "a < 1"
	+ shows "\<exists> \<alpha>'. -pi/2 \<le> \<alpha>' \<and> \<alpha>' \<le> pi/2 \<and> \<alpha>' \<noteq> \<alpha> \<and> cos (\<alpha> - \<alpha>') > a"
	+proof-
	+ have "\<exists> a'. a' \<ge> 0 \<and> a' > a \<and> a' < 1"
	+ using \<open>a < 1\<close>
	+ using divide_strict_right_mono[of "2*a + (1 - a)" 2 2]
	+ by (rule_tac x="if a < 0 then 0 else a + (1-a)/2" in exI) (auto simp add: field_simps)
	+ then obtain a' where "a' \<ge> 0" "a' > a" "a' < 1"
	+ by auto
	+ thus ?thesis
	+ using ex_cos_eq[of \<alpha> a'] assms
	+ by auto
	+qed
	+
	+text \<open>The function @{term atan2} is a generalization of @{term arctan} that takes a pair of coordinates
	+of non-zero points returns its angle in the range $[-\pi, \pi)$.\<close>
	+
	+definition atan2 where
	+ "atan2 y x =
	+ (if x > 0 then arctan (y/x)
	+ else if x < 0 then
	+ if y > 0 then arctan (y/x) + pi else arctan (y/x) - pi
	+ else
	+ if y > 0 then pi/2 else if y < 0 then -pi/2 else 0)"
	+
	+lemma atan2_bounded:
	+ shows "-pi \<le> atan2 y x \<and> atan2 y x < pi"
	+ using arctan_bounded[of "y/x"] zero_le_arctan_iff[of "y/x"] arctan_le_zero_iff[of "y/x"] zero_less_arctan_iff[of "y/x"] arctan_less_zero_iff[of "y/x"]
	+ using divide_neg_neg[of y x] divide_neg_pos[of y x] divide_pos_pos[of y x] divide_pos_neg[of y x]
	+ unfolding atan2_def
	+ by (simp (no_asm_simp)) auto
	+
	+end
	diff --git a/thys/Complex_Geometry/Oriented_Circlines.thy b/thys/Complex_Geometry/Oriented_Circlines.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Oriented_Circlines.thy
	@@ -0,0 +1,1373 @@
	+(* -------------------------------------------------------------------------- *)
	+section \<open>Oriented circlines\<close>
	+(* -------------------------------------------------------------------------- *)
	+theory Oriented_Circlines
	+imports Circlines
	+begin
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Oriented circlines definition\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>In this section we describe how the orientation is introduced for the circlines. Similarly as
	+the set of circline points, the set of disc points is introduced using the quadratic form induced by
	+the circline matrix --- the set of points of the circline disc is the set of points such that
	+satisfy that $A\cdot z\cdot \overline{z} + B\cdot \overline{z} + C\cdot z + D < 0$, where
	+$(A, B, C, D)$ is a circline matrix representative Hermitean matrix. As the
	+set of disc points must be invariant to the choice of representative, it is clear that oriented
	+circlines matrices are equivalent only if they are proportional by a positive real factor (recall
	+that unoriented circline allowed arbitrary non-zero real factors).\<close>
	+
	+definition ocircline_eq_cmat :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> bool" where
	+ [simp]: "ocircline_eq_cmat A B \<longleftrightarrow>(\<exists> k::real. k > 0 \<and> B = cor k *\<^sub>s\<^sub>m A)"
	+lift_definition ocircline_eq_clmat :: "circline_mat \<Rightarrow> circline_mat \<Rightarrow> bool" is ocircline_eq_cmat
	+ done
	+
	+lemma ocircline_eq_cmat_id [simp]:
	+ shows "ocircline_eq_cmat H H"
	+ by (simp, rule_tac x=1 in exI, simp)
	+
	+quotient_type ocircline = circline_mat / ocircline_eq_clmat
	+proof (rule equivpI)
	+ show "reflp ocircline_eq_clmat"
	+ unfolding reflp_def
	+ by transfer (auto, rule_tac x="1" in exI, simp)
	+next
	+ show "symp ocircline_eq_clmat"
	+ unfolding symp_def
	+ by transfer (simp only: ocircline_eq_cmat_def, safe, rule_tac x="1/k" in exI, simp)
	+next
	+ show "transp ocircline_eq_clmat"
	+ unfolding transp_def
	+ by transfer (simp only: ocircline_eq_cmat_def, safe, rule_tac x="k*ka" in exI, simp)
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Points on oriented circlines\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Boundary of the circline.\<close>
	+
	+lift_definition on_ocircline :: "ocircline \<Rightarrow> complex_homo \<Rightarrow> bool" is on_circline_clmat_hcoords
	+ by transfer (simp del: quad_form_def, (erule exE)+, simp add: quad_form_scale_m quad_form_scale_v del: quad_form_def)
	+
	+definition ocircline_set :: "ocircline \<Rightarrow> complex_homo set" where
	+ "ocircline_set H = {z. on_ocircline H z}"
	+
	+lemma ocircline_set_I [simp]:
	+ assumes "on_ocircline H z"
	+ shows "z \<in> ocircline_set H"
	+ using assms
	+ unfolding ocircline_set_def
	+ by simp
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Disc and disc complement - in and out points\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Interior and the exterior of an oriented circline.\<close>
	+
	+definition in_ocircline_cmat_cvec :: "complex_mat \<Rightarrow> complex_vec \<Rightarrow> bool" where
	+ [simp]: "in_ocircline_cmat_cvec H z \<longleftrightarrow> Re (quad_form z H) < 0"
	+lift_definition in_ocircline_clmat_hcoords :: "circline_mat \<Rightarrow> complex_homo_coords \<Rightarrow> bool" is in_ocircline_cmat_cvec
	+ done
	+lift_definition in_ocircline :: "ocircline \<Rightarrow> complex_homo \<Rightarrow> bool" is in_ocircline_clmat_hcoords
	+proof transfer
	+ fix H H' z z'
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero" and "hermitean H' \<and> H' \<noteq> mat_zero" and
	+ "z \<noteq> vec_zero" and "z' \<noteq> vec_zero"
	+ assume "ocircline_eq_cmat H H'" and "z \<approx>\<^sub>v z'"
	+ then obtain k k' where
	+ : "0 < k" "H' = cor k \<^sub>s\<^sub>m H" "k' \<noteq> 0" "z' = k' *\<^sub>s\<^sub>v z"
	+ by auto
	+ hence "quad_form z' H' = cor k * cor ((cmod k')\<^sup>2) * quad_form z H"
	+ by (simp add: quad_form_scale_v quad_form_scale_m del: vec_cnj_sv quad_form_def)
	+ hence "Re (quad_form z' H') = k * (cmod k')\<^sup>2 * Re (quad_form z H)"
	+ using hh quad_form_hermitean_real[of H]
	+ by (simp add: power2_eq_square)
	+ thus "in_ocircline_cmat_cvec H z = in_ocircline_cmat_cvec H' z'"
	+ using \<open>k > 0\<close> \<open>k' \<noteq> 0\<close>
	+ using mult_less_0_iff
	+ by fastforce
	+qed
	+
	+definition disc :: "ocircline \<Rightarrow> complex_homo set" where
	+ "disc H = {z. in_ocircline H z}"
	+
	+lemma disc_I [simp]:
	+ assumes "in_ocircline H z"
	+ shows "z \<in> disc H"
	+ using assms
	+ unfolding disc_def
	+ by simp
	+
	+definition out_ocircline_cmat_cvec :: "complex_mat \<Rightarrow> complex_vec \<Rightarrow> bool" where
	+ [simp]: "out_ocircline_cmat_cvec H z \<longleftrightarrow> Re (quad_form z H) > 0"
	+lift_definition out_ocircline_clmat_hcoords :: "circline_mat \<Rightarrow> complex_homo_coords \<Rightarrow> bool" is out_ocircline_cmat_cvec
	+ done
	+lift_definition out_ocircline :: "ocircline \<Rightarrow> complex_homo \<Rightarrow> bool" is out_ocircline_clmat_hcoords
	+proof transfer
	+ fix H H' z z'
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero" "hermitean H' \<and> H' \<noteq> mat_zero"
	+ "z \<noteq> vec_zero" "z' \<noteq> vec_zero"
	+ assume "ocircline_eq_cmat H H'" "z \<approx>\<^sub>v z'"
	+ then obtain k k' where
	+ : "0 < k" "H' = cor k \<^sub>s\<^sub>m H" "k' \<noteq> 0" "z' = k' *\<^sub>s\<^sub>v z"
	+ by auto
	+ hence "quad_form z' H' = cor k * cor ((cmod k')\<^sup>2) * quad_form z H"
	+ by (simp add: quad_form_scale_v quad_form_scale_m del: vec_cnj_sv quad_form_def)
	+ hence "Re (quad_form z' H') = k * (cmod k')\<^sup>2 * Re (quad_form z H)"
	+ using hh quad_form_hermitean_real[of H]
	+ by (simp add: power2_eq_square)
	+ thus "out_ocircline_cmat_cvec H z = out_ocircline_cmat_cvec H' z'"
	+ using \<open>k > 0\<close> \<open>k' \<noteq> 0\<close>
	+ using zero_less_mult_pos
	+ by fastforce
	+qed
	+
	+definition disc_compl :: "ocircline \<Rightarrow> complex_homo set" where
	+ "disc_compl H = {z. out_ocircline H z}"
	+
	+text \<open>These three sets are mutually disjoint and they fill up the entire plane.\<close>
	+
	+lemma disc_compl_I [simp]:
	+ assumes "out_ocircline H z"
	+ shows "z \<in> disc_compl H"
	+ using assms
	+ unfolding disc_compl_def
	+ by simp
	+
	+lemma in_on_out:
	+ shows "in_ocircline H z \<or> on_ocircline H z \<or> out_ocircline H z"
	+ apply (transfer, transfer)
	+ using quad_form_hermitean_real
	+ using complex_eq_if_Re_eq
	+ by auto
	+
	+lemma in_on_out_univ:
	+ shows "disc H \<union> disc_compl H \<union> ocircline_set H = UNIV"
	+ unfolding disc_def disc_compl_def ocircline_set_def
	+ using in_on_out[of H]
	+ by auto
	+
	+lemma disc_inter_disc_compl [simp]:
	+ shows "disc H \<inter> disc_compl H = {}"
	+ unfolding disc_def disc_compl_def
	+ by auto (transfer, transfer, simp)
	+
	+lemma disc_inter_ocircline_set [simp]:
	+ shows "disc H \<inter> ocircline_set H = {}"
	+ unfolding disc_def ocircline_set_def
	+ by auto (transfer, transfer, simp)
	+
	+lemma disc_compl_inter_ocircline_set [simp]:
	+ shows "disc_compl H \<inter> ocircline_set H = {}"
	+ unfolding disc_compl_def ocircline_set_def
	+ by auto (transfer, transfer, simp)
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Opposite orientation\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Finding opposite circline is idempotent, and opposite circlines share the same set of points,
	+but exchange disc and its complement.\<close>
	+
	+definition opposite_ocircline_cmat :: "complex_mat \<Rightarrow> complex_mat" where
	+ [simp]: "opposite_ocircline_cmat H = (-1) *\<^sub>s\<^sub>m H"
	+lift_definition opposite_ocircline_clmat :: "circline_mat \<Rightarrow> circline_mat" is opposite_ocircline_cmat
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+lift_definition opposite_ocircline :: "ocircline \<Rightarrow> ocircline" is opposite_ocircline_clmat
	+ by transfer auto
	+
	+lemma opposite_ocircline_involution [simp]:
	+ shows "opposite_ocircline (opposite_ocircline H) = H"
	+ by (transfer, transfer) (auto, rule_tac x="1" in exI, simp)
	+
	+lemma on_circline_opposite_ocircline_cmat [simp]:
	+ assumes "hermitean H \<and> H \<noteq> mat_zero" and "z \<noteq> vec_zero"
	+ shows "on_circline_cmat_cvec (opposite_ocircline_cmat H) z = on_circline_cmat_cvec H z"
	+ using assms
	+ by (simp add: quad_form_scale_m del: quad_form_def)
	+
	+lemma on_circline_opposite_ocircline [simp]:
	+ shows "on_ocircline (opposite_ocircline H) z \<longleftrightarrow> on_ocircline H z"
	+ using on_circline_opposite_ocircline_cmat
	+ by (transfer, transfer, simp)
	+
	+lemma ocircline_set_opposite_ocircline [simp]:
	+ shows "ocircline_set (opposite_ocircline H) = ocircline_set H"
	+ unfolding ocircline_set_def
	+ by auto
	+
	+lemma disc_compl_opposite_ocircline [simp]:
	+ shows "disc_compl (opposite_ocircline H) = disc H"
	+ unfolding disc_def disc_compl_def
	+ apply auto
	+ apply (transfer, transfer)
	+ apply (auto simp add: quad_form_scale_m simp del: quad_form_def)
	+ apply (transfer ,transfer)
	+ apply (auto simp add: quad_form_scale_m simp del: quad_form_def)
	+ done
	+
	+lemma disc_opposite_ocircline [simp]:
	+ shows "disc (opposite_ocircline H) = disc_compl H"
	+ using disc_compl_opposite_ocircline[of "opposite_ocircline H"]
	+ by simp
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Positive orientation. Conversion between unoriented and oriented circlines\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Given an oriented circline, one can trivially obtain its unoriented counterpart, and these two
	+share the same set of points.\<close>
	+
	+lift_definition of_ocircline :: "ocircline \<Rightarrow> circline" is "id::circline_mat \<Rightarrow> circline_mat"
	+ by transfer (simp, erule exE, force)
	+
	+lemma of_ocircline_opposite_ocircline [simp]:
	+ shows "of_ocircline (opposite_ocircline H) = of_ocircline H"
	+ by (transfer, transfer) (simp, erule exE, rule_tac x="-1" in exI, simp)
	+
	+lemma on_ocircline_of_circline [simp]:
	+ shows "on_circline (of_ocircline H) z \<longleftrightarrow> on_ocircline H z"
	+ by (transfer, transfer, simp)
	+
	+lemma circline_set_of_ocircline [simp]:
	+ shows "circline_set (of_ocircline H) = ocircline_set H"
	+ unfolding ocircline_set_def circline_set_def
	+ by (safe) (transfer, simp)+
	+
	+lemma inj_of_ocircline:
	+ assumes "of_ocircline H = of_ocircline H'"
	+ shows "H = H' \<or> H = opposite_ocircline H'"
	+ using assms
	+ by (transfer, transfer) (simp, metis linorder_neqE_linordered_idom minus_of_real_eq_of_real_iff mult_minus1 mult_sm_distribution neg_0_equal_iff_equal neg_less_0_iff_less)
	+
	+lemma inj_ocircline_set:
	+ assumes "ocircline_set H = ocircline_set H'" and "ocircline_set H \<noteq> {}"
	+ shows "H = H' \<or> H = opposite_ocircline H'"
	+proof-
	+ from assms
	+ have "circline_set (of_ocircline H) = circline_set (of_ocircline H')"
	+ "circline_set (of_ocircline H') \<noteq> {}"
	+ by auto
	+ hence "of_ocircline H = of_ocircline H'"
	+ by (simp add: inj_circline_set)
	+ thus ?thesis
	+ by (rule inj_of_ocircline)
	+qed
	+
	+text \<open>Positive orientation.\<close>
	+
	+text \<open>Given a representative Hermitean matrix of a circline, it represents exactly one of the two
	+possible oriented circlines. The choice of what should be called a positive orientation is
	+arbitrary. We follow Schwerdtfeger \cite{schwerdtfeger}, use the leading coefficient $A$ as the
	+first criterion, and say that circline matrices with $A > 0$ are called positively oriented, and
	+with $A < 0$ negatively oriented. However, Schwerdtfeger did not discuss the possible case of $A =
	+0$ (the case of lines), so we had to extend his definition to achieve a total characterization.\<close>
	+
	+definition pos_oriented_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "pos_oriented_cmat H \<longleftrightarrow>
	+ (let (A, B, C, D) = H
	+ in (Re A > 0 \<or> (Re A = 0 \<and> ((B \<noteq> 0 \<and> arg B > 0) \<or> (B = 0 \<and> Re D > 0)))))"
	+lift_definition pos_oriented_clmat :: "circline_mat \<Rightarrow> bool" is pos_oriented_cmat
	+ done
	+
	+lift_definition pos_oriented :: "ocircline \<Rightarrow> bool" is pos_oriented_clmat
	+ by transfer
	+ (case_tac circline_mat1, case_tac circline_mat2, simp, erule exE, simp,
	+ metis mult_pos_pos zero_less_mult_pos)
	+
	+lemma pos_oriented:
	+ shows "pos_oriented H \<or> pos_oriented (opposite_ocircline H)"
	+proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ moreover
	+ hence "Re A = 0 \<and> Re D = 0 \<longrightarrow> B \<noteq> 0"
	+ using hh hermitean_elems[of A B C D]
	+ by (cases A, cases D) (auto simp add: Complex_eq)
	+ moreover
	+ have "B \<noteq> 0 \<and> \<not> 0 < arg B \<longrightarrow> 0 < arg (- B)"
	+ using canon_ang_plus_pi2[of "arg B"] arg_bounded[of B]
	+ by (auto simp add: arg_uminus)
	+ ultimately
	+ show "pos_oriented_cmat H \<or> pos_oriented_cmat (opposite_ocircline_cmat H)"
	+ by auto
	+qed
	+
	+lemma pos_oriented_opposite_ocircline_cmat [simp]:
	+ assumes "hermitean H \<and> H \<noteq> mat_zero"
	+ shows "pos_oriented_cmat (opposite_ocircline_cmat H) \<longleftrightarrow> \<not> pos_oriented_cmat H"
	+proof-
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ moreover
	+ hence "Re A = 0 \<and> Re D = 0 \<longrightarrow> B \<noteq> 0"
	+ using assms hermitean_elems[of A B C D]
	+ by (cases A, cases D) (auto simp add: Complex_eq)
	+ moreover
	+ have "B \<noteq> 0 \<and> \<not> 0 < arg B \<longrightarrow> 0 < arg (- B)"
	+ using canon_ang_plus_pi2[of "arg B"] arg_bounded[of B]
	+ by (auto simp add: arg_uminus)
	+ moreover
	+ have "B \<noteq> 0 \<and> 0 < arg B \<longrightarrow> \<not> 0 < arg (- B)"
	+ using canon_ang_plus_pi1[of "arg B"] arg_bounded[of B]
	+ by (auto simp add: arg_uminus)
	+ ultimately
	+ show "pos_oriented_cmat (opposite_ocircline_cmat H) = (\<not> pos_oriented_cmat H)"
	+ by simp (metis not_less_iff_gr_or_eq)
	+qed
	+
	+lemma pos_oriented_opposite_ocircline [simp]:
	+ shows "pos_oriented (opposite_ocircline H) \<longleftrightarrow> \<not> pos_oriented H"
	+ using pos_oriented_opposite_ocircline_cmat
	+ by (transfer, transfer, simp)
	+
	+lemma pos_oriented_circle_inf:
	+ assumes "\<infinity>\<^sub>h \<notin> ocircline_set H"
	+ shows "pos_oriented H \<longleftrightarrow> \<infinity>\<^sub>h \<notin> disc H"
	+ using assms
	+ unfolding ocircline_set_def disc_def
	+ apply simp
	+proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ hence "is_real A"
	+ using hh hermitean_elems
	+ by auto
	+ assume "\<not> on_circline_cmat_cvec H \<infinity>\<^sub>v"
	+ thus "pos_oriented_cmat H = (\<not> in_ocircline_cmat_cvec H \<infinity>\<^sub>v)"
	+ using HH \<open>is_real A\<close>
	+ by (cases A) (auto simp add: vec_cnj_def Complex_eq)
	+qed
	+
	+lemma pos_oriented_euclidean_circle:
	+ assumes "is_circle (of_ocircline H)"
	+ "(a, r) = euclidean_circle (of_ocircline H)"
	+ "circline_type (of_ocircline H) < 0"
	+ shows "pos_oriented H \<longleftrightarrow> of_complex a \<in> disc H"
	+ using assms
	+ unfolding disc_def
	+ apply simp
	+proof (transfer, transfer)
	+ fix H a r
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases H) auto
	+ hence "is_real A" "is_real D" "C = cnj B"
	+ using hh hermitean_elems
	+ by auto
	+
	+ assume *: "\<not> circline_A0_cmat (id H)" "(a, r) = euclidean_circle_cmat (id H)" "circline_type_cmat (id H) < 0"
	+ hence "A \<noteq> 0" "Re A \<noteq> 0"
	+ using HH \<open>is_real A\<close>
	+ by (case_tac[!] A) (auto simp add: Complex_eq)
	+
	+ have "Re (AD - BC) < 0"
	+ using \<open>circline_type_cmat (id H) < 0\<close> HH
	+ by simp
	+
	+ have *: "(A (D * cnj A) - B * (C * cnj A)) / (A * cnj A) = (AD - BC) / A"
	+ using \<open>A \<noteq> 0\<close>
	+ by (simp add: field_simps)
	+ hence **: "0 < Re A \<longleftrightarrow> Re ((A (D * cnj A) - B * (C * cnj A)) / (A * cnj A)) < 0"
	+ using \<open>is_real A\<close> \<open>A \<noteq> 0\<close> \<open>Re (AD - BC) < 0\<close>
	+ by (simp add: Re_divide_real divide_less_0_iff)
	+
	+ have "Re D - Re (cnj B * B / cnj A) < Re ((C - cnj B * A / cnj A) * B / A)" if "Re A > 0"
	+ using HH * \<open>is_real A\<close> that
	+ by simp (smt "" "*" cnj.simps(1) cnj.simps(2) complex_eq diff_divide_distrib left_diff_distrib'
	+ minus_complex.simps(1) mult.commute nonzero_mult_div_cancel_right)?
	+ moreover have "Re A > 0" if "Re D - Re (cnj B * B / cnj A) < Re ((C - cnj B * A / cnj A) * B / A)"
	+ using HH * \<open>is_real A\<close> that
	+ by simp (smt "" "*" cnj.simps(1) cnj.simps(2) complex_eq diff_divide_distrib left_diff_distrib'
	+ minus_complex.simps(1) mult.commute nonzero_mult_div_cancel_right)?
	+ ultimately show "pos_oriented_cmat H = in_ocircline_cmat_cvec H (of_complex_cvec a)"
	+ using HH \<open>Re A \<noteq> 0\<close> * \<open>is_real A\<close> by (auto simp add: vec_cnj_def)
	+qed
	+
	+text \<open>Introduce positive orientation\<close>
	+
	+definition of_circline_cmat :: "complex_mat \<Rightarrow> complex_mat" where
	+ [simp]: "of_circline_cmat H = (if pos_oriented_cmat H then H else opposite_ocircline_cmat H)"
	+
	+lift_definition of_circline_clmat :: "circline_mat \<Rightarrow> circline_mat" is of_circline_cmat
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+
	+lemma of_circline_clmat_def':
	+ shows "of_circline_clmat H = (if pos_oriented_clmat H then H else opposite_ocircline_clmat H)"
	+ by transfer simp
	+
	+lemma pos_oriented_cmat_mult_positive':
	+ assumes
	+ "hermitean H1 \<and> H1 \<noteq> mat_zero" and
	+ "hermitean H2 \<and> H2 \<noteq> mat_zero" and
	+ "\<exists>k. k > 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1" and
	+ "pos_oriented_cmat H1"
	+ shows "pos_oriented_cmat H2"
	+proof-
	+ obtain A1 B1 C1 D1 A2 B2 C2 D2
	+ where HH: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
	+ by (cases H1, cases H2)
	+ thus ?thesis
	+ using assms
	+ by fastforce
	+qed
	+
	+lemma pos_oriented_cmat_mult_positive:
	+ assumes
	+ "hermitean H1 \<and> H1 \<noteq> mat_zero" and
	+ "hermitean H2 \<and> H2 \<noteq> mat_zero" and
	+ "\<exists>k. k > 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
	+ shows
	+ "pos_oriented_cmat H1 \<longleftrightarrow> pos_oriented_cmat H2"
	+proof-
	+ from assms(3) obtain k where "k > 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
	+ by auto
	+ hence "\<exists>k. k > 0 \<and> H1 = cor k *\<^sub>s\<^sub>m H2"
	+ by (rule_tac x="1/k" in exI, auto)
	+ thus ?thesis
	+ using assms pos_oriented_cmat_mult_positive'
	+ by blast
	+qed
	+
	+
	+lemma pos_oriented_cmat_mult_negative:
	+ assumes
	+ "hermitean H1 \<and> H1 \<noteq> mat_zero" and
	+ "hermitean H2 \<and> H2 \<noteq> mat_zero" and
	+ "\<exists>k. k < 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
	+ shows
	+ "pos_oriented_cmat H1 \<longleftrightarrow> \<not> pos_oriented_cmat H2"
	+ using assms
	+proof-
	+ obtain A B C D A1 B1 C1 D1
	+ where *: "H1 = (A, B, C, D)" "H2 = (A1, B1, C1, D1)"
	+ by (cases H1, cases H2) auto
	+ hence **: "is_real A" "is_real D" "is_real A1" "is_real D1" "B = 0 \<longleftrightarrow> C = 0" "B1 = 0 \<longleftrightarrow> C1 = 0"
	+ using assms hermitean_elems[of A B C D] hermitean_elems[of A1 B1 C1 D1]
	+ by auto
	+ show ?thesis
	+ proof (rule iffI)
	+ assume H1: "pos_oriented_cmat H1"
	+ show "\<not> pos_oriented_cmat H2"
	+ proof (cases "Re A > 0")
	+ case True
	+ thus ?thesis
	+ using assms * ** mult_neg_pos
	+ by fastforce
	+ next
	+ case False
	+ show ?thesis
	+ proof (cases "B = 0")
	+ case True
	+ thus ?thesis
	+ using assms * ** H1 `\<not> Re A > 0` mult_neg_pos
	+ by fastforce
	+ next
	+ case False
	+ thus ?thesis
	+ using arg_uminus_opposite_sign[of B] arg_mult_real_negative
	+ using assms * ** H1 `\<not> Re A > 0` mult_neg_pos
	+ by fastforce
	+ qed
	+ qed
	+ next
	+ assume H2: "\<not> pos_oriented_cmat H2"
	+ show "pos_oriented_cmat H1"
	+ proof (cases "Re A > 0")
	+ case True
	+ thus ?thesis
	+ using * ** mult_neg_pos
	+ by fastforce
	+ next
	+ case False
	+ show ?thesis
	+ proof (cases "B = 0")
	+ case True
	+ thus ?thesis
	+ using assms * ** H2 `\<not> Re A > 0`
	+ by simp (smt arg_0_iff arg_complex_of_real_negative arg_complex_of_real_positive arg_mult_eq complex_of_real_Re mult.right_neutral mult_eq_0_iff of_real_0 of_real_1 zero_complex.simps(1))
	+ next
	+ case False
	+ thus ?thesis
	+ using assms `\<not> Re A > 0` H2 * **
	+ using arg_uminus_opposite_sign[of B]
	+ by (cases "Re A = 0", auto simp add: mult_neg_neg)
	+ qed
	+ qed
	+ qed
	+qed
	+
	+lift_definition of_circline :: "circline \<Rightarrow> ocircline" is of_circline_clmat
	+proof transfer
	+ fix H1 H2
	+ assume hh:
	+ "hermitean H1 \<and> H1 \<noteq> mat_zero"
	+ "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ assume "circline_eq_cmat H1 H2"
	+ then obtain k where : "k \<noteq> 0 \<and> H2 = cor k \<^sub>s\<^sub>m H1"
	+ by auto
	+ show "ocircline_eq_cmat (of_circline_cmat H1) (of_circline_cmat H2)"
	+ proof (cases "k > 0")
	+ case True
	+ hence "pos_oriented_cmat H1 = pos_oriented_cmat H2"
	+ using * pos_oriented_cmat_mult_positive[OF hh]
	+ by blast
	+ thus ?thesis
	+ using hh * \<open>k > 0\<close>
	+ apply (simp del: pos_oriented_cmat_def)
	+ apply (rule conjI)
	+ apply (rule impI)
	+ apply (simp, rule_tac x=k in exI, simp)
	+ apply (rule impI)
	+ apply (simp, rule_tac x=k in exI, simp)
	+ done
	+ next
	+ case False
	+ hence "k < 0"
	+ using *
	+ by simp
	+ hence "pos_oriented_cmat H1 \<longleftrightarrow> \<not> (pos_oriented_cmat H2)"
	+ using * pos_oriented_cmat_mult_negative[OF hh]
	+ by blast
	+ thus ?thesis
	+ using hh * \<open>k < 0\<close>
	+ apply (simp del: pos_oriented_cmat_def)
	+ apply (rule conjI)
	+ apply (rule impI)
	+ apply (simp, rule_tac x="-k" in exI, simp)
	+ apply (rule impI)
	+ apply (simp, rule_tac x="-k" in exI, simp)
	+ done
	+ qed
	+qed
	+
	+lemma pos_oriented_of_circline [simp]:
	+ shows "pos_oriented (of_circline H)"
	+ using pos_oriented_opposite_ocircline_cmat
	+ by (transfer, transfer, simp)
	+
	+lemma of_ocircline_of_circline [simp]:
	+ shows "of_ocircline (of_circline H) = H"
	+ apply (transfer, auto simp add: of_circline_clmat_def')
	+ apply (transfer, simp, rule_tac x="-1" in exI, simp)
	+ done
	+
	+lemma of_circline_of_ocircline_pos_oriented [simp]:
	+ assumes "pos_oriented H"
	+ shows "of_circline (of_ocircline H) = H"
	+ using assms
	+ by (transfer, transfer, simp, rule_tac x=1 in exI, simp)
	+
	+lemma inj_of_circline:
	+ assumes "of_circline H = of_circline H'"
	+ shows "H = H'"
	+ using assms
	+proof (transfer, transfer)
	+ fix H H'
	+ assume "ocircline_eq_cmat (of_circline_cmat H) (of_circline_cmat H')"
	+ then obtain k where "k > 0" "of_circline_cmat H' = cor k *\<^sub>s\<^sub>m of_circline_cmat H"
	+ by auto
	+ thus "circline_eq_cmat H H'"
	+ using mult_sm_inv_l[of "-1" "H'" "cor k *\<^sub>s\<^sub>m H"]
	+ using mult_sm_inv_l[of "-1" "H'" "(- (cor k)) *\<^sub>s\<^sub>m H"]
	+ apply (simp split: if_split_asm)
	+ apply (rule_tac x="k" in exI, simp)
	+ apply (rule_tac x="-k" in exI, simp)
	+ apply (rule_tac x="-k" in exI, simp)
	+ apply (rule_tac x="k" in exI, simp)
	+ done
	+qed
	+
	+lemma of_circline_of_ocircline:
	+ shows "of_circline (of_ocircline H') = H' \<or>
	+ of_circline (of_ocircline H') = opposite_ocircline H'"
	+proof (cases "pos_oriented H'")
	+ case True
	+ thus ?thesis
	+ by auto
	+next
	+ case False
	+ hence "pos_oriented (opposite_ocircline H')"
	+ using pos_oriented
	+ by auto
	+ thus ?thesis
	+ using of_ocircline_opposite_ocircline[of H']
	+ using of_circline_of_ocircline_pos_oriented [of "opposite_ocircline H'"]
	+ by auto
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Set of points on oriented and unoriented circlines\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+lemma ocircline_set_of_circline [simp]:
	+ shows "ocircline_set (of_circline H) = circline_set H"
	+ unfolding ocircline_set_def circline_set_def
	+proof (safe)
	+ fix z
	+ assume "on_ocircline (of_circline H) z"
	+ thus "on_circline H z"
	+ by (transfer, transfer, simp del: on_circline_cmat_cvec_def opposite_ocircline_cmat_def split: if_split_asm)
	+next
	+ fix z
	+ assume "on_circline H z"
	+ thus "on_ocircline (of_circline H) z"
	+ by (transfer, transfer, simp del: on_circline_cmat_cvec_def opposite_ocircline_cmat_def split: if_split_asm)
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Some special oriented circlines and discs\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lift_definition mk_ocircline :: "complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> ocircline" is mk_circline_clmat
	+ done
	+
	+text \<open>oriented unit circle and unit disc\<close>
	+
	+lift_definition ounit_circle :: "ocircline" is unit_circle_clmat
	+ done
	+
	+lemma pos_oriented_ounit_circle [simp]:
	+ shows "pos_oriented ounit_circle"
	+ by (transfer, transfer, simp)
	+
	+lemma of_ocircline_ounit_circle [simp]:
	+ shows "of_ocircline ounit_circle = unit_circle"
	+ by (transfer, transfer, simp)
	+
	+lemma of_circline_unit_circle [simp]:
	+ shows "of_circline (unit_circle) = ounit_circle"
	+ by (transfer, transfer, simp)
	+
	+lemma ocircline_set_ounit_circle [simp]:
	+ shows "ocircline_set ounit_circle = circline_set unit_circle"
	+ apply (subst of_circline_unit_circle[symmetric])
	+ apply (subst ocircline_set_of_circline)
	+ apply simp
	+ done
	+
	+definition unit_disc :: "complex_homo set" where
	+ "unit_disc = disc ounit_circle"
	+
	+definition unit_disc_compl :: "complex_homo set" where
	+ "unit_disc_compl = disc_compl ounit_circle"
	+
	+definition unit_circle_set :: "complex_homo set" where
	+ "unit_circle_set = circline_set unit_circle"
	+
	+lemma zero_in_unit_disc [simp]:
	+ shows "0\<^sub>h \<in> unit_disc"
	+ unfolding unit_disc_def disc_def
	+ by (simp, transfer, transfer) (simp add: Let_def vec_cnj_def)
	+
	+lemma one_notin_unit_dic [simp]:
	+ shows "1\<^sub>h \<notin> unit_disc"
	+ unfolding unit_disc_def disc_def
	+ by (simp, transfer, transfer) (simp add: Let_def vec_cnj_def)
	+
	+lemma inf_notin_unit_disc [simp]:
	+ shows "\<infinity>\<^sub>h \<notin> unit_disc"
	+ unfolding unit_disc_def disc_def
	+ by (simp, transfer, transfer) (simp add: Let_def vec_cnj_def)
	+
	+lemma unit_disc_iff_cmod_lt_1 [simp]:
	+ shows "of_complex c \<in> unit_disc \<longleftrightarrow> cmod c < 1"
	+ unfolding unit_disc_def disc_def
	+ by (simp, transfer, transfer, simp add: vec_cnj_def cmod_def power2_eq_square)
	+
	+lemma unit_disc_cmod_square_lt_1 [simp]:
	+ assumes "z \<in> unit_disc"
	+ shows "(cmod (to_complex z))\<^sup>2 < 1"
	+ using assms inf_or_of_complex[of z]
	+ by (auto simp add: abs_square_less_1)
	+
	+lemma unit_disc_to_complex_inj:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ assumes "to_complex u = to_complex v"
	+ shows "u = v"
	+ using assms
	+ using inf_or_of_complex[of u] inf_or_of_complex[of v]
	+ by auto
	+
	+lemma inversion_unit_disc [simp]:
	+ shows "inversion ` unit_disc = unit_disc_compl"
	+ unfolding unit_disc_def unit_disc_compl_def disc_def disc_compl_def
	+proof safe
	+ fix x
	+ assume "in_ocircline ounit_circle x"
	+ thus "out_ocircline ounit_circle (inversion x)"
	+ unfolding inversion_def
	+ by (transfer, transfer, auto simp add: vec_cnj_def)
	+next
	+ fix x
	+ assume *: "out_ocircline ounit_circle x"
	+ show "x \<in> inversion ` Collect (in_ocircline ounit_circle)"
	+ proof (rule image_eqI)
	+ show "x = inversion (inversion x)"
	+ by auto
	+ next
	+ show "inversion x \<in> Collect (in_ocircline ounit_circle)"
	+ using *
	+ unfolding inversion_def
	+ by (simp, transfer, transfer, auto simp add: vec_cnj_def)
	+ qed
	+qed
	+
	+lemma inversion_unit_disc_compl [simp]:
	+ shows "inversion ` unit_disc_compl = unit_disc"
	+proof-
	+ have "inversion ` (inversion ` unit_disc) = unit_disc"
	+ by (auto simp del: inversion_unit_disc simp add: image_iff)
	+ thus ?thesis
	+ by simp
	+qed
	+
	+lemma inversion_noteq_unit_disc:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "inversion u \<noteq> v"
	+proof-
	+ from assms
	+ have "inversion u \<in> unit_disc_compl"
	+ by (metis image_eqI inversion_unit_disc)
	+ thus ?thesis
	+ using assms
	+ unfolding unit_disc_def unit_disc_compl_def
	+ using disc_inter_disc_compl
	+ by fastforce
	+qed
	+
	+lemma in_ocircline_ounit_circle_conjugate [simp]:
	+ assumes "in_ocircline ounit_circle z"
	+ shows "in_ocircline ounit_circle (conjugate z)"
	+ using assms
	+ by (transfer, transfer, auto simp add: vec_cnj_def)
	+
	+lemma conjugate_unit_disc [simp]:
	+ shows "conjugate ` unit_disc = unit_disc"
	+ unfolding unit_disc_def disc_def
	+ apply (auto simp add: image_iff)
	+ apply (rule_tac x="conjugate x" in exI, simp)
	+ done
	+
	+lemma conjugate_in_unit_disc [simp]:
	+ assumes "z \<in> unit_disc"
	+ shows "conjugate z \<in> unit_disc"
	+ using conjugate_unit_disc
	+ using assms
	+ by blast
	+
	+lemma out_ocircline_ounit_circle_conjugate [simp]:
	+ assumes "out_ocircline ounit_circle z"
	+ shows "out_ocircline ounit_circle (conjugate z)"
	+ using assms
	+ by (transfer, transfer, auto simp add: vec_cnj_def)
	+
	+lemma conjugate_unit_disc_compl [simp]:
	+ shows "conjugate ` unit_disc_compl = unit_disc_compl"
	+ unfolding unit_disc_compl_def disc_compl_def
	+ apply (auto simp add: image_iff)
	+ apply (rule_tac x="conjugate x" in exI, simp)
	+ done
	+
	+lemma conjugate_in_unit_disc_compl [simp]:
	+ assumes "z \<in> unit_disc_compl"
	+ shows "conjugate z \<in> unit_disc_compl"
	+ using conjugate_unit_disc_compl
	+ using assms
	+ by blast
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Oriented x axis and lower half plane\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+lift_definition o_x_axis :: "ocircline" is x_axis_clmat
	+done
	+
	+lemma o_x_axis_pos_oriented [simp]:
	+ shows "pos_oriented o_x_axis"
	+ by (transfer, transfer, simp)
	+
	+lemma of_ocircline_o_x_axis [simp]:
	+ shows "of_ocircline o_x_axis = x_axis"
	+ by (transfer, transfer, simp)
	+
	+lemma of_circline_x_axis [simp]:
	+ shows "of_circline x_axis = o_x_axis"
	+ using of_circline_of_ocircline_pos_oriented[of o_x_axis]
	+ using o_x_axis_pos_oriented
	+ by simp
	+
	+lemma ocircline_set_circline_set_x_axis [simp]:
	+ shows "ocircline_set o_x_axis = circline_set x_axis"
	+ by (subst of_circline_x_axis[symmetric], subst ocircline_set_of_circline, simp)
	+
	+lemma ii_in_disc_o_x_axis [simp]:
	+ shows "ii\<^sub>h \<notin> disc o_x_axis"
	+ unfolding disc_def
	+ by simp (transfer, transfer, simp add: Let_def vec_cnj_def)
	+
	+lemma ii_notin_disc_o_x_axis [simp]:
	+ shows "ii\<^sub>h \<in> disc_compl o_x_axis"
	+ unfolding disc_compl_def
	+ by simp (transfer, transfer, simp add: Let_def vec_cnj_def)
	+
	+lemma of_complex_in_o_x_axis_disc [simp]:
	+ shows "of_complex z \<in> disc o_x_axis \<longleftrightarrow> Im z < 0"
	+ unfolding disc_def
	+ by auto (transfer, transfer, simp add: vec_cnj_def)+
	+
	+lemma inf_notin_disc_o_x_axis [simp]:
	+ shows "\<infinity>\<^sub>h \<notin> disc o_x_axis"
	+ unfolding disc_def
	+ by simp (transfer, transfer, simp add: vec_cnj_def)
	+
	+lemma disc_o_x_axis:
	+ shows "disc o_x_axis = of_complex ` {z. Im z < 0}"
	+proof-
	+ {
	+ fix z
	+ assume "z \<in> disc o_x_axis"
	+ hence "\<exists> x. Im x < 0 \<and> z = of_complex x"
	+ using inf_or_of_complex[of z]
	+ by auto
	+ }
	+ thus ?thesis
	+ by (auto simp add: image_iff)
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Oriented single point circline\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+lift_definition o_circline_point_0 :: "ocircline" is circline_point_0_clmat
	+done
	+
	+lemma of_ocircline_o_circline_point_0 [simp]:
	+ shows "of_ocircline o_circline_point_0 = circline_point_0"
	+ by (transfer, transfer, simp)
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Möbius action on oriented circlines and discs\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Möbius action on an oriented circline is the same as on to an unoriented circline.\<close>
	+
	+lift_definition moebius_ocircline :: "moebius \<Rightarrow> ocircline \<Rightarrow> ocircline" is moebius_circline_mmat_clmat
	+ apply (transfer, transfer)
	+ apply simp
	+ apply ((erule exE)+, (erule conjE)+)
	+ apply (simp add: mat_inv_mult_sm)
	+ apply (rule_tac x="ka / Re (k * cnj k)" in exI, auto simp add: complex_mult_cnj_cmod power2_eq_square)
	+ done
	+
	+text \<open>Möbius action on (unoriented) circlines could have been defined using the action on oriented
	+circlines, but not the other way around.\<close>
	+
	+lemma moebius_circline_ocircline:
	+ shows "moebius_circline M H = of_ocircline (moebius_ocircline M (of_circline H))"
	+ apply (transfer, simp add: of_circline_clmat_def', safe)
	+ apply (transfer, simp, rule_tac x="-1" in exI, simp)
	+ done
	+
	+lemma moebius_ocircline_circline:
	+ shows "moebius_ocircline M H = of_circline (moebius_circline M (of_ocircline H)) \<or>
	+ moebius_ocircline M H = opposite_ocircline (of_circline (moebius_circline M (of_ocircline H)))"
	+ apply (transfer, simp add: of_circline_clmat_def', safe)
	+ apply (transfer, simp, rule_tac x="1" in exI, simp)
	+ apply (transfer, simp, erule_tac x="1" in allE, simp)
	+ done
	+
	+text \<open>Möbius action on oriented circlines have many nice properties as it was the case with
	+Möbius action on (unoriented) circlines. These transformations are injective and form group under
	+composition.\<close>
	+
	+lemma inj_moebius_ocircline [simp]:
	+ shows "inj (moebius_ocircline M)"
	+ unfolding inj_on_def
	+proof (safe)
	+ fix H H'
	+ assume "moebius_ocircline M H = moebius_ocircline M H'"
	+ thus "H = H'"
	+ proof (transfer, transfer)
	+ fix M H H' :: complex_mat
	+ assume "mat_det M \<noteq> 0"
	+ let ?iM = "mat_inv M"
	+ assume "ocircline_eq_cmat (moebius_circline_cmat_cmat M H) (moebius_circline_cmat_cmat M H')"
	+ then obtain k where "congruence ?iM H' = congruence ?iM (cor k *\<^sub>s\<^sub>m H)" "k > 0"
	+ by (auto simp del: congruence_def)
	+ thus "ocircline_eq_cmat H H'"
	+ using \<open>mat_det M \<noteq> 0\<close> inj_congruence[of ?iM H' "cor k *\<^sub>s\<^sub>m H"] mat_det_inv[of M]
	+ by auto
	+ qed
	+qed
	+
	+lemma moebius_ocircline_id_moebius [simp]:
	+ shows "moebius_ocircline id_moebius H = H"
	+ by (transfer, transfer) (force simp add: mat_adj_def mat_cnj_def)
	+
	+lemma moebius_ocircline_comp [simp]:
	+ shows "moebius_ocircline (moebius_comp M1 M2) H = moebius_ocircline M1 (moebius_ocircline M2 H)"
	+ by (transfer, transfer, simp, rule_tac x=1 in exI, simp add: mat_inv_mult_mm mult_mm_assoc)
	+
	+lemma moebius_ocircline_comp_inv_left [simp]:
	+ shows "moebius_ocircline (moebius_inv M) (moebius_ocircline M H) = H"
	+ by (subst moebius_ocircline_comp[symmetric]) simp
	+
	+lemma moebius_ocircline_comp_inv_right [simp]:
	+ shows "moebius_ocircline M (moebius_ocircline (moebius_inv M) H) = H"
	+ by (subst moebius_ocircline_comp[symmetric]) simp
	+
	+lemma moebius_ocircline_opposite_ocircline [simp]:
	+ shows "moebius_ocircline M (opposite_ocircline H) = opposite_ocircline (moebius_ocircline M H)"
	+ by (transfer, transfer, simp, rule_tac x=1 in exI, simp)
	+
	+text \<open>Möbius action on oriented circlines preserve the set of points of the circline.\<close>
	+
	+lemma ocircline_set_moebius_ocircline [simp]:
	+ shows "ocircline_set (moebius_ocircline M H) = moebius_pt M ` ocircline_set H" (is "?lhs = ?rhs")
	+proof-
	+ have "?rhs = circline_set (moebius_circline M (of_ocircline H))"
	+ by simp
	+ thus ?thesis
	+ using moebius_ocircline_circline[of M H]
	+ by auto
	+qed
	+
	+lemma ocircline_set_fix_iff_ocircline_fix:
	+ assumes "ocircline_set H' \<noteq> {}"
	+ shows "ocircline_set (moebius_ocircline M H) = ocircline_set H' \<longleftrightarrow>
	+ moebius_ocircline M H = H' \<or> moebius_ocircline M H = opposite_ocircline H'"
	+ using assms
	+ using inj_ocircline_set[of "moebius_ocircline M H" H']
	+ by (auto simp del: ocircline_set_moebius_ocircline)
	+
	+lemma disc_moebius_ocircline [simp]:
	+ shows "disc (moebius_ocircline M H) = moebius_pt M ` (disc H)"
	+proof (safe)
	+ fix z
	+ assume "z \<in> disc H"
	+ thus "moebius_pt M z \<in> disc (moebius_ocircline M H)"
	+ unfolding disc_def
	+ proof (safe)
	+ assume "in_ocircline H z"
	+ thus "in_ocircline (moebius_ocircline M H) (moebius_pt M z)"
	+ proof (transfer, transfer)
	+ fix H M :: complex_mat and z :: complex_vec
	+ assume "mat_det M \<noteq> 0"
	+ assume "in_ocircline_cmat_cvec H z"
	+ thus "in_ocircline_cmat_cvec (moebius_circline_cmat_cmat M H) (moebius_pt_cmat_cvec M z)"
	+ using \<open>mat_det M \<noteq> 0\<close> quad_form_congruence[of M z]
	+ by simp
	+ qed
	+ qed
	+next
	+ fix z
	+ assume "z \<in> disc (moebius_ocircline M H)"
	+ thus "z \<in> moebius_pt M ` disc H"
	+ unfolding disc_def
	+ proof(safe)
	+ assume "in_ocircline (moebius_ocircline M H) z"
	+ show "z \<in> moebius_pt M ` Collect (in_ocircline H)"
	+ proof
	+ show "z = moebius_pt M (moebius_pt (moebius_inv M) z)"
	+ by simp
	+ next
	+ show "moebius_pt (moebius_inv M) z \<in> Collect (in_ocircline H)"
	+ using \<open>in_ocircline (moebius_ocircline M H) z\<close>
	+ proof (safe, transfer, transfer)
	+ fix M H :: complex_mat and z :: complex_vec
	+ assume "mat_det M \<noteq> 0"
	+ hence "congruence (mat_inv (mat_inv M)) (congruence (mat_inv M) H) = H"
	+ by (simp del: congruence_def)
	+ hence "quad_form z (congruence (mat_inv M) H) = quad_form (mat_inv M *\<^sub>m\<^sub>v z) H"
	+ using quad_form_congruence[of "mat_inv M" "z" "congruence (mat_inv M) H"]
	+ using \<open>mat_det M \<noteq> 0\<close> mat_det_inv[of "M"]
	+ by simp
	+ moreover
	+ assume "in_ocircline_cmat_cvec (moebius_circline_cmat_cmat M H) z"
	+ ultimately
	+ show "in_ocircline_cmat_cvec H (moebius_pt_cmat_cvec (moebius_inv_cmat M) z)"
	+ by simp
	+ qed
	+ qed
	+ qed
	+qed
	+
	+lemma disc_compl_moebius_ocircline [simp]:
	+ shows "disc_compl (moebius_ocircline M H) = moebius_pt M ` (disc_compl H)"
	+proof (safe)
	+ fix z
	+ assume "z \<in> disc_compl H"
	+ thus "moebius_pt M z \<in> disc_compl (moebius_ocircline M H)"
	+ unfolding disc_compl_def
	+ proof (safe)
	+ assume "out_ocircline H z"
	+ thus "out_ocircline (moebius_ocircline M H) (moebius_pt M z)"
	+ proof (transfer, transfer)
	+ fix H M :: complex_mat and z :: complex_vec
	+ assume "mat_det M \<noteq> 0"
	+ assume "out_ocircline_cmat_cvec H z"
	+ thus "out_ocircline_cmat_cvec (moebius_circline_cmat_cmat M H) (moebius_pt_cmat_cvec M z)"
	+ using \<open>mat_det M \<noteq> 0\<close> quad_form_congruence[of M z]
	+ by simp
	+ qed
	+ qed
	+next
	+ fix z
	+ assume "z \<in> disc_compl (moebius_ocircline M H)"
	+ thus "z \<in> moebius_pt M ` disc_compl H"
	+ unfolding disc_compl_def
	+ proof(safe)
	+ assume "out_ocircline (moebius_ocircline M H) z"
	+ show "z \<in> moebius_pt M ` Collect (out_ocircline H)"
	+ proof
	+ show "z = moebius_pt M (moebius_pt (moebius_inv M) z)"
	+ by simp
	+ next
	+ show "moebius_pt (moebius_inv M) z \<in> Collect (out_ocircline H)"
	+ using \<open>out_ocircline (moebius_ocircline M H) z\<close>
	+ proof (safe, transfer, transfer)
	+ fix M H :: complex_mat and z :: complex_vec
	+ assume "mat_det M \<noteq> 0"
	+ hence "congruence (mat_inv (mat_inv M)) (congruence (mat_inv M) H) = H"
	+ by (simp del: congruence_def)
	+ hence "quad_form z (congruence (mat_inv M) H) = quad_form (mat_inv M *\<^sub>m\<^sub>v z) H"
	+ using quad_form_congruence[of "mat_inv M" "z" "congruence (mat_inv M) H"]
	+ using \<open>mat_det M \<noteq> 0\<close> mat_det_inv[of "M"]
	+ by simp
	+ moreover
	+ assume "out_ocircline_cmat_cvec (moebius_circline_cmat_cmat M H) z"
	+ ultimately
	+ show "out_ocircline_cmat_cvec H (moebius_pt_cmat_cvec (moebius_inv_cmat M) z)"
	+ by simp
	+ qed
	+ qed
	+ qed
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Orientation after Möbius transformations\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>All Euclidean similarities preserve circline orientation.\<close>
	+
	+lemma moebius_similarity_oriented_lines_to_oriented_lines:
	+ assumes "a \<noteq> 0"
	+ shows "\<infinity>\<^sub>h \<in> ocircline_set H \<longleftrightarrow> \<infinity>\<^sub>h \<in> ocircline_set (moebius_ocircline (moebius_similarity a b) H)"
	+ using moebius_similarity_lines_to_lines[OF \<open>a \<noteq> 0\<close>, of b "of_ocircline H"]
	+ by simp
	+
	+lemma moebius_similarity_preserve_orientation':
	+ assumes "a \<noteq> 0" and "\<infinity>\<^sub>h \<notin> ocircline_set H" and "pos_oriented H"
	+ shows "pos_oriented (moebius_ocircline (moebius_similarity a b) H)"
	+proof-
	+ let ?M = "moebius_similarity a b"
	+ let ?H = "moebius_ocircline ?M H"
	+ have "\<infinity>\<^sub>h \<notin> ocircline_set ?H"
	+ using \<open>\<infinity>\<^sub>h \<notin> ocircline_set H\<close> moebius_similarity_oriented_lines_to_oriented_lines[OF \<open>a \<noteq> 0\<close>]
	+ by simp
	+
	+ have "\<infinity>\<^sub>h \<in> disc_compl H"
	+ using \<open>\<infinity>\<^sub>h \<notin> ocircline_set H\<close> \<open>pos_oriented H\<close> pos_oriented_circle_inf[of H] in_on_out
	+ unfolding disc_def disc_compl_def ocircline_set_def
	+ by auto
	+ hence "\<infinity>\<^sub>h \<in> disc_compl ?H"
	+ using moebius_similarity_inf[OF \<open>a \<noteq> 0\<close>, of b]
	+ by force
	+ thus "pos_oriented ?H"
	+ using pos_oriented_circle_inf[of ?H] disc_inter_disc_compl[of ?H] \<open>\<infinity>\<^sub>h \<notin> ocircline_set ?H\<close>
	+ by auto
	+qed
	+
	+lemma moebius_similarity_preserve_orientation:
	+ assumes "a \<noteq> 0" and "\<infinity>\<^sub>h \<notin> ocircline_set H"
	+ shows "pos_oriented H \<longleftrightarrow> pos_oriented(moebius_ocircline (moebius_similarity a b) H)"
	+proof-
	+ let ?M = "moebius_similarity a b"
	+ let ?H = "moebius_ocircline ?M H"
	+ have "\<infinity>\<^sub>h \<notin> ocircline_set ?H"
	+ using \<open>\<infinity>\<^sub>h \<notin> ocircline_set H\<close> moebius_similarity_oriented_lines_to_oriented_lines[OF \<open>a \<noteq> 0\<close>]
	+ by simp
	+
	+ have *: "H = moebius_ocircline (- moebius_similarity a b) ?H"
	+ by simp
	+ show ?thesis
	+ using \<open>a \<noteq> 0\<close>
	+ using moebius_similarity_preserve_orientation' [OF \<open>a \<noteq> 0\<close> \<open>\<infinity>\<^sub>h \<notin> ocircline_set H\<close>]
	+ using moebius_similarity_preserve_orientation'[OF _ \<open>\<infinity>\<^sub>h \<notin> ocircline_set ?H\<close>, of "1/a" "-b/a"]
	+ using moebius_similarity_inv[of a b, OF \<open>a \<noteq> 0\<close>] *
	+ by auto
	+qed
	+
	+lemma reciprocal_preserve_orientation:
	+ assumes "0\<^sub>h \<in> disc_compl H"
	+ shows "pos_oriented (moebius_ocircline moebius_reciprocal H)"
	+proof-
	+ have "\<infinity>\<^sub>h \<in> disc_compl (moebius_ocircline moebius_reciprocal H)"
	+ using assms
	+ by force
	+ thus "pos_oriented (moebius_ocircline moebius_reciprocal H)"
	+ using pos_oriented_circle_inf[of "moebius_ocircline moebius_reciprocal H"]
	+ using disc_inter_disc_compl[of "moebius_ocircline moebius_reciprocal H"]
	+ using disc_compl_inter_ocircline_set[of "moebius_ocircline moebius_reciprocal H"]
	+ by auto
	+qed
	+
	+
	+lemma reciprocal_not_preserve_orientation:
	+ assumes "0\<^sub>h \<in> disc H"
	+ shows "\<not> pos_oriented (moebius_ocircline moebius_reciprocal H)"
	+proof-
	+ let ?H = "moebius_ocircline moebius_reciprocal H"
	+ have "\<infinity>\<^sub>h \<in> disc ?H"
	+ using assms
	+ by force
	+ thus "\<not> pos_oriented ?H"
	+ using pos_oriented_circle_inf[of ?H] disc_inter_ocircline_set[of ?H]
	+ by auto
	+qed
	+
	+text \<open>Orientation of the image of a given oriented circline $H$ under a given Möbius transformation
	+$M$ depends on whether the pole of $M$ (the point that $M$ maps to $\infty_{hc}$) lies in the disc
	+or in the disc complement of $H$ (if it is on the set of $H$, then it maps onto a line and we do not
	+discuss the orientation).\<close>
	+
	+lemma pole_in_disc:
	+ assumes "M = mk_moebius a b c d" and "c \<noteq> 0" and "ad - bc \<noteq> 0"
	+ assumes "is_pole M z" "z \<in> disc H"
	+ shows "\<not> pos_oriented (moebius_ocircline M H)"
	+proof-
	+ let ?t1 = "moebius_translation (a / c)"
	+ let ?rd = "moebius_rotation_dilatation ((b * c - a * d) / (c * c))"
	+ let ?r = "moebius_reciprocal"
	+ let ?t2 = "moebius_translation (d / c)"
	+
	+ have "0\<^sub>h = moebius_pt (moebius_translation (d/c)) z"
	+ using pole_mk_moebius[of a b c d z] assms
	+ by simp
	+
	+ have "z \<notin> ocircline_set H"
	+ using \<open>z \<in> disc H\<close> disc_inter_ocircline_set[of H]
	+ by blast
	+
	+ hence "0\<^sub>h \<notin> ocircline_set (moebius_ocircline ?t2 H)"
	+ using \<open>0\<^sub>h = moebius_pt ?t2 z\<close>
	+ using moebius_pt_neq_I[of z _ ?t2]
	+ by force
	+
	+ hence *: "\<infinity>\<^sub>h \<notin> ocircline_set (moebius_ocircline (?r + ?t2) H)"
	+ using \<open>0\<^sub>h = moebius_pt (moebius_translation (d / c)) z\<close>
	+ by (metis circline_set_moebius_circline circline_set_moebius_circline_iff circline_set_of_ocircline moebius_pt_comp moebius_reciprocal ocircline_set_moebius_ocircline plus_moebius_def reciprocal_zero)
	+
	+
	+ hence **: "\<infinity>\<^sub>h \<notin> ocircline_set (moebius_ocircline (?rd + ?r + ?t2) H)"
	+ using \<open>ad - bc \<noteq> 0\<close> \<open>c \<noteq> 0\<close>
	+ unfolding moebius_rotation_dilatation_def
	+ using moebius_similarity_oriented_lines_to_oriented_lines[of _ "moebius_ocircline (?r + ?t2) H"]
	+ by (metis divide_eq_0_iff divisors_zero moebius_ocircline_comp plus_moebius_def right_minus_eq)
	+
	+ have "\<not> pos_oriented (moebius_ocircline (?r + ?t2) H)"
	+ using pole_mk_moebius[of a b c d z] assms
	+ using reciprocal_not_preserve_orientation
	+ by force
	+ hence "\<not> pos_oriented (moebius_ocircline (?rd + ?r + ?t2) H)"
	+ using *
	+ using \<open>ad - bc \<noteq> 0\<close> \<open>c \<noteq> 0\<close>
	+ using moebius_similarity_preserve_orientation[of _ "moebius_ocircline (?r + ?t2) H"]
	+ unfolding moebius_rotation_dilatation_def
	+ by simp
	+ hence "\<not> pos_oriented (moebius_ocircline (?t1 + ?rd + ?r + ?t2) H)"
	+ using **
	+ using moebius_similarity_preserve_orientation[of _ "moebius_ocircline (?rd + ?r + ?t2) H"]
	+ unfolding moebius_translation_def
	+ by simp
	+
	+ thus ?thesis
	+ using assms
	+ by simp (subst moebius_decomposition, simp_all)
	+qed
	+
	+lemma pole_in_disc_compl:
	+ assumes "M = mk_moebius a b c d" and "c \<noteq> 0" and "ad - bc \<noteq> 0"
	+ assumes "is_pole M z" and "z \<in> disc_compl H"
	+ shows "pos_oriented (moebius_ocircline M H)"
	+proof-
	+ let ?t1 = "moebius_translation (a / c)"
	+ let ?rd = "moebius_rotation_dilatation ((b * c - a * d) / (c * c))"
	+ let ?r = "moebius_reciprocal"
	+ let ?t2 = "moebius_translation (d / c)"
	+
	+ have "0\<^sub>h = moebius_pt (moebius_translation (d/c)) z"
	+ using pole_mk_moebius[of a b c d z] assms
	+ by simp
	+
	+ have "z \<notin> ocircline_set H"
	+ using \<open>z \<in> disc_compl H\<close> disc_compl_inter_ocircline_set[of H]
	+ by blast
	+ hence "0\<^sub>h \<notin> ocircline_set (moebius_ocircline ?t2 H)"
	+ using \<open>0\<^sub>h = moebius_pt ?t2 z\<close>
	+ using moebius_pt_neq_I[of z _ ?t2]
	+ by force
	+ hence *: "\<infinity>\<^sub>h \<notin> ocircline_set (moebius_ocircline (?r + ?t2) H)"
	+ using \<open>0\<^sub>h = moebius_pt (moebius_translation (d / c)) z\<close>
	+ by (metis circline_set_moebius_circline circline_set_moebius_circline_iff circline_set_of_ocircline moebius_pt_comp moebius_reciprocal ocircline_set_moebius_ocircline plus_moebius_def reciprocal_zero)
	+
	+ hence **: "\<infinity>\<^sub>h \<notin> ocircline_set (moebius_ocircline (?rd + ?r + ?t2) H)"
	+ using \<open>ad - bc \<noteq> 0\<close> \<open>c \<noteq> 0\<close>
	+ unfolding moebius_rotation_dilatation_def
	+ using moebius_similarity_oriented_lines_to_oriented_lines[of _ "moebius_ocircline (?r + ?t2) H"]
	+ by (metis divide_eq_0_iff divisors_zero moebius_ocircline_comp plus_moebius_def right_minus_eq)
	+
	+ have "pos_oriented (moebius_ocircline (?r + ?t2) H)"
	+ using pole_mk_moebius[of a b c d z] assms
	+ using reciprocal_preserve_orientation
	+ by force
	+ hence "pos_oriented (moebius_ocircline (?rd + ?r + ?t2) H)"
	+ using *
	+ using \<open>ad - bc \<noteq> 0\<close> \<open>c \<noteq> 0\<close>
	+ using moebius_similarity_preserve_orientation[of _ "moebius_ocircline (?r + ?t2) H"]
	+ unfolding moebius_rotation_dilatation_def
	+ by simp
	+ hence "pos_oriented (moebius_ocircline (?t1 + ?rd + ?r + ?t2) H)"
	+ using **
	+ using moebius_similarity_preserve_orientation[of _ "moebius_ocircline (?rd + ?r + ?t2) H"]
	+ unfolding moebius_translation_def
	+ by simp
	+
	+ thus ?thesis
	+ using assms
	+ by simp (subst moebius_decomposition, simp_all)
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Oriented circlines uniqueness\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma ocircline_01inf:
	+ assumes "0\<^sub>h \<in> ocircline_set H \<and> 1\<^sub>h \<in> ocircline_set H \<and> \<infinity>\<^sub>h \<in> ocircline_set H"
	+ shows "H = o_x_axis \<or> H = opposite_ocircline o_x_axis"
	+proof-
	+ have "0\<^sub>h \<in> circline_set (of_ocircline H) \<and> 1\<^sub>h \<in> circline_set (of_ocircline H) \<and> \<infinity>\<^sub>h \<in> circline_set (of_ocircline H)"
	+ using assms
	+ by simp
	+ hence "of_ocircline H = x_axis"
	+ using unique_circline_01inf'
	+ by auto
	+ thus "H = o_x_axis \<or> H = opposite_ocircline o_x_axis"
	+ by (metis inj_of_ocircline of_ocircline_o_x_axis)
	+qed
	+
	+lemma unique_ocircline_01inf:
	+ shows "\<exists>! H. 0\<^sub>h \<in> ocircline_set H \<and> 1\<^sub>h \<in> ocircline_set H \<and> \<infinity>\<^sub>h \<in> ocircline_set H \<and> ii\<^sub>h \<notin> disc H"
	+proof
	+ show "0\<^sub>h \<in> ocircline_set o_x_axis \<and> 1\<^sub>h \<in> ocircline_set o_x_axis \<and> \<infinity>\<^sub>h \<in> ocircline_set o_x_axis \<and> ii\<^sub>h \<notin> disc o_x_axis"
	+ by simp
	+next
	+ fix H
	+ assume "0\<^sub>h \<in> ocircline_set H \<and> 1\<^sub>h \<in> ocircline_set H \<and> \<infinity>\<^sub>h \<in> ocircline_set H \<and> ii\<^sub>h \<notin> disc H"
	+ hence "0\<^sub>h \<in> ocircline_set H \<and> 1\<^sub>h \<in> ocircline_set H \<and> \<infinity>\<^sub>h \<in> ocircline_set H" "ii\<^sub>h \<notin> disc H"
	+ by auto
	+ hence "H = o_x_axis \<or> H = opposite_ocircline o_x_axis"
	+ using ocircline_01inf
	+ by simp
	+ thus "H = o_x_axis"
	+ using \<open>ii\<^sub>h \<notin> disc H\<close>
	+ by auto
	+qed
	+
	+lemma unique_ocircline_set:
	+ assumes "A \<noteq> B" and "A \<noteq> C" and "B \<noteq> C"
	+ shows "\<exists>! H. pos_oriented H \<and> (A \<in> ocircline_set H \<and> B \<in> ocircline_set H \<and> C \<in> ocircline_set H)"
	+proof-
	+ obtain M where *: "moebius_pt M A = 0\<^sub>h" "moebius_pt M B = 1\<^sub>h" "moebius_pt M C = \<infinity>\<^sub>h"
	+ using ex_moebius_01inf[OF assms]
	+ by auto
	+ let ?iM = "moebius_pt (moebius_inv M)"
	+ have **: "?iM 0\<^sub>h = A" "?iM 1\<^sub>h = B" "?iM \<infinity>\<^sub>h = C"
	+ using *
	+ by (auto simp add: moebius_pt_invert)
	+ let ?H = "moebius_ocircline (moebius_inv M) o_x_axis"
	+ have 1: "A \<in> ocircline_set ?H" "B \<in> ocircline_set ?H" "C \<in> ocircline_set ?H"
	+ using **
	+ by auto
	+ have 2: "\<And> H'. A \<in> ocircline_set H' \<and> B \<in> ocircline_set H' \<and> C \<in> ocircline_set H' \<Longrightarrow> H' = ?H \<or> H' = opposite_ocircline ?H"
	+ proof-
	+ fix H'
	+ let ?H' = "ocircline_set H'" and ?H'' = "ocircline_set (moebius_ocircline M H')"
	+ assume "A \<in> ocircline_set H' \<and> B \<in> ocircline_set H' \<and> C \<in> ocircline_set H'"
	+ hence "moebius_pt M A \<in> ?H''" "moebius_pt M B \<in> ?H''" "moebius_pt M C \<in> ?H''"
	+ by auto
	+ hence "0\<^sub>h \<in> ?H''" "1\<^sub>h \<in> ?H''" "\<infinity>\<^sub>h \<in> ?H''"
	+ using *
	+ by auto
	+ hence "moebius_ocircline M H' = o_x_axis \<or> moebius_ocircline M H' = opposite_ocircline o_x_axis"
	+ using ocircline_01inf
	+ by auto
	+ hence "o_x_axis = moebius_ocircline M H' \<or> o_x_axis = opposite_ocircline (moebius_ocircline M H')"
	+ by auto
	+ thus "H' = ?H \<or> H' = opposite_ocircline ?H"
	+ proof
	+ assume *: "o_x_axis = moebius_ocircline M H'"
	+ show "H' = moebius_ocircline (moebius_inv M) o_x_axis \<or> H' = opposite_ocircline (moebius_ocircline (moebius_inv M) o_x_axis)"
	+ by (rule disjI1) (subst *, simp)
	+ next
	+ assume *: "o_x_axis = opposite_ocircline (moebius_ocircline M H')"
	+ show "H' = moebius_ocircline (moebius_inv M) o_x_axis \<or> H' = opposite_ocircline (moebius_ocircline (moebius_inv M) o_x_axis)"
	+ by (rule disjI2) (subst *, simp)
	+ qed
	+ qed
	+
	+ show ?thesis (is "\<exists>! x. ?P x")
	+ proof (cases "pos_oriented ?H")
	+ case True
	+ show ?thesis
	+ proof
	+ show "?P ?H"
	+ using 1 True
	+ by auto
	+ next
	+ fix H
	+ assume "?P H"
	+ thus "H = ?H"
	+ using 1 2[of H] True
	+ by auto
	+ qed
	+ next
	+ case False
	+ let ?OH = "opposite_ocircline ?H"
	+ show ?thesis
	+ proof
	+ show "?P ?OH"
	+ using 1 False
	+ by auto
	+ next
	+ fix H
	+ assume "?P H"
	+ thus "H = ?OH"
	+ using False 2[of H]
	+ by auto
	+ qed
	+ qed
	+qed
	+
	+lemma ocircline_set_0h:
	+ assumes "ocircline_set H = {0\<^sub>h}"
	+ shows "H = o_circline_point_0 \<or> H = opposite_ocircline (o_circline_point_0)"
	+proof-
	+ have "of_ocircline H = circline_point_0"
	+ using assms
	+ using unique_circline_type_zero_0' card_eq1_circline_type_zero[of "of_ocircline H"]
	+ by auto
	+ thus ?thesis
	+ by (metis inj_of_ocircline of_ocircline_o_circline_point_0)
	+qed
	+
	+
	+end
	diff --git a/thys/Complex_Geometry/Quadratic.thy b/thys/Complex_Geometry/Quadratic.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Quadratic.thy
	@@ -0,0 +1,477 @@
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Quadratic equations\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>In this section some simple properties of quadratic equations and their roots are derived.
	+Quadratic equations over reals and over complex numbers, but also systems of quadratic equations and
	+systems of quadratic and linear equations are analysed.\<close>
	+
	+theory Quadratic
	+ imports More_Complex "HOL-Library.Quadratic_Discriminant"
	+begin
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Real quadratic equations, Viette rules\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma viette2_monic:
	+ fixes b c \<xi>1 \<xi>2 :: real
	+ assumes "b\<^sup>2 - 4c \<ge> 0" and "\<xi>1\<^sup>2 + b\<xi>1 + c = 0" and "\<xi>2\<^sup>2 + b*\<xi>2 + c = 0" and "\<xi>1 \<noteq> \<xi>2"
	+ shows "\<xi>1*\<xi>2 = c"
	+ using assms
	+ by algebra
	+
	+lemma viette2:
	+ fixes a b c \<xi>1 \<xi>2 :: real
	+ assumes "a \<noteq> 0" and "b\<^sup>2 - 4ac \<ge> 0" and "a\<xi>1\<^sup>2 + b\<xi>1 + c = 0" and "a\<xi>2\<^sup>2 + b\<xi>2 + c = 0" and "\<xi>1 \<noteq> \<xi>2"
	+ shows "\<xi>1*\<xi>2 = c/a"
	+proof (rule viette2_monic[of "b/a" "c/a" \<xi>1 \<xi>2])
	+ have "(b / a)\<^sup>2 - 4 * (c / a) = (b\<^sup>2 - 4ac) / a\<^sup>2"
	+ using \<open>a \<noteq> 0\<close>
	+ by (auto simp add: power2_eq_square field_simps)
	+ thus "0 \<le> (b / a)\<^sup>2 - 4 * (c / a)"
	+ using \<open>b\<^sup>2 - 4ac \<ge> 0\<close>
	+ by simp
	+next
	+ show "\<xi>1\<^sup>2 + b / a * \<xi>1 + c / a = 0" "\<xi>2\<^sup>2 + b / a * \<xi>2 + c / a = 0"
	+ using assms
	+ by (auto simp add: power2_eq_square field_simps)
	+next
	+ show "\<xi>1 \<noteq> \<xi>2"
	+ by fact
	+qed
	+
	+lemma viette2'_monic:
	+ fixes b c \<xi> :: real
	+ assumes "b\<^sup>2 - 4c = 0" and "\<xi>\<^sup>2 + b\<xi> + c = 0"
	+ shows "\<xi>*\<xi> = c"
	+ using assms
	+ by algebra
	+
	+lemma viette2':
	+ fixes a b c \<xi> :: real
	+ assumes "a \<noteq> 0" and "b\<^sup>2 - 4ac = 0" and "a\<xi>\<^sup>2 + b\<xi> + c = 0"
	+ shows "\<xi>*\<xi> = c/a"
	+proof (rule viette2'_monic)
	+ have "(b / a)\<^sup>2 - 4 * (c / a) = (b\<^sup>2 - 4ac) / a\<^sup>2"
	+ using \<open>a \<noteq> 0\<close>
	+ by (auto simp add: power2_eq_square field_simps)
	+ thus "(b / a)\<^sup>2 - 4 * (c / a) = 0"
	+ using \<open>b\<^sup>2 - 4ac = 0\<close>
	+ by simp
	+next
	+ show "\<xi>\<^sup>2 + b / a * \<xi> + c / a = 0"
	+ using assms
	+ by (auto simp add: power2_eq_square field_simps)
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Complex quadratic equations\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+lemma complex_quadratic_equation_monic_only_two_roots:
	+ fixes \<xi> :: complex
	+ assumes "\<xi>\<^sup>2 + b * \<xi> + c = 0"
	+ shows "\<xi> = (-b + ccsqrt(b\<^sup>2 - 4c)) / 2 \<or> \<xi> = (-b - ccsqrt(b\<^sup>2 - 4c)) / 2"
	+using assms
	+proof-
	+ from assms have "(2 * (\<xi> + b/2))\<^sup>2 = b\<^sup>2 - 4*c"
	+ by (simp add: power2_eq_square field_simps)
	+ (metis (no_types, lifting) distrib_right_numeral mult.assoc mult_zero_left)
	+ hence "2 * (\<xi> + b/2) = ccsqrt (b\<^sup>2 - 4c) \<or> 2 (\<xi> + b/2) = - ccsqrt (b\<^sup>2 - 4*c)"
	+ using ccsqrt[of "(2 * (\<xi> + b / 2))" "b\<^sup>2 - 4 * c"]
	+ by (simp add: power2_eq_square)
	+ thus ?thesis
	+ using mult_cancel_right[of "b + \<xi> * 2" 2 "ccsqrt (b\<^sup>2 - 4*c)"]
	+ using mult_cancel_right[of "b + \<xi> * 2" 2 "-ccsqrt (b\<^sup>2 - 4*c)"]
	+ by (auto simp add: field_simps) (metis add_diff_cancel diff_minus_eq_add minus_diff_eq)
	+qed
	+
	+lemma complex_quadratic_equation_monic_roots:
	+ fixes \<xi> :: complex
	+ assumes "\<xi> = (-b + ccsqrt(b\<^sup>2 - 4*c)) / 2 \<or>
	+ \<xi> = (-b - ccsqrt(b\<^sup>2 - 4*c)) / 2"
	+ shows "\<xi>\<^sup>2 + b * \<xi> + c = 0"
	+using assms
	+proof
	+ assume : "\<xi> = (- b + ccsqrt (b\<^sup>2 - 4 c)) / 2"
	+ show ?thesis
	+ by ((subst *)+) (subst power_divide, subst power2_sum, simp add: field_simps, simp add: power2_eq_square)
	+next
	+ assume : "\<xi> = (- b - ccsqrt (b\<^sup>2 - 4 c)) / 2"
	+ show ?thesis
	+ by ((subst *)+, subst power_divide, subst power2_diff, simp add: field_simps, simp add: power2_eq_square)
	+qed
	+
	+lemma complex_quadratic_equation_monic_distinct_roots:
	+ fixes b c :: complex
	+ assumes "b\<^sup>2 - 4*c \<noteq> 0"
	+ shows "\<exists> k\<^sub>1 k\<^sub>2. k\<^sub>1 \<noteq> k\<^sub>2 \<and> k\<^sub>1\<^sup>2 + bk\<^sub>1 + c = 0 \<and> k\<^sub>2\<^sup>2 + bk\<^sub>2 + c = 0"
	+proof-
	+ let ?\<xi>1 = "(-b + ccsqrt(b\<^sup>2 - 4*c)) / 2"
	+ let ?\<xi>2 = "(-b - ccsqrt(b\<^sup>2 - 4*c)) / 2"
	+ show ?thesis
	+ apply (rule_tac x="?\<xi>1" in exI)
	+ apply (rule_tac x="?\<xi>2" in exI)
	+ using assms
	+ using complex_quadratic_equation_monic_roots[of ?\<xi>1 b c]
	+ using complex_quadratic_equation_monic_roots[of ?\<xi>2 b c]
	+ by simp
	+qed
	+
	+lemma complex_quadratic_equation_two_roots:
	+ fixes \<xi> :: complex
	+ assumes "a \<noteq> 0" and "a\<xi>\<^sup>2 + b \<xi> + c = 0"
	+ shows "\<xi> = (-b + ccsqrt(b\<^sup>2 - 4ac)) / (2*a) \<or>
	+ \<xi> = (-b - ccsqrt(b\<^sup>2 - 4ac)) / (2*a)"
	+proof-
	+ from assms have "\<xi>\<^sup>2 + (b/a) * \<xi> + (c/a) = 0"
	+ by (simp add: field_simps)
	+ hence "\<xi> = (-(b/a) + ccsqrt((b/a)\<^sup>2 - 4(c/a))) / 2 \<or> \<xi> = (-(b/a) - ccsqrt((b/a)\<^sup>2 - 4(c/a))) / 2"
	+ using complex_quadratic_equation_monic_only_two_roots[of \<xi> "b/a" "c/a"]
	+ by simp
	+ hence "\<exists> k. \<xi> = (-(b/a) + (-1)^k * ccsqrt((b/a)\<^sup>2 - 4*(c/a))) / 2"
	+ by safe (rule_tac x="2" in exI, simp, rule_tac x="1" in exI, simp)
	+ then obtain k1 where "\<xi> = (-(b/a) + (-1)^k1 * ccsqrt((b/a)\<^sup>2 - 4*(c/a))) / 2"
	+ by auto
	+ moreover
	+ have "(b / a)\<^sup>2 - 4 * (c / a) = (b\<^sup>2 - 4 * a * c) * (1 / a\<^sup>2)"
	+ using \<open>a \<noteq> 0\<close>
	+ by (simp add: field_simps power2_eq_square)
	+ hence "ccsqrt ((b / a)\<^sup>2 - 4 * (c / a)) = ccsqrt (b\<^sup>2 - 4 * a * c) * ccsqrt (1/a\<^sup>2) \<or>
	+ ccsqrt ((b / a)\<^sup>2 - 4 * (c / a)) = - ccsqrt (b\<^sup>2 - 4 * a * c) * ccsqrt (1/a\<^sup>2)"
	+ using ccsqrt_mult[of "b\<^sup>2 - 4 * a * c" "1/a\<^sup>2"]
	+ by auto
	+ hence "\<exists> k. ccsqrt ((b / a)\<^sup>2 - 4 * (c / a)) = (-1)^k * ccsqrt (b\<^sup>2 - 4 * a * c) * ccsqrt (1 / a\<^sup>2)"
	+ by safe (rule_tac x="2" in exI, simp, rule_tac x="1" in exI, simp)
	+ then obtain k2 where "ccsqrt ((b / a)\<^sup>2 - 4 * (c / a)) = (-1)^k2 * ccsqrt (b\<^sup>2 - 4 * a * c) * ccsqrt (1 / a\<^sup>2)"
	+ by auto
	+ moreover
	+ have "ccsqrt (1 / a\<^sup>2) = 1/a \<or> ccsqrt (1 / a\<^sup>2) = -1/a"
	+ using ccsqrt[of "1/a" "1 / a\<^sup>2"]
	+ by (auto simp add: power2_eq_square)
	+ hence "\<exists> k. ccsqrt (1 / a\<^sup>2) = (-1)^k * 1/a"
	+ by safe (rule_tac x="2" in exI, simp, rule_tac x="1" in exI, simp)
	+ then obtain k3 where "ccsqrt (1 / a\<^sup>2) = (-1)^k3 * 1/a"
	+ by auto
	+ ultimately
	+ have "\<xi> = (- (b / a) + ((-1) ^ k1 * (-1) ^ k2 * (-1) ^ k3) * ccsqrt (b\<^sup>2 - 4 * a * c) * 1/a) / 2"
	+ by simp
	+ moreover
	+ have "(-(1::complex)) ^ k1 * (-1) ^ k2 * (-1) ^ k3 = 1 \<or> (-(1::complex)) ^ k1 * (-1) ^ k2 * (-1) ^ k3 = -1"
	+ using neg_one_even_power[of "k1 + k2 + k3"]
	+ using neg_one_odd_power[of "k1 + k2 + k3"]
	+ by (smt power_add)
	+ ultimately
	+ have "\<xi> = (- (b / a) + ccsqrt (b\<^sup>2 - 4 * a * c) * 1 / a) / 2 \<or> \<xi> = (- (b / a) - ccsqrt (b\<^sup>2 - 4 * a * c) * 1 / a) / 2"
	+ by auto
	+ thus ?thesis
	+ using \<open>a \<noteq> 0\<close>
	+ by (simp add: field_simps)
	+qed
	+
	+lemma complex_quadratic_equation_only_two_roots:
	+ fixes x :: complex
	+ assumes "a \<noteq> 0"
	+ assumes "qf = (\<lambda> x. ax\<^sup>2 + bx + c)"
	+ "qf x1 = 0" and "qf x2 = 0" and "x1 \<noteq> x2"
	+ "qf x = 0"
	+ shows "x = x1 \<or> x = x2"
	+ using assms
	+ using complex_quadratic_equation_two_roots
	+ by blast
	+
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Intersections of linear and quadratic forms\<close>
	+(* ----------------------------------------------------------------- *)
	+(* These lemmas are not used *)
	+
	+lemma quadratic_linear_at_most_2_intersections_help:
	+ fixes x y :: complex
	+ assumes "(a11, a12, a22) \<noteq> (0, 0, 0)" and "k2 \<noteq> 0"
	+ "qf = (\<lambda> x y. a11x\<^sup>2 + 2a12xy + a22y\<^sup>2 + b1x + b2y + c)" and "lf = (\<lambda> x y. k1x + k2*y + n)"
	+ "qf x y = 0" and "lf x y = 0"
	+ "pf = (\<lambda> x. (a11 - 2a12k1/k2 + a22k1\<^sup>2/k2\<^sup>2)x\<^sup>2 + (-2a12n/k2 + b1 + a222nk1/k2\<^sup>2 - b2k1/k2)x + a22n\<^sup>2/k2\<^sup>2 - b2*n/k2 + c)"
	+ "yf = (\<lambda> x. (-n - k1*x) / k2)"
	+ shows "pf x = 0" and "y = yf x"
	+proof -
	+ show "y = yf x"
	+ using assms
	+ by (simp add:field_simps eq_neg_iff_add_eq_0)
	+next
	+ have "2a12x(-n - k1x)/k2 = (-2a12n/k2)x - (2a12k1/k2)x\<^sup>2"
	+ by algebra
	+ have "a22((-n - k1x)/k2)\<^sup>2 = a22n\<^sup>2/k2\<^sup>2 + (a222nk1/k2\<^sup>2)x + (a22k1\<^sup>2/k2\<^sup>2)*x\<^sup>2"
	+ by (simp add: power_divide) algebra
	+ have "2a12x(-n - k1x)/k2 = (-2a12n/k2)x - (2a12k1/k2)x\<^sup>2"
	+ by algebra
	+ have "b2(-n - k1x)/k2 = -b2n/k2 - (b2k1/k2)*x"
	+ by algebra
	+
	+ have : "y = (-n - k1x)/k2"
	+ using assms(2, 4, 6)
	+ by (simp add:field_simps eq_neg_iff_add_eq_0)
	+
	+ have "0 = a11x\<^sup>2 + 2a12xy + a22y\<^sup>2 + b1x + b2*y + c"
	+ using assms
	+ by simp
	+ hence "0 = a11x\<^sup>2 + 2a12x(-n - k1x)/k2 + a22((-n - k1x)/k2)\<^sup>2 + b1x + b2(-n - k1x)/k2 + c"
	+ by (subst (asm) , subst (asm) , subst (asm) *) auto
	+ also have "... = (a11 - 2a12k1/k2 + a22k1\<^sup>2/k2\<^sup>2)x\<^sup>2 + (-2a12n/k2 + b1 + a222nk1/k2\<^sup>2 - b2k1/k2)x + a22n\<^sup>2/k2\<^sup>2 -b2*n/k2 + c"
	+ using \<open>2a12x(-n - k1x)/k2 = (-2a12n/k2)x - (2a12k1/k2)x\<^sup>2\<close>
	+ using \<open>a22((-n - k1x)/k2)\<^sup>2 = a22n\<^sup>2/k2\<^sup>2 + (a222nk1/k2\<^sup>2)x + (a22k1\<^sup>2/k2\<^sup>2)*x\<^sup>2\<close>
	+ using \<open>b2(-n - k1x)/k2 = -b2n/k2 - (b2k1/k2)*x\<close>
	+ by (simp add:field_simps)
	+ finally show "pf x = 0"
	+ using assms(7)
	+ by auto
	+qed
	+
	+lemma quadratic_linear_at_most_2_intersections_help':
	+ fixes x y :: complex
	+ assumes "qf = (\<lambda> x y. a11x\<^sup>2 + 2a12xy + a22y\<^sup>2 + b1x + b2*y + c)"
	+ "x = -n/k1" and "k1 \<noteq> 0" and "qf x y = 0"
	+ "yf = (\<lambda> y. k1\<^sup>2a22y\<^sup>2 + (-2a12nk1 + b2k1\<^sup>2)y + a11n\<^sup>2 - b1nk1 + c*k1\<^sup>2)"
	+ shows "yf y = 0"
	+proof-
	+ have "0 = a11n\<^sup>2/k1\<^sup>2 - 2a12ny/k1 + a22y\<^sup>2 - b1n/k1 + b2*y + c"
	+ using assms(1, 2, 4)
	+ by (simp add: power_divide)
	+ hence "0 = a11n\<^sup>2 - 2a12nk1y + a22y\<^sup>2k1\<^sup>2 - b1nk1 + b2yk1\<^sup>2 + ck1\<^sup>2"
	+ using assms(3)
	+ apply (simp add:field_simps power2_eq_square)
	+ by algebra
	+ thus ?thesis
	+ using assms(1, 4, 5)
	+ by (simp add:field_simps)
	+qed
	+
	+lemma quadratic_linear_at_most_2_intersections:
	+ fixes x y x1 y1 x2 y2 :: complex
	+ assumes "(a11, a12, a22) \<noteq> (0, 0, 0)" and "(k1, k2) \<noteq> (0, 0)"
	+ assumes "a11k2\<^sup>2 - 2a12k1k2 + a22*k1\<^sup>2 \<noteq> 0"
	+ assumes "qf = (\<lambda> x y. a11x\<^sup>2 + 2a12xy + a22y\<^sup>2 + b1x + b2y + c)" and "lf = (\<lambda> x y. k1x + k2*y + n)"
	+ "qf x1 y1 = 0" and "lf x1 y1 = 0"
	+ "qf x2 y2 = 0" and "lf x2 y2 = 0"
	+ "(x1, y1) \<noteq> (x2, y2)"
	+ "qf x y = 0" and "lf x y = 0"
	+ shows "(x, y) = (x1, y1) \<or> (x, y) = (x2, y2)"
	+proof(cases "k2 = 0")
	+ case True
	+ hence "k1 \<noteq> 0"
	+ using assms(2)
	+ by simp
	+
	+ have "a22*k1\<^sup>2 \<noteq> 0"
	+ using assms(3) True
	+ by auto
	+
	+ have "x1 = -n/k1"
	+ using \<open>k1 \<noteq> 0\<close> assms(5, 7) True
	+ by (metis add.right_neutral add_eq_0_iff2 mult_zero_left nonzero_mult_div_cancel_left)
	+ have "x2 = -n/k1"
	+ using \<open>k1 \<noteq> 0\<close> assms(5, 9) True
	+ by (metis add.right_neutral add_eq_0_iff2 mult_zero_left nonzero_mult_div_cancel_left)
	+ have "x = -n/k1"
	+ using \<open>k1 \<noteq> 0\<close> assms(5, 12) True
	+ by (metis add.right_neutral add_eq_0_iff2 mult_zero_left nonzero_mult_div_cancel_left)
	+
	+ let ?yf = "(\<lambda> y. k1\<^sup>2a22y\<^sup>2 + (-2a12nk1 + b2k1\<^sup>2)y + a11n\<^sup>2 - b1nk1 + c*k1\<^sup>2)"
	+
	+ have "?yf y = 0"
	+ using quadratic_linear_at_most_2_intersections_help'[of qf a11 a12 a22 b1 b2 c x n k1 y ?yf]
	+ using assms(4, 11) \<open>k1 \<noteq> 0\<close> \<open>x = -n/k1\<close>
	+ by auto
	+ have "?yf y1 = 0"
	+ using quadratic_linear_at_most_2_intersections_help'[of qf a11 a12 a22 b1 b2 c x1 n k1 y1 ?yf]
	+ using assms(4, 6) \<open>k1 \<noteq> 0\<close> \<open>x1 = -n/k1\<close>
	+ by auto
	+ have "?yf y2 = 0"
	+ using quadratic_linear_at_most_2_intersections_help'[of qf a11 a12 a22 b1 b2 c x2 n k1 y2 ?yf]
	+ using assms(4, 8) \<open>k1 \<noteq> 0\<close> \<open>x2 = -n/k1\<close>
	+ by auto
	+
	+ have "y1 \<noteq> y2"
	+ using assms(10) \<open>x1 = -n/k1\<close> \<open>x2 = -n/k1\<close>
	+ by blast
	+
	+ have "y = y1 \<or> y = y2"
	+ using complex_quadratic_equation_only_two_roots[of "a22k1\<^sup>2" ?yf "-2a12nk1 + b2k1\<^sup>2" "a11n\<^sup>2 - b1nk1 + c*k1\<^sup>2"
	+ y1 y2 y]
	+ using \<open>a22*k1\<^sup>2 \<noteq> 0\<close> \<open>?yf y1 = 0\<close> \<open>y1 \<noteq> y2\<close> \<open>?yf y2 = 0\<close> \<open>?yf y = 0\<close>
	+ by fastforce
	+
	+ thus ?thesis
	+ using \<open>x1 = -n/k1\<close> \<open>x2 = -n/k1\<close> \<open>x = -n/k1\<close>
	+ by auto
	+next
	+ case False
	+
	+ let ?py = "(\<lambda> x. (-n - k1*x)/k2)"
	+ let ?pf = "(\<lambda> x. (a11 - 2a12k1/k2 + a22k1\<^sup>2/k2\<^sup>2)x\<^sup>2 + (-2a12n/k2 + b1 + a222nk1/k2\<^sup>2 - b2k1/k2)x + a22n\<^sup>2/k2\<^sup>2 -b2*n/k2 + c)"
	+ have "?pf x1 = 0" "y1 = ?py x1"
	+ using quadratic_linear_at_most_2_intersections_help[of a11 a12 a22 k2 qf b1 b2 c lf k1 n x1 y1]
	+ using assms(1, 4, 5, 6, 7) False
	+ by auto
	+ have "?pf x2 = 0" "y2 = ?py x2"
	+ using quadratic_linear_at_most_2_intersections_help[of a11 a12 a22 k2 qf b1 b2 c lf k1 n x2 y2]
	+ using assms(1, 4, 5, 8, 9) False
	+ by auto
	+ have "?pf x = 0" "y = ?py x"
	+ using quadratic_linear_at_most_2_intersections_help[of a11 a12 a22 k2 qf b1 b2 c lf k1 n x y]
	+ using assms(1, 4, 5, 11, 12) False
	+ by auto
	+
	+ have "x1 \<noteq> x2"
	+ using assms(10) \<open>y1 = ?py x1\<close> \<open>y2 = ?py x2\<close>
	+ by auto
	+
	+ have "a11 - 2a12k1/k2 + a22k1\<^sup>2/k2\<^sup>2 = (a11 k2\<^sup>2 - 2 * a12 * k1 * k2 + a22 * k1\<^sup>2)/k2\<^sup>2"
	+ by (simp add: False power2_eq_square add_divide_distrib diff_divide_distrib)
	+ also have "... \<noteq> 0"
	+ using False assms(3)
	+ by simp
	+ finally have "a11 - 2a12k1/k2 + a22*k1\<^sup>2/k2\<^sup>2 \<noteq> 0"
	+ .
	+
	+ have "x = x1 \<or> x = x2"
	+ using complex_quadratic_equation_only_two_roots[of "a11 - 2a12k1/k2 + a22*k1\<^sup>2/k2\<^sup>2" ?pf
	+ "(- 2 * a12 * n / k2 + b1 + a22 * 2 * n * k1 / k2\<^sup>2 - b2 * k1 / k2)"
	+ "a22 * n\<^sup>2 / k2\<^sup>2 - b2 * n / k2 + c" x1 x2 x]
	+ using \<open>?pf x2 = 0\<close> \<open>?pf x1 = 0\<close> \<open>?pf x = 0\<close>
	+ using \<open>a11 - 2 * a12 * k1 / k2 + a22 * k1\<^sup>2 / k2\<^sup>2 \<noteq> 0\<close>
	+ using \<open>x1 \<noteq> x2\<close>
	+ by fastforce
	+
	+ thus ?thesis
	+ using \<open>y = ?py x\<close> \<open>y1 = ?py x1\<close> \<open>y2 = ?py x2\<close>
	+ by (cases "x = x1", auto)
	+qed
	+
	+lemma quadratic_quadratic_at_most_2_intersections':
	+ fixes x y x1 y1 x2 y2 :: complex
	+ assumes "b2 \<noteq> B2 \<or> b1 \<noteq> B1"
	+ "(b2 - B2)\<^sup>2 + (b1 - B1)\<^sup>2 \<noteq> 0"
	+ assumes "qf1 = (\<lambda> x y. x\<^sup>2 + y\<^sup>2 + b1x + b2y + c)"
	+ "qf2 = (\<lambda> x y. x\<^sup>2 + y\<^sup>2 + B1x + B2y + C)"
	+ "qf1 x1 y1 = 0" "qf2 x1 y1 = 0"
	+ "qf1 x2 y2 = 0" "qf2 x2 y2 = 0"
	+ "(x1, y1) \<noteq> (x2, y2)"
	+ "qf1 x y = 0" "qf2 x y = 0"
	+ shows "(x, y) = (x1, y1) \<or> (x, y) = (x2, y2)"
	+proof-
	+ have "x\<^sup>2 + y\<^sup>2 + b1x + b2y + c = 0"
	+ using assms by auto
	+ have "x\<^sup>2 + y\<^sup>2 + B1x + B2y + C = 0"
	+ using assms by auto
	+ hence "0 = x\<^sup>2 + y\<^sup>2 + b1x + b2y + c - (x\<^sup>2 + y\<^sup>2 + B1x + B2y + C)"
	+ using \<open>x\<^sup>2 + y\<^sup>2 + b1x + b2y + c = 0\<close>
	+ by auto
	+ hence "0 = (b1 - B1)x + (b2 - B2)y + c - C"
	+ by (simp add:field_simps)
	+
	+ have "x1\<^sup>2 + y1\<^sup>2 + b1x1 + b2y1 + c = 0"
	+ using assms by auto
	+ have "x1\<^sup>2 + y1\<^sup>2 + B1x1 + B2y1 + C = 0"
	+ using assms by auto
	+ hence "0 = x1\<^sup>2 + y1\<^sup>2 + b1x1 + b2y1 + c - (x1\<^sup>2 + y1\<^sup>2 + B1x1 + B2y1 + C)"
	+ using \<open>x1\<^sup>2 + y1\<^sup>2 + b1x1 + b2y1 + c = 0\<close>
	+ by auto
	+ hence "0 = (b1 - B1)x1 + (b2 - B2)y1 + c - C"
	+ by (simp add:field_simps)
	+
	+ have "x2\<^sup>2 + y2\<^sup>2 + b1x2 + b2y2 + c = 0"
	+ using assms by auto
	+ have "x2\<^sup>2 + y2\<^sup>2 + B1x2 + B2y2 + C = 0"
	+ using assms by auto
	+ hence "0 = x2\<^sup>2 + y2\<^sup>2 + b1x2 + b2y2 + c - (x2\<^sup>2 + y2\<^sup>2 + B1x2 + B2y2 + C)"
	+ using \<open>x2\<^sup>2 + y2\<^sup>2 + b1x2 + b2y2 + c = 0\<close>
	+ by auto
	+ hence "0 = (b1 - B1)x2 + (b2 - B2)y2 + c - C"
	+ by (simp add:field_simps)
	+
	+ have "(b1 - B1, b2 - B2) \<noteq> (0, 0)"
	+ using assms(1) by auto
	+
	+ let ?lf = "(\<lambda> x y. (b1 - B1)x + (b2 - B2)y + c - C)"
	+
	+ have "?lf x y = 0" "?lf x1 y1 = 0" "?lf x2 y2 = 0"
	+ using \<open>0 = (b1 - B1)x2 + (b2 - B2)y2 + c - C\<close>
	+ \<open>0 = (b1 - B1)x1 + (b2 - B2)y1 + c - C\<close>
	+ \<open>0 = (b1 - B1)x + (b2 - B2)y + c - C\<close>
	+ by auto
	+
	+ thus ?thesis
	+ using quadratic_linear_at_most_2_intersections[of 1 0 1 "b1 - B1" "b2 - B2" qf1 b1 b2 c ?lf "c - C" x1 y1 x2 y2 x y]
	+ using \<open>(b1 - B1, b2 - B2) \<noteq> (0, 0)\<close>
	+ using assms \<open>(b1 - B1, b2 - B2) \<noteq> (0, 0)\<close>
	+ using \<open>(b1 - B1) * x + (b2 - B2) * y + c - C = 0\<close> \<open>(b1 - B1) * x1 + (b2 - B2) * y1 + c - C = 0\<close>
	+ by (simp add: add_diff_eq)
	+qed
	+
	+lemma quadratic_change_coefficients:
	+ fixes x y :: complex
	+ assumes "A1 \<noteq> 0"
	+ assumes "qf = (\<lambda> x y. A1x\<^sup>2 + A1y\<^sup>2 + b1x + b2y + c)"
	+ "qf x y = 0"
	+ "qf_1 = (\<lambda> x y. x\<^sup>2 + y\<^sup>2 + (b1/A1)x + (b2/A1)y + c/A1)"
	+ shows "qf_1 x y = 0"
	+proof-
	+ have "0 = A1x\<^sup>2 + A1y\<^sup>2 + b1x + b2y + c"
	+ using assms by auto
	+ hence "0/A1 = (A1x\<^sup>2 + A1y\<^sup>2 + b1x + b2y + c)/A1"
	+ using assms(1) by auto
	+ also have "... = A1x\<^sup>2/A1 + A1y\<^sup>2/A1 + b1x/A1 + b2y/A1 + c/A1"
	+ by (simp add: add_divide_distrib)
	+ also have "... = x\<^sup>2 + y\<^sup>2 + (b1/A1)x + (b2/A1)y + c/A1"
	+ using assms(1)
	+ by (simp add:field_simps)
	+ finally have "0 = x\<^sup>2 + y\<^sup>2 + (b1/A1)x + (b2/A1)y + c/A1"
	+ by simp
	+ thus ?thesis
	+ using assms
	+ by simp
	+qed
	+
	+lemma quadratic_quadratic_at_most_2_intersections:
	+ fixes x y x1 y1 x2 y2 :: complex
	+ assumes "A1 \<noteq> 0" and "A2 \<noteq> 0"
	+ assumes "qf1 = (\<lambda> x y. A1x\<^sup>2 + A1y\<^sup>2 + b1x + b2y + c)" and
	+ "qf2 = (\<lambda> x y. A2x\<^sup>2 + A2y\<^sup>2 + B1x + B2y + C)" and
	+ "qf1 x1 y1 = 0" and "qf2 x1 y1 = 0" and
	+ "qf1 x2 y2 = 0" and "qf2 x2 y2 = 0" and
	+ "(x1, y1) \<noteq> (x2, y2)" and
	+ "qf1 x y = 0" and "qf2 x y = 0"
	+ assumes "(b2A2 - B2A1)\<^sup>2 + (b1A2 - B1A1)\<^sup>2 \<noteq> 0" and
	+ "b2A2 \<noteq> B2A1 \<or> b1A2 \<noteq> B1A1"
	+ shows "(x, y) = (x1, y1) \<or> (x, y) = (x2, y2)"
	+proof-
	+ have *: "b2 / A1 \<noteq> B2 / A2 \<or> b1 / A1 \<noteq> B1 / A2"
	+ using assms(1, 2) assms(13)
	+ by (simp add:field_simps)
	+ have **: "(b2 / A1 - B2 / A2)\<^sup>2 + (b1 / A1 - B1 / A2)\<^sup>2 \<noteq> 0"
	+ using assms(1, 2) assms(12)
	+ by (simp add:field_simps)
	+
	+ let ?qf_1 = "(\<lambda> x y. x\<^sup>2 + y\<^sup>2 + (b1/A1)x + (b2/A1)y + c/A1)"
	+ let ?qf_2 = "(\<lambda> x y. x\<^sup>2 + y\<^sup>2 + (B1/A2)x + (B2/A2)y + C/A2)"
	+
	+ have "?qf_1 x1 y1 = 0" "?qf_1 x2 y2 = 0" "?qf_1 x y = 0"
	+ "?qf_2 x1 y1 = 0" "?qf_2 x2 y2 = 0" "?qf_2 x y = 0"
	+ using assms quadratic_change_coefficients[of A1 qf1 b1 b2 c x2 y2 ?qf_1]
	+ quadratic_change_coefficients[of A1 qf1 b1 b2 c x1 y1 ?qf_1]
	+ quadratic_change_coefficients[of A2 qf2 B1 B2 C x1 y1 ?qf_2]
	+ quadratic_change_coefficients[of A2 qf2 B1 B2 C x2 y2 ?qf_2]
	+ quadratic_change_coefficients[of A1 qf1 b1 b2 c x y ?qf_1]
	+ quadratic_change_coefficients[of A2 qf2 B1 B2 C x y ?qf_2]
	+ by auto
	+
	+ thus ?thesis
	+ using quadratic_quadratic_at_most_2_intersections'
	+ [of "b2 / A1" "B2 / A2" "b1 / A1" "B1 / A2" ?qf_1 "c / A1" ?qf_2 "C / A2" x1 y1 x2 y2 x y]
	+ using * ** \<open>(x1, y1) \<noteq> (x2, y2)\<close>
	+ by fastforce
	+qed
	+
	+end
	diff --git a/thys/Complex_Geometry/ROOT b/thys/Complex_Geometry/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/ROOT
	@@ -0,0 +1,31 @@
	+chapter AFP
	+
	+session Complex_Geometry (AFP) = HOL +
	+ options [timeout = 1200]
	+ sessions
	+ "HOL-Analysis"
	+ "HOL-Library"
	+ theories
	+ More_Transcendental
	+ Canonical_Angle
	+ More_Complex
	+ Angles
	+ More_Set
	+ Linear_Systems
	+ Quadratic
	+ Matrices
	+ Unitary_Matrices
	+ Unitary11_Matrices
	+ Hermitean_Matrices
	+ Elementary_Complex_Geometry
	+ Homogeneous_Coordinates
	+ Moebius
	+ Circlines
	+ Oriented_Circlines
	+ Circlines_Angle
	+ Unit_Circle_Preserving_Moebius
	+ Riemann_Sphere
	+ Chordal_Metric
	+ document_files
	+ "root.bib"
	+ "root.tex"
	diff --git a/thys/Complex_Geometry/Riemann_Sphere.thy b/thys/Complex_Geometry/Riemann_Sphere.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Riemann_Sphere.thy
	@@ -0,0 +1,641 @@
	+(* ---------------------------------------------------------------------------- *)
	+section \<open>Riemann sphere\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>The extended complex plane $\mathbb{C}P^1$ can be identified with a Riemann (unit) sphere
	+$\Sigma$ by means of stereographic projection. The sphere is projected from its north pole $N$ to
	+the $xOy$ plane (identified with $\mathbb{C}$). This projection establishes a bijective map $sp$
	+between $\Sigma \setminus \{N\}$ and the finite complex plane $\mathbb{C}$. The infinite point is
	+defined as the image of $N$.\<close>
	+
	+theory Riemann_Sphere
	+imports Homogeneous_Coordinates Circlines "HOL-Analysis.Product_Vector"
	+begin
	+
	+text \<open>Coordinates in $\mathbb{R}^3$\<close>
	+type_synonym R3 = "real \<times> real \<times> real"
	+
	+text \<open>Type of points of $\Sigma$\<close>
	+abbreviation unit_sphere where
	+ "unit_sphere \<equiv> {(x::real, y::real, z::real). xx + yy + z*z = 1}"
	+
	+typedef riemann_sphere = "unit_sphere"
	+ by (rule_tac x="(1, 0, 0)" in exI) simp
	+
	+setup_lifting type_definition_riemann_sphere
	+
	+lemma sphere_bounds':
	+ assumes "xx + yy + z*z = (1::real)"
	+ shows "-1 \<le> x \<and> x \<le> 1"
	+proof-
	+ from assms have "x*x \<le> 1"
	+ by (smt real_minus_mult_self_le)
	+ hence "x\<^sup>2 \<le> 1\<^sup>2" "(- x)\<^sup>2 \<le> 1\<^sup>2"
	+ by (auto simp add: power2_eq_square)
	+ show "-1 \<le> x \<and> x \<le> 1"
	+ proof (cases "x \<ge> 0")
	+ case True
	+ thus ?thesis
	+ using \<open>x\<^sup>2 \<le> 1\<^sup>2\<close>
	+ by (smt power2_le_imp_le)
	+ next
	+ case False
	+ thus ?thesis
	+ using \<open>(-x)\<^sup>2 \<le> 1\<^sup>2\<close>
	+ by (smt power2_le_imp_le)
	+ qed
	+qed
	+
	+lemma sphere_bounds:
	+ assumes "xx + yy + z*z = (1::real)"
	+ shows "-1 \<le> x \<and> x \<le> 1" "-1 \<le> y \<and> y \<le> 1" "-1 \<le> z \<and> z \<le> 1"
	+ using assms
	+ using sphere_bounds'[of x y z] sphere_bounds'[of y x z] sphere_bounds'[of z x y]
	+ by (auto simp add: field_simps)
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Parametrization of the unit sphere in polar coordinates\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+lemma sphere_params_on_sphere:
	+ fixes \<alpha> \<beta> :: real
	+ assumes "x = cos \<alpha> * cos \<beta>" and "y = cos \<alpha> * sin \<beta>" "z = sin \<alpha>"
	+ shows "xx + yy + z*z = 1"
	+proof-
	+ have "xx + yy = (cos \<alpha> * cos \<alpha>) * (cos \<beta> * cos \<beta>) + (cos \<alpha> * cos \<alpha>) * (sin \<beta> * sin \<beta>)"
	+ using assms
	+ by simp
	+ hence "xx + yy = cos \<alpha> * cos \<alpha>"
	+ using sin_cos_squared_add3[of \<beta>]
	+ by (subst (asm) distrib_left[symmetric]) (simp add: field_simps)
	+ thus ?thesis
	+ using assms
	+ using sin_cos_squared_add3[of \<alpha>]
	+ by simp
	+qed
	+
	+lemma sphere_params:
	+ fixes x y z :: real
	+ assumes "xx + yy + z*z = 1"
	+ shows "x = cos (arcsin z) * cos (atan2 y x) \<and> y = cos (arcsin z) * sin (atan2 y x) \<and> z = sin (arcsin z)"
	+proof (cases "z=1 \<or> z = -1")
	+ case True
	+ hence "x = 0 \<and> y = 0"
	+ using assms
	+ by auto
	+ thus ?thesis
	+ using \<open>z = 1 \<or> z = -1\<close>
	+ by (auto simp add: cos_arcsin)
	+next
	+ case False
	+ hence "x \<noteq> 0 \<or> y \<noteq> 0"
	+ using assms
	+ by (auto simp add: square_eq_1_iff)
	+ thus ?thesis
	+ using real_sqrt_unique[of y "1 - z*z"]
	+ using real_sqrt_unique[of "-y" "1 - z*z"]
	+ using sphere_bounds[OF assms] assms
	+ by (auto simp add: cos_arcsin cos_arctan sin_arctan power2_eq_square field_simps real_sqrt_divide atan2_def)
	+qed
	+
	+lemma ex_sphere_params:
	+ assumes "xx + yy + z*z = 1"
	+ shows "\<exists> \<alpha> \<beta>. x = cos \<alpha> * cos \<beta> \<and> y = cos \<alpha> * sin \<beta> \<and> z = sin \<alpha> \<and> -pi / 2 \<le> \<alpha> \<and> \<alpha> \<le> pi / 2 \<and> -pi \<le> \<beta> \<and> \<beta> < pi"
	+using assms arcsin_bounded[of z] sphere_bounds[of x y z]
	+by (rule_tac x="arcsin z" in exI, rule_tac x="atan2 y x" in exI) (simp add: sphere_params arcsin_bounded atan2_bounded)
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Stereographic and inverse stereographic projection\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Stereographic projection\<close>
	+
	+definition stereographic_r3_cvec :: "R3 \<Rightarrow> complex_vec" where
	+[simp]: "stereographic_r3_cvec M = (let (x, y, z) = M in
	+ (if (x, y, z) \<noteq> (0, 0, 1) then
	+ (x + \<i> * y, cor (1 - z))
	+ else
	+ (1, 0)
	+ ))"
	+
	+
	+lift_definition stereographic_r3_hcoords :: "R3 \<Rightarrow> complex_homo_coords" is stereographic_r3_cvec
	+ by (auto split: if_split_asm simp add: cor_eq_0)
	+
	+lift_definition stereographic :: "riemann_sphere \<Rightarrow> complex_homo" is stereographic_r3_hcoords
	+ done
	+
	+text \<open>Inverse stereographic projection\<close>
	+
	+definition inv_stereographic_cvec_r3 :: "complex_vec \<Rightarrow> R3" where [simp]:
	+ "inv_stereographic_cvec_r3 z = (
	+ let (z1, z2) = z
	+ in if z2 = 0 then
	+ (0, 0, 1)
	+ else
	+ let z = z1/z2;
	+ X = Re (2z / (1 + zcnj z));
	+ Y = Im (2z / (1 + zcnj z));
	+ Z = ((cmod z)\<^sup>2 - 1) / (1 + (cmod z)\<^sup>2)
	+ in (X, Y, Z))"
	+
	+lemma Re_stereographic:
	+ shows "Re (2 * z / (1 + z * cnj z)) = 2 * Re z / (1 + (cmod z)\<^sup>2)"
	+ using one_plus_square_neq_zero
	+ by (subst complex_mult_cnj_cmod, subst Re_divide_real) (auto simp add: power2_eq_square)
	+
	+lemma Im_stereographic:
	+ shows "Im (2 * z / (1 + z * cnj z)) = 2 * Im z / (1 + (cmod z)\<^sup>2)"
	+ using one_plus_square_neq_zero
	+ by (subst complex_mult_cnj_cmod, subst Im_divide_real) (auto simp add: power2_eq_square)
	+
	+lemma inv_stereographic_on_sphere:
	+ assumes "X = Re (2z / (1 + zcnj z))" and "Y = Im (2z / (1 + zcnj z))" and "Z = ((cmod z)\<^sup>2 - 1) / (1 + (cmod z)\<^sup>2)"
	+ shows "XX + YY + Z*Z = 1"
	+proof-
	+ have "1 + (cmod z)\<^sup>2 \<noteq> 0"
	+ by (smt power2_less_0)
	+ thus ?thesis
	+ using assms
	+ by (simp add: Re_stereographic Im_stereographic)
	+ (cases z, simp add: power2_eq_square real_sqrt_mult[symmetric] add_divide_distrib[symmetric], simp add: complex_norm power2_eq_square field_simps)
	+qed
	+
	+lift_definition inv_stereographic_hcoords_r3 :: "complex_homo_coords \<Rightarrow> R3" is inv_stereographic_cvec_r3
	+ done
	+
	+lift_definition inv_stereographic :: "complex_homo \<Rightarrow> riemann_sphere" is inv_stereographic_hcoords_r3
	+proof transfer
	+ fix v v'
	+ assume 1: "v \<noteq> vec_zero" "v' \<noteq> vec_zero" "v \<approx>\<^sub>v v'"
	+ obtain v1 v2 v'1 v'2 where *: "v = (v1, v2)" "v' = (v'1, v'2)"
	+ by (cases v, cases v', auto)
	+ obtain x y z where
	+ **: "inv_stereographic_cvec_r3 v = (x, y, z)"
	+ by (cases "inv_stereographic_cvec_r3 v", blast)
	+ have "inv_stereographic_cvec_r3 v \<in> unit_sphere"
	+ proof (cases "v2 = 0")
	+ case True
	+ thus ?thesis
	+ using *
	+ by simp
	+ next
	+ case False
	+ thus ?thesis
	+ using * ** inv_stereographic_on_sphere[of x "v1 / v2" y z]
	+ by simp
	+ qed
	+ moreover
	+ have "inv_stereographic_cvec_r3 v = inv_stereographic_cvec_r3 v'"
	+ using 1 * **
	+ by (auto split: if_split if_split_asm)
	+ ultimately
	+ show "inv_stereographic_cvec_r3 v \<in> unit_sphere \<and>
	+ inv_stereographic_cvec_r3 v = inv_stereographic_cvec_r3 v'"
	+ by simp
	+qed
	+
	+text \<open>North pole\<close>
	+definition North_R3 :: R3 where
	+ [simp]: "North_R3 = (0, 0, 1)"
	+lift_definition North :: "riemann_sphere" is North_R3
	+ by simp
	+
	+lemma stereographic_North:
	+ shows "stereographic x = \<infinity>\<^sub>h \<longleftrightarrow> x = North"
	+ by (transfer, transfer, auto split: if_split_asm)
	+
	+text \<open>Stereographic and inverse stereographic projection are mutually inverse.\<close>
	+
	+lemma stereographic_inv_stereographic':
	+ assumes
	+ z: "z = z1/z2" and "z2 \<noteq> 0" and
	+ X: "X = Re (2z / (1 + zcnj z))" and Y: "Y = Im (2z / (1 + zcnj z))" and Z: "Z = ((cmod z)\<^sup>2 - 1) / (1 + (cmod z)\<^sup>2)"
	+ shows "\<exists> k. k \<noteq> 0 \<and> (X + \<i>Y, complex_of_real (1 - Z)) = k \<^sub>s\<^sub>v (z1, z2)"
	+proof-
	+ have "1 + (cmod z)\<^sup>2 \<noteq> 0"
	+ by (metis one_power2 sum_power2_eq_zero_iff zero_neq_one)
	+ hence "(1 - Z) = 2 / (1 + (cmod z)\<^sup>2)"
	+ using Z
	+ by (auto simp add: field_simps)
	+ hence "cor (1 - Z) = 2 / cor (1 + (cmod z)\<^sup>2)"
	+ by auto
	+ moreover
	+ have "X = 2 * Re(z) / (1 + (cmod z)\<^sup>2)"
	+ using X
	+ by (simp add: Re_stereographic)
	+ have "Y = 2 * Im(z) / (1 + (cmod z)\<^sup>2)"
	+ using Y
	+ by (simp add: Im_stereographic)
	+ have "X + \<i>Y = 2 z / cor (1 + (cmod z)\<^sup>2)"
	+ using \<open>1 + (cmod z)\<^sup>2 \<noteq> 0\<close>
	+ unfolding Complex_eq[of X Y, symmetric]
	+ by (subst \<open>X = 2Re(z) / (1 + (cmod z)\<^sup>2)\<close>, subst \<open>Y = 2Im(z) / (1 + (cmod z)\<^sup>2)\<close>, simp add: Complex_scale4 Complex_scale1)
	+ moreover
	+ have "1 + (cor (cmod (z1 / z2)))\<^sup>2 \<noteq> 0"
	+ by (rule one_plus_square_neq_zero)
	+ ultimately
	+ show ?thesis
	+ using \<open>z2 \<noteq> 0\<close> \<open>1 + (cmod z)\<^sup>2 \<noteq> 0\<close>
	+ by (simp, subst z)+
	+ (rule_tac x="(2 / (1 + (cor (cmod (z1 / z2)))\<^sup>2)) / z2" in exI, auto)
	+qed
	+
	+lemma stereographic_inv_stereographic [simp]:
	+ shows "stereographic (inv_stereographic w) = w"
	+proof-
	+ have "w = stereographic (inv_stereographic w)"
	+ proof (transfer, transfer)
	+ fix w
	+ assume "w \<noteq> vec_zero"
	+ obtain w1 w2 where *: "w = (w1, w2)"
	+ by (cases w, auto)
	+ obtain x y z where **: "inv_stereographic_cvec_r3 w = (x, y, z)"
	+ by (cases "inv_stereographic_cvec_r3 w", blast)
	+ show "w \<approx>\<^sub>v stereographic_r3_cvec (inv_stereographic_cvec_r3 w)"
	+ using \<open>w \<noteq> vec_zero\<close> stereographic_inv_stereographic'[of "w1/w2" w1 w2 x y z] * **
	+ by (auto simp add: split_def Let_def split: if_split_asm)
	+ qed
	+ thus ?thesis
	+ by simp
	+qed
	+
	+text \<open>Stereographic projection is bijective function\<close>
	+
	+lemma bij_stereographic:
	+ shows "bij stereographic"
	+ unfolding bij_def inj_on_def surj_def
	+proof (safe)
	+ fix a b
	+ assume "stereographic a = stereographic b"
	+ thus "a = b"
	+ proof (transfer, transfer)
	+ fix a b :: R3
	+ obtain xa ya za xb yb zb where
	+ *: "a = (xa, ya, za)" "b = (xb, yb, zb)"
	+ by (cases a, cases b, auto)
	+ assume **: "a \<in> unit_sphere" "b \<in> unit_sphere" "stereographic_r3_cvec a \<approx>\<^sub>v stereographic_r3_cvec b"
	+ show "a = b"
	+ proof (cases "a = (0, 0, 1) \<or> b = (0, 0, 1)")
	+ case True
	+ thus ?thesis
	+ using * **
	+ by (simp split: if_split_asm) force+
	+ next
	+ case False
	+ then obtain k where ++: "k \<noteq> 0" "cor xb + \<i> * cor yb = k * (cor xa + \<i> * cor ya)" "1 - cor zb = k * (1 - cor za)"
	+ using * **
	+ by (auto split: if_split_asm)
	+
	+ {
	+ assume "xb + xazb = xa + xbza"
	+ "yb + yazb = ya + ybza"
	+ "xaxa + yaya + zaza = 1" "xbxb + ybyb + zbzb = 1"
	+ "za \<noteq> 1" "zb \<noteq> 1"
	+ hence "xa = xb \<and> ya = yb \<and> za = zb"
	+ by algebra
	+ } note *** = this
	+
	+ have "za \<noteq> 1" "zb \<noteq> 1"
	+ using False * **
	+ by auto
	+ have "k = (1 - cor zb) / (1 - cor za)"
	+ using \<open>1 - cor zb = k * (1 - cor za)\<close> \<open>za \<noteq> 1\<close>
	+ by simp
	+ hence "(1 - cor za) * (cor xb + \<i> * cor yb) = (1 - cor zb) * (cor xa + \<i> * cor ya)"
	+ using \<open>za \<noteq> 1\<close> ++(2)
	+ by simp
	+ hence "xb + xazb = xa + xbza"
	+ "yb + yazb = ya + ybza"
	+ "xaxa + yaya + zaza = 1" "xbxb + ybyb + zbzb = 1"
	+ using * ** \<open>za \<noteq> 1\<close>
	+ apply (simp_all add: field_simps)
	+ unfolding complex_of_real_def imaginary_unit.ctr
	+ by (simp_all add: legacy_Complex_simps)
	+ thus ?thesis
	+ using * * \<open>za \<noteq> 1\<close> \<open>zb \<noteq> 1\<close>
	+ by simp
	+ qed
	+ qed
	+next
	+ fix y
	+ show "\<exists> x. y = stereographic x"
	+ by (rule_tac x="inv_stereographic y" in exI, simp)
	+qed
	+
	+
	+lemma inv_stereographic_stereographic [simp]:
	+ shows "inv_stereographic (stereographic x) = x"
	+ using stereographic_inv_stereographic[of "stereographic x"]
	+ using bij_stereographic
	+ unfolding bij_def inj_on_def
	+ by simp
	+
	+lemma inv_stereographic_is_inv:
	+ shows "inv_stereographic = inv stereographic"
	+ by (rule inv_equality[symmetric], simp_all)
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Circles on the sphere\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Circlines in the plane correspond to circles on the Riemann sphere, and we formally establish
	+this connection. Every circle in three--dimensional space can be obtained as the intersection of a
	+sphere and a plane. We establish a one-to-one correspondence between circles on the Riemann sphere
	+and planes in space. Note that the plane need not intersect the sphere, but we will still say that
	+it defines a single imaginary circle. However, for one special circline (the one with the identity
	+representative matrix), there does not exist a plane in $\mathbb{R}^3$ that would correspond to it
	+--- in order to have this, instead of considering planes in $\mathbb{R}^3$, we must consider three
	+dimensional projective space and consider the infinite (hyper)plane.\<close>
	+
	+text \<open>Planes in $R^3$ are given by equations $ax+by+cz=d$. Two four-tuples of coefficients $(a, b, c,
	+d)$ give the same plane iff they are proportional.\<close>
	+
	+type_synonym R4 = "real \<times> real \<times> real \<times> real"
	+
	+fun mult_sv :: "real \<Rightarrow> R4 \<Rightarrow> R4" (infixl "*\<^sub>s\<^sub>v\<^sub>4" 100) where
	+ "k \<^sub>s\<^sub>v\<^sub>4 (a, b, c, d) = (ka, kb, kc, k*d)"
	+
	+abbreviation plane_vectors where
	+ "plane_vectors \<equiv> {(a::real, b::real, c::real, d::real). a \<noteq> 0 \<or> b \<noteq> 0 \<or> c \<noteq> 0 \<or> d \<noteq> 0}"
	+
	+typedef plane_vec = "plane_vectors"
	+ by (rule_tac x="(1, 1, 1, 1)" in exI) simp
	+
	+setup_lifting type_definition_plane_vec
	+
	+definition plane_vec_eq_r4 :: "R4 \<Rightarrow> R4 \<Rightarrow> bool" where
	+ [simp]: "plane_vec_eq_r4 v1 v2 \<longleftrightarrow> (\<exists> k. k \<noteq> 0 \<and> v2 = k *\<^sub>s\<^sub>v\<^sub>4 v1)"
	+
	+lift_definition plane_vec_eq :: "plane_vec \<Rightarrow> plane_vec \<Rightarrow> bool" is plane_vec_eq_r4
	+ done
	+
	+lemma mult_sv_one [simp]:
	+ shows "1 *\<^sub>s\<^sub>v\<^sub>4 x = x"
	+ by (cases x) simp
	+
	+lemma mult_sv_distb [simp]:
	+ shows "x \<^sub>s\<^sub>v\<^sub>4 (y \<^sub>s\<^sub>v\<^sub>4 v) = (xy) \<^sub>s\<^sub>v\<^sub>4 v"
	+ by (cases v) simp
	+
	+quotient_type plane = plane_vec / plane_vec_eq
	+proof (rule equivpI)
	+ show "reflp plane_vec_eq"
	+ unfolding reflp_def
	+ by (auto simp add: plane_vec_eq_def) (rule_tac x="1" in exI, simp)
	+next
	+ show "symp plane_vec_eq"
	+ unfolding symp_def
	+ by (auto simp add: plane_vec_eq_def) (rule_tac x="1/k" in exI, simp)
	+next
	+ show "transp plane_vec_eq"
	+ unfolding transp_def
	+ by (auto simp add: plane_vec_eq_def) (rule_tac x="ka*k" in exI, simp)
	+qed
	+
	+text \<open>Plane coefficients give a linear equation and the point on the Riemann sphere lies on the
	+circle determined by the plane iff its representation satisfies that linear equation.\<close>
	+
	+definition on_sphere_circle_r4_r3 :: "R4 \<Rightarrow> R3 \<Rightarrow> bool" where
	+ [simp]: "on_sphere_circle_r4_r3 \<alpha> A \<longleftrightarrow>
	+ (let (X, Y, Z) = A;
	+ (a, b, c, d) = \<alpha>
	+ in aX + bY + c*Z + d = 0)"
	+
	+lift_definition on_sphere_circle_vec :: "plane_vec \<Rightarrow> R3 \<Rightarrow> bool" is on_sphere_circle_r4_r3
	+ done
	+
	+lift_definition on_sphere_circle :: "plane \<Rightarrow> riemann_sphere \<Rightarrow> bool" is on_sphere_circle_vec
	+proof (transfer)
	+ fix pv1 pv2 :: R4 and w :: R3
	+ obtain a1 b1 c1 d1 a2 b2 c2 d2 x y z where
	+ *: "pv1 = (a1, b1, c1, d1)" "pv2 = (a2, b2, c2, d2)" "w = (x, y, z)"
	+ by (cases pv1, cases pv2, cases w, auto)
	+ assume "pv1 \<in> plane_vectors" "pv2 \<in> plane_vectors" "w \<in> unit_sphere" "plane_vec_eq_r4 pv1 pv2"
	+ then obtain k where *: "a2 = ka1" "b2 = kb1" "c2 = kc1" "d2 = k*d1" "k \<noteq> 0"
	+ using *
	+ by auto
	+ have "k * a1 * x + k * b1 * y + k * c1 * z + k * d1 = k(a1x + b1y + c1z + d1)"
	+ by (simp add: field_simps)
	+ thus "on_sphere_circle_r4_r3 pv1 w = on_sphere_circle_r4_r3 pv2 w"
	+ using * **
	+ by simp
	+qed
	+
	+definition sphere_circle_set where
	+ "sphere_circle_set \<alpha> = {A. on_sphere_circle \<alpha> A}"
	+
	+
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Connections of circlines in the plane and circles on the Riemann sphere\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>We introduce stereographic and inverse stereographic projection between circles on the Riemann
	+sphere and circlines in the extended complex plane.\<close>
	+
	+definition inv_stereographic_circline_cmat_r4 :: "complex_mat \<Rightarrow> R4" where
	+ [simp]: "inv_stereographic_circline_cmat_r4 H =
	+ (let (A, B, C, D) = H
	+ in (Re (B+C), Re(\<i>*(C-B)), Re(A-D), Re(D+A)))"
	+
	+lift_definition inv_stereographic_circline_clmat_pv :: "circline_mat \<Rightarrow> plane_vec" is inv_stereographic_circline_cmat_r4
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def real_imag_0 eq_cnj_iff_real)
	+
	+lift_definition inv_stereographic_circline :: "circline \<Rightarrow> plane" is inv_stereographic_circline_clmat_pv
	+ apply transfer
	+ apply simp
	+ apply (erule exE)
	+ apply (rule_tac x="k" in exI)
	+ apply (case_tac "circline_mat1", case_tac "circline_mat2")
	+ apply (simp add: field_simps)
	+ done
	+
	+definition stereographic_circline_r4_cmat :: "R4 \<Rightarrow> complex_mat" where
	+[simp]: "stereographic_circline_r4_cmat \<alpha> =
	+ (let (a, b, c, d) = \<alpha>
	+ in (cor ((c+d)/2) , ((cor a + \<i> * cor b)/2), ((cor a - \<i> * cor b)/2), cor ((d-c)/2)))"
	+
	+lift_definition stereographic_circline_pv_clmat :: "plane_vec \<Rightarrow> circline_mat" is stereographic_circline_r4_cmat
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+
	+lift_definition stereographic_circline :: "plane \<Rightarrow> circline" is stereographic_circline_pv_clmat
	+ apply transfer
	+ apply transfer
	+ apply (case_tac plane_vec1, case_tac plane_vec2, simp, erule exE, rule_tac x=k in exI, simp add: field_simps)
	+ done
	+
	+text \<open>Stereographic and inverse stereographic projection of circlines are mutually inverse.\<close>
	+
	+lemma stereographic_circline_inv_stereographic_circline:
	+ shows "stereographic_circline \<circ> inv_stereographic_circline = id"
	+proof (rule ext, simp)
	+ fix H
	+ show "stereographic_circline (inv_stereographic_circline H) = H"
	+ proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases "H") auto
	+ have "is_real A" "is_real D" "C = cnj B"
	+ using HH hh hermitean_elems[of A B C D]
	+ by auto
	+ thus "circline_eq_cmat (stereographic_circline_r4_cmat (inv_stereographic_circline_cmat_r4 H)) H"
	+ using HH
	+ apply simp
	+ apply (rule_tac x=1 in exI, cases B)
	+ by (smt add_uminus_conv_diff complex_cnj_add complex_cnj_complex_of_real complex_cnj_i complex_cnj_mult complex_cnj_one complex_eq distrib_left_numeral mult.commute mult.left_commute mult.left_neutral mult_cancel_right2 mult_minus_left of_real_1 one_add_one)
	+ qed
	+qed
	+
	+text \<open>Stereographic and inverse stereographic projection of circlines are mutually inverse.\<close>
	+lemma inv_stereographic_circline_stereographic_circline:
	+ "inv_stereographic_circline \<circ> stereographic_circline = id"
	+proof (rule ext, simp)
	+ fix \<alpha>
	+ show "inv_stereographic_circline (stereographic_circline \<alpha>) = \<alpha>"
	+ proof (transfer, transfer)
	+ fix \<alpha>
	+ assume aa: "\<alpha> \<in> plane_vectors"
	+ obtain a b c d where AA: "\<alpha> = (a, b, c, d)"
	+ by (cases "\<alpha>") auto
	+ thus "plane_vec_eq_r4 (inv_stereographic_circline_cmat_r4 (stereographic_circline_r4_cmat \<alpha>)) \<alpha>"
	+ using AA
	+ by simp (rule_tac x=1 in exI, auto simp add: field_simps complex_of_real_def)
	+ qed
	+qed
	+
	+lemma stereographic_sphere_circle_set'':
	+ shows "on_sphere_circle (inv_stereographic_circline H) z \<longleftrightarrow>
	+ on_circline H (stereographic z)"
	+proof (transfer, transfer)
	+ fix M :: R3 and H :: complex_mat
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero" "M \<in> unit_sphere"
	+ obtain A B C D where HH: "H = (A, B, C, D)"
	+ by (cases "H") auto
	+ have *: "is_real A" "is_real D" "C = cnj B"
	+ using hh HH hermitean_elems[of A B C D]
	+ by auto
	+ obtain x y z where MM: "M = (x, y, z)"
	+ by (cases "M") auto
	+ show "on_sphere_circle_r4_r3 (inv_stereographic_circline_cmat_r4 H) M \<longleftrightarrow>
	+ on_circline_cmat_cvec H (stereographic_r3_cvec M)" (is "?lhs = ?rhs")
	+ proof
	+ assume ?lhs
	+ show ?rhs
	+ proof (cases "z=1")
	+ case True
	+ hence "x = 0" "y = 0"
	+ using MM hh
	+ by auto
	+ thus ?thesis
	+ using * \<open>?lhs\<close> HH MM \<open>z=1\<close>
	+ by (cases A, simp add: vec_cnj_def Complex_eq Let_def)
	+ next
	+ case False
	+ hence "Re A(1+z) + 2Re Bx + 2Im By + Re D(1-z) = 0"
	+ using * \<open>?lhs\<close> HH MM
	+ by (simp add: Let_def field_simps)
	+ hence "(Re A(1+z) + 2Re Bx + 2Im By + Re D(1-z))*(1-z) = 0"
	+ by simp
	+ hence "Re A(1+z)(1-z) + 2Re Bx(1-z) + 2Im By(1-z) + Re D(1-z)(1-z) = 0"
	+ by (simp add: field_simps)
	+ moreover
	+ have "xx+yy = (1+z)*(1-z)"
	+ using MM hh
	+ by (simp add: field_simps)
	+ ultimately
	+ have "Re A(xx+yy) + 2Re Bx(1-z) + 2Im By(1-z) + Re D(1-z)*(1-z) = 0"
	+ by simp
	+ hence "(x * Re A + (1 - z) * Re B) * x - (- (y * Re A) + - ((1 - z) * Im B)) * y + (x * Re B + y * Im B + (1 - z) * Re D) * (1 - z) = 0"
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using \<open>z \<noteq> 1\<close> HH MM * \<open>Re A(1+z) + 2Re Bx + 2Im By + Re D(1-z) = 0\<close>
	+ apply (simp add: Let_def vec_cnj_def)
	+ apply (subst complex_eq_iff)
	+ apply (simp add: field_simps)
	+ done
	+ qed
	+ next
	+ assume ?rhs
	+ show ?lhs
	+ proof (cases "z=1")
	+ case True
	+ hence "x = 0" "y = 0"
	+ using MM hh
	+ by auto
	+ thus ?thesis
	+ using HH MM \<open>?rhs\<close> \<open>z = 1\<close>
	+ by (simp add: Let_def vec_cnj_def)
	+ next
	+ case False
	+ hence "(x * Re A + (1 - z) * Re B) * x - (- (y * Re A) + - ((1 - z) * Im B)) * y + (x * Re B + y * Im B + (1 - z) * Re D) * (1 - z) = 0"
	+ using HH MM * \<open>?rhs\<close>
	+ by (simp add: Let_def vec_cnj_def complex_eq_iff)
	+ hence "Re A(xx+yy) + 2Re Bx(1-z) + 2Im By(1-z) + Re D(1-z)*(1-z) = 0"
	+ by (simp add: field_simps)
	+ moreover
	+ have "xx + yy = (1+z)*(1-z)"
	+ using MM hh
	+ by (simp add: field_simps)
	+ ultimately
	+ have "Re A(1+z)(1-z) + 2Re Bx(1-z) + 2Im By(1-z) + Re D(1-z)(1-z) = 0"
	+ by simp
	+ hence "(Re A(1+z) + 2Re Bx + 2Im By + Re D(1-z))*(1-z) = 0"
	+ by (simp add: field_simps)
	+ hence "Re A(1+z) + 2Re Bx + 2Im By + Re D(1-z) = 0"
	+ using \<open>z \<noteq> 1\<close>
	+ by simp
	+ thus ?thesis
	+ using MM HH *
	+ by (simp add: field_simps)
	+ qed
	+ qed
	+qed
	+
	+lemma stereographic_sphere_circle_set' [simp]:
	+ shows "stereographic ` sphere_circle_set (inv_stereographic_circline H) =
	+ circline_set H"
	+unfolding sphere_circle_set_def circline_set_def
	+apply safe
	+proof-
	+ fix x
	+ assume "on_sphere_circle (inv_stereographic_circline H) x"
	+ thus "on_circline H (stereographic x)"
	+ using stereographic_sphere_circle_set''
	+ by simp
	+next
	+ fix x
	+ assume "on_circline H x"
	+ show "x \<in> stereographic ` {z. on_sphere_circle (inv_stereographic_circline H) z}"
	+ proof
	+ show "x = stereographic (inv_stereographic x)"
	+ by simp
	+ next
	+ show "inv_stereographic x \<in> {z. on_sphere_circle (inv_stereographic_circline H) z}"
	+ using stereographic_sphere_circle_set''[of H "inv_stereographic x"] \<open>on_circline H x\<close>
	+ by simp
	+ qed
	+qed
	+
	+text \<open>The projection of the set of points on a circle on the Riemann sphere is exactly the set of
	+points on the circline obtained by the just introduced circle stereographic projection.\<close>
	+lemma stereographic_sphere_circle_set:
	+ shows "stereographic ` sphere_circle_set H = circline_set (stereographic_circline H)"
	+using stereographic_sphere_circle_set'[of "stereographic_circline H"]
	+using inv_stereographic_circline_stereographic_circline
	+unfolding comp_def
	+by (metis id_apply)
	+
	+text \<open>Stereographic projection of circlines is bijective.\<close>
	+lemma bij_stereographic_circline:
	+ shows "bij stereographic_circline"
	+ using stereographic_circline_inv_stereographic_circline inv_stereographic_circline_stereographic_circline
	+ using o_bij by blast
	+
	+text \<open>Inverse stereographic projection is bijective.\<close>
	+lemma bij_inv_stereographic_circline:
	+ shows "bij inv_stereographic_circline"
	+ using stereographic_circline_inv_stereographic_circline inv_stereographic_circline_stereographic_circline
	+ using o_bij by blast
	+
	+end
	diff --git a/thys/Complex_Geometry/Unit_Circle_Preserving_Moebius.thy b/thys/Complex_Geometry/Unit_Circle_Preserving_Moebius.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Unit_Circle_Preserving_Moebius.thy
	@@ -0,0 +1,1201 @@
	+(* ---------------------------------------------------------------------------- *)
	+section \<open>Unit circle preserving Möbius transformations\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>In this section we shall examine Möbius transformations that map the unit circle onto itself.
	+We shall say that they fix or preserve the unit circle (although, they do not need to fix each of
	+its points).\<close>
	+
	+theory Unit_Circle_Preserving_Moebius
	+imports Unitary11_Matrices Moebius Oriented_Circlines
	+begin
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Möbius transformations that fix the unit circle\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>We define Möbius transformations that preserve unit circle as transformations represented by
	+generalized unitary matrices with the $1-1$ signature (elements of the gruop $GU_{1,1}(2,
	+\mathbb{C})$, defined earlier in the theory Unitary11Matrices).\<close>
	+
	+lift_definition unit_circle_fix_mmat :: "moebius_mat \<Rightarrow> bool" is unitary11_gen
	+ done
	+
	+lift_definition unit_circle_fix :: "moebius \<Rightarrow> bool" is unit_circle_fix_mmat
	+ apply transfer
	+ apply (auto simp del: mult_sm.simps)
	+ apply (simp del: mult_sm.simps add: unitary11_gen_mult_sm)
	+ apply (simp del: mult_sm.simps add: unitary11_gen_div_sm)
	+ done
	+
	+text \<open>Our algebraic characterisation (by matrices) is geometrically correct.\<close>
	+
	+lemma unit_circle_fix_iff:
	+ shows "unit_circle_fix M \<longleftrightarrow>
	+ moebius_circline M unit_circle = unit_circle" (is "?rhs = ?lhs")
	+proof
	+ assume ?lhs
	+ thus ?rhs
	+ proof (transfer, transfer)
	+ fix M :: complex_mat
	+ assume "mat_det M \<noteq> 0"
	+ assume "circline_eq_cmat (moebius_circline_cmat_cmat M unit_circle_cmat) unit_circle_cmat"
	+ then obtain k where "k \<noteq> 0" "(1, 0, 0, -1) = cor k *\<^sub>s\<^sub>m congruence (mat_inv M) (1, 0, 0, -1)"
	+ by auto
	+ hence "(1/cor k, 0, 0, -1/cor k) = congruence (mat_inv M) (1, 0, 0, -1)"
	+ using mult_sm_inv_l[of "cor k" "congruence (mat_inv M) (1, 0, 0, -1)" ]
	+ by simp
	+ hence "congruence M (1/cor k, 0, 0, -1/cor k) = (1, 0, 0, -1)"
	+ using \<open>mat_det M \<noteq> 0\<close> mat_det_inv[of M]
	+ using congruence_inv[of "mat_inv M" "(1, 0, 0, -1)" "(1/cor k, 0, 0, -1/cor k)"]
	+ by simp
	+ hence "congruence M (1, 0, 0, -1) = cor k *\<^sub>s\<^sub>m (1, 0, 0, -1)"
	+ using congruence_scale_m[of "M" "1/cor k" "(1, 0, 0, -1)"]
	+ using mult_sm_inv_l[of "1/ cor k" "congruence M (1, 0, 0, -1)" "(1, 0, 0, -1)"] \<open>k \<noteq> 0\<close>
	+ by simp
	+ thus "unitary11_gen M"
	+ using \<open>k \<noteq> 0\<close>
	+ unfolding unitary11_gen_def
	+ by simp
	+ qed
	+next
	+ assume ?rhs
	+ thus ?lhs
	+ proof (transfer, transfer)
	+ fix M :: complex_mat
	+ assume "mat_det M \<noteq> 0"
	+ assume "unitary11_gen M"
	+ hence "unitary11_gen (mat_inv M)"
	+ using \<open>mat_det M \<noteq> 0\<close>
	+ using unitary11_gen_mat_inv
	+ by simp
	+ thus " circline_eq_cmat (moebius_circline_cmat_cmat M unit_circle_cmat) unit_circle_cmat"
	+ unfolding unitary11_gen_real
	+ by auto (rule_tac x="1/k" in exI, simp)
	+ qed
	+qed
	+
	+lemma circline_set_fix_iff_circline_fix:
	+ assumes "circline_set H' \<noteq> {}"
	+ shows "circline_set (moebius_circline M H) = circline_set H' \<longleftrightarrow>
	+ moebius_circline M H = H'"
	+ using assms
	+ by auto (rule inj_circline_set, auto)
	+
	+lemma unit_circle_fix_iff_unit_circle_set:
	+ shows "unit_circle_fix M \<longleftrightarrow> moebius_pt M ` unit_circle_set = unit_circle_set"
	+proof-
	+ have "circline_set unit_circle \<noteq> {}"
	+ using one_in_unit_circle_set
	+ by auto
	+ thus ?thesis
	+ using unit_circle_fix_iff[of M] circline_set_fix_iff_circline_fix[of unit_circle M unit_circle]
	+ by (simp add: unit_circle_set_def)
	+qed
	+
	+
	+text \<open>Unit circle preserving Möbius transformations form a group. \<close>
	+
	+lemma unit_circle_fix_id_moebius [simp]:
	+ shows "unit_circle_fix id_moebius"
	+ by (transfer, transfer, simp add: unitary11_gen_def mat_adj_def mat_cnj_def)
	+
	+lemma unit_circle_fix_moebius_add [simp]:
	+ assumes "unit_circle_fix M1" and "unit_circle_fix M2"
	+ shows "unit_circle_fix (M1 + M2)"
	+ using assms
	+ unfolding unit_circle_fix_iff
	+ by auto
	+
	+lemma unit_circle_fix_moebius_comp [simp]:
	+ assumes "unit_circle_fix M1" and "unit_circle_fix M2"
	+ shows "unit_circle_fix (moebius_comp M1 M2)"
	+ using unit_circle_fix_moebius_add[OF assms]
	+ by simp
	+
	+lemma unit_circle_fix_moebius_uminus [simp]:
	+ assumes "unit_circle_fix M"
	+ shows "unit_circle_fix (-M)"
	+ using assms
	+ unfolding unit_circle_fix_iff
	+ by (metis moebius_circline_comp_inv_left uminus_moebius_def)
	+
	+lemma unit_circle_fix_moebius_inv [simp]:
	+ assumes "unit_circle_fix M"
	+ shows "unit_circle_fix (moebius_inv M)"
	+ using unit_circle_fix_moebius_uminus[OF assms]
	+ by simp
	+
	+text \<open>Unit circle fixing transforms preserve inverse points.\<close>
	+
	+lemma unit_circle_fix_moebius_pt_inversion [simp]:
	+ assumes "unit_circle_fix M"
	+ shows "moebius_pt M (inversion z) = inversion (moebius_pt M z)"
	+ using assms
	+ using symmetry_principle[of z "inversion z" unit_circle M]
	+ using unit_circle_fix_iff[of M, symmetric]
	+ using circline_symmetric_inv_homo_disc[of z]
	+ using circline_symmetric_inv_homo_disc'[of "moebius_pt M z" "moebius_pt M (inversion z)"]
	+ by metis
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Möbius transformations that fix the imaginary unit circle\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Only for completeness we show that Möbius transformations that preserve the imaginary unit
	+circle are exactly those characterised by generalized unitary matrices (with the (2, 0) signature).\<close>
	+lemma imag_unit_circle_fixed_iff_unitary_gen:
	+ assumes "mat_det (A, B, C, D) \<noteq> 0"
	+ shows "moebius_circline (mk_moebius A B C D) imag_unit_circle = imag_unit_circle \<longleftrightarrow>
	+ unitary_gen (A, B, C, D)" (is "?lhs = ?rhs")
	+proof
	+ assume ?lhs
	+ thus ?rhs
	+ using assms
	+ proof (transfer, transfer)
	+ fix A B C D :: complex
	+ let ?M = "(A, B, C, D)" and ?E = "(1, 0, 0, 1)"
	+ assume "circline_eq_cmat (moebius_circline_cmat_cmat (mk_moebius_cmat A B C D) imag_unit_circle_cmat) imag_unit_circle_cmat"
	+ "mat_det ?M \<noteq> 0"
	+ then obtain k where "k \<noteq> 0" "?E = cor k *\<^sub>s\<^sub>m congruence (mat_inv ?M) ?E"
	+ by auto
	+ hence "unitary_gen (mat_inv ?M)"
	+ using mult_sm_inv_l[of "cor k" "congruence (mat_inv ?M) ?E" "?E"]
	+ unfolding unitary_gen_def
	+ by (metis congruence_def divide_eq_0_iff eye_def mat_eye_r of_real_eq_0_iff one_neq_zero)
	+ thus "unitary_gen ?M"
	+ using unitary_gen_inv[of "mat_inv ?M"] \<open>mat_det ?M \<noteq> 0\<close>
	+ by (simp del: mat_inv.simps)
	+ qed
	+next
	+ assume ?rhs
	+ thus ?lhs
	+ using assms
	+ proof (transfer, transfer)
	+ fix A B C D :: complex
	+ let ?M = "(A, B, C, D)" and ?E = "(1, 0, 0, 1)"
	+ assume "unitary_gen ?M" "mat_det ?M \<noteq> 0"
	+ hence "unitary_gen (mat_inv ?M)"
	+ using unitary_gen_inv[of ?M]
	+ by simp
	+ then obtain k where "k \<noteq> 0" "mat_adj (mat_inv ?M) \<^sub>m\<^sub>m (mat_inv ?M) = cor k \<^sub>s\<^sub>m eye"
	+ using unitary_gen_real[of "mat_inv ?M"] mat_det_inv[of ?M]
	+ by auto
	+ hence : "?E = (1 / cor k) \<^sub>s\<^sub>m (mat_adj (mat_inv ?M) *\<^sub>m\<^sub>m (mat_inv ?M))"
	+ using mult_sm_inv_l[of "cor k" eye "mat_adj (mat_inv ?M) *\<^sub>m\<^sub>m (mat_inv ?M)"]
	+ by simp
	+ have "\<exists>k. k \<noteq> 0 \<and>
	+ (1, 0, 0, 1) = cor k \<^sub>s\<^sub>m (mat_adj (mat_inv (A, B, C, D)) \<^sub>m\<^sub>m (1, 0, 0, 1) *\<^sub>m\<^sub>m mat_inv (A, B, C, D))"
	+ using \<open>mat_det ?M \<noteq> 0\<close> \<open>k \<noteq> 0\<close>
	+ by (metis "" Im_complex_of_real Re_complex_of_real \<open>mat_adj (mat_inv ?M) \<^sub>m\<^sub>m mat_inv ?M = cor k *\<^sub>s\<^sub>m eye\<close> complex_of_real_Re eye_def mat_eye_l mult_mm_assoc mult_mm_sm mult_sm_eye_mm of_real_1 of_real_divide of_real_eq_1_iff zero_eq_1_divide_iff)
	+ thus "circline_eq_cmat (moebius_circline_cmat_cmat (mk_moebius_cmat A B C D) imag_unit_circle_cmat) imag_unit_circle_cmat"
	+ using \<open>mat_det ?M \<noteq> 0\<close> \<open>k \<noteq> 0\<close>
	+ by (simp del: mat_inv.simps)
	+ qed
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Möbius transformations that fix the oriented unit circle and the unit disc\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Möbius transformations that fix the unit circle either map the unit disc onto itself or
	+exchange it with its exterior. The transformations that fix the unit disc can be recognized from
	+their matrices -- they have the form as before, but additionally it must hold that $\|a\|^2 > \|b\|^2$.\<close>
	+
	+definition unit_disc_fix_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "unit_disc_fix_cmat M \<longleftrightarrow>
	+ (let (A, B, C, D) = M
	+ in unitary11_gen (A, B, C, D) \<and> (B = 0 \<or> Re ((AD)/(BC)) > 1))"
	+
	+lift_definition unit_disc_fix_mmat :: "moebius_mat \<Rightarrow> bool" is unit_disc_fix_cmat
	+ done
	+
	+lift_definition unit_disc_fix :: "moebius \<Rightarrow> bool" is unit_disc_fix_mmat
	+proof transfer
	+ fix M M' :: complex_mat
	+ assume det: "mat_det M \<noteq> 0" "mat_det M' \<noteq> 0"
	+ assume "moebius_cmat_eq M M'"
	+ then obtain k where : "k \<noteq> 0" "M' = k \<^sub>s\<^sub>m M"
	+ by auto
	+ hence **: "unitary11_gen M \<longleftrightarrow> unitary11_gen M'"
	+ using unitary11_gen_mult_sm[of k M] unitary11_gen_div_sm[of k M]
	+ by auto
	+ obtain A B C D where MM: "(A, B, C, D) = M"
	+ by (cases M) auto
	+ obtain A' B' C' D' where MM': "(A', B', C', D') = M'"
	+ by (cases M') auto
	+
	+ show "unit_disc_fix_cmat M = unit_disc_fix_cmat M'"
	+ using * ** MM MM'
	+ by auto
	+qed
	+
	+text \<open>Transformations that fix the unit disc also fix the unit circle.\<close>
	+lemma unit_disc_fix_unit_circle_fix [simp]:
	+ assumes "unit_disc_fix M"
	+ shows "unit_circle_fix M"
	+ using assms
	+ by (transfer, transfer, auto)
	+
	+text \<open>Transformations that preserve the unit disc preserve the orientation of the unit circle.\<close>
	+lemma unit_disc_fix_iff_ounit_circle:
	+ shows "unit_disc_fix M \<longleftrightarrow>
	+ moebius_ocircline M ounit_circle = ounit_circle" (is "?rhs \<longleftrightarrow> ?lhs")
	+proof
	+ assume *: ?lhs
	+ have "moebius_circline M unit_circle = unit_circle"
	+ apply (subst moebius_circline_ocircline[of M unit_circle])
	+ apply (subst of_circline_unit_circle)
	+ apply (subst *)
	+ by simp
	+
	+ hence "unit_circle_fix M"
	+ by (simp add: unit_circle_fix_iff)
	+ thus ?rhs
	+ using *
	+ proof (transfer, transfer)
	+ fix M :: complex_mat
	+ assume "mat_det M \<noteq> 0"
	+ let ?H = "(1, 0, 0, -1)"
	+ obtain A B C D where MM: "(A, B, C, D) = M"
	+ by (cases M) auto
	+ assume "unitary11_gen M" "ocircline_eq_cmat (moebius_circline_cmat_cmat M unit_circle_cmat) unit_circle_cmat"
	+ then obtain k where "0 < k" "?H = cor k *\<^sub>s\<^sub>m congruence (mat_inv M) ?H"
	+ by auto
	+ hence "congruence M ?H = cor k *\<^sub>s\<^sub>m ?H"
	+ using congruence_inv[of "mat_inv M" "?H" "(1/cor k) *\<^sub>s\<^sub>m ?H"] \<open>mat_det M \<noteq> 0\<close>
	+ using mult_sm_inv_l[of "cor k" "congruence (mat_inv M) ?H" "?H"]
	+ using mult_sm_inv_l[of "1/cor k" "congruence M ?H"]
	+ using congruence_scale_m[of M "1/cor k" "?H"]
	+ by (auto simp add: mat_det_inv)
	+ then obtain a b k' where "k' \<noteq> 0" "M = k' *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)" "sgn (Re (mat_det (a, b, cnj b, cnj a))) = 1"
	+ using unitary11_sgn_det_orientation'[of M k] \<open>k > 0\<close>
	+ by auto
	+ moreover
	+ have "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
	+ using \<open>sgn (Re (mat_det (a, b, cnj b, cnj a))) = 1\<close>
	+ by (smt sgn_0 zero_complex.simps(1))
	+ ultimately
	+ show "unit_disc_fix_cmat M"
	+ using unitary11_sgn_det[of k' a b M A B C D]
	+ using MM[symmetric] \<open>k > 0\<close> \<open>unitary11_gen M\<close>
	+ by (simp add: sgn_1_pos split: if_split_asm)
	+ qed
	+next
	+ assume ?rhs
	+ thus ?lhs
	+ proof (transfer, transfer)
	+ fix M :: complex_mat
	+ assume "mat_det M \<noteq> 0"
	+
	+ obtain A B C D where MM: "(A, B, C, D) = M"
	+ by (cases M) auto
	+ assume "unit_disc_fix_cmat M"
	+ hence "unitary11_gen M" "B = 0 \<or> 1 < Re (A * D / (B * C))"
	+ using MM[symmetric]
	+ by auto
	+ have "sgn (if B = 0 then 1 else sgn (Re (A * D / (B * C)) - 1)) = 1"
	+ using \<open>B = 0 \<or> 1 < Re (A * D / (B * C))\<close>
	+ by auto
	+ then obtain k' where "k' > 0" "congruence M (1, 0, 0, -1) = cor k' *\<^sub>s\<^sub>m (1, 0, 0, -1)"
	+ using unitary11_orientation[OF \<open>unitary11_gen M\<close> MM[symmetric]]
	+ by (auto simp add: sgn_1_pos)
	+ thus "ocircline_eq_cmat (moebius_circline_cmat_cmat M unit_circle_cmat) unit_circle_cmat"
	+ using congruence_inv[of M "(1, 0, 0, -1)" "cor k' *\<^sub>s\<^sub>m (1, 0, 0, -1)"] \<open>mat_det M \<noteq> 0\<close>
	+ using congruence_scale_m[of "mat_inv M" "cor k'" "(1, 0, 0, -1)"]
	+ by auto
	+ qed
	+qed
	+
	+
	+text \<open>Our algebraic characterisation (by matrices) is geometrically correct.\<close>
	+
	+lemma unit_disc_fix_iff [simp]:
	+ assumes "unit_disc_fix M"
	+ shows "moebius_pt M ` unit_disc = unit_disc"
	+ using assms
	+ using unit_disc_fix_iff_ounit_circle[of M]
	+ unfolding unit_disc_def
	+ by (subst disc_moebius_ocircline[symmetric], simp)
	+
	+lemma unit_disc_fix_discI [simp]:
	+ assumes "unit_disc_fix M" and "u \<in> unit_disc"
	+ shows "moebius_pt M u \<in> unit_disc"
	+ using unit_disc_fix_iff assms
	+ by blast
	+
	+text \<open>Unit disc preserving transformations form a group.\<close>
	+
	+lemma unit_disc_fix_id_moebius [simp]:
	+ shows "unit_disc_fix id_moebius"
	+ by (transfer, transfer, simp add: unitary11_gen_def mat_adj_def mat_cnj_def)
	+
	+lemma unit_disc_fix_moebius_add [simp]:
	+ assumes "unit_disc_fix M1" and "unit_disc_fix M2"
	+ shows "unit_disc_fix (M1 + M2)"
	+ using assms
	+ unfolding unit_disc_fix_iff_ounit_circle
	+ by auto
	+
	+lemma unit_disc_fix_moebius_comp [simp]:
	+ assumes "unit_disc_fix M1" and "unit_disc_fix M2"
	+ shows "unit_disc_fix (moebius_comp M1 M2)"
	+ using unit_disc_fix_moebius_add[OF assms]
	+ by simp
	+
	+lemma unit_disc_fix_moebius_uminus [simp]:
	+ assumes "unit_disc_fix M"
	+ shows "unit_disc_fix (-M)"
	+ using assms
	+ unfolding unit_disc_fix_iff_ounit_circle
	+ by (metis moebius_ocircline_comp_inv_left uminus_moebius_def)
	+
	+lemma unit_disc_fix_moebius_inv [simp]:
	+ assumes "unit_disc_fix M"
	+ shows "unit_disc_fix (moebius_inv M)"
	+ using unit_disc_fix_moebius_uminus[OF assms]
	+ by simp
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Rotations are unit disc preserving transformations\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+lemma unit_disc_fix_rotation [simp]:
	+ shows "unit_disc_fix (moebius_rotation \<phi>)"
	+ unfolding moebius_rotation_def moebius_similarity_def
	+ by (transfer, transfer, simp add: unitary11_gen_def mat_adj_def mat_cnj_def cis_mult)
	+
	+lemma moebius_rotation_unit_circle_fix [simp]:
	+ shows "moebius_pt (moebius_rotation \<phi>) u \<in> unit_circle_set \<longleftrightarrow> u \<in> unit_circle_set"
	+ using moebius_pt_moebius_inv_in_set unit_circle_fix_iff_unit_circle_set
	+ by fastforce
	+
	+lemma ex_rotation_mapping_u_to_positive_x_axis:
	+ assumes "u \<noteq> 0\<^sub>h" and "u \<noteq> \<infinity>\<^sub>h"
	+ shows "\<exists> \<phi>. moebius_pt (moebius_rotation \<phi>) u \<in> positive_x_axis"
	+proof-
	+ from assms obtain c where *: "u = of_complex c"
	+ using inf_or_of_complex
	+ by blast
	+ have "is_real (cis (- arg c) * c)" "Re (cis (-arg c) * c) > 0"
	+ using "*" assms is_real_rot_to_x_axis positive_rot_to_x_axis of_complex_zero_iff
	+ by blast+
	+ thus ?thesis
	+ using *
	+ by (rule_tac x="-arg c" in exI) (simp add: positive_x_axis_def circline_set_x_axis)
	+qed
	+
	+lemma ex_rotation_mapping_u_to_positive_y_axis:
	+ assumes "u \<noteq> 0\<^sub>h" and "u \<noteq> \<infinity>\<^sub>h"
	+ shows "\<exists> \<phi>. moebius_pt (moebius_rotation \<phi>) u \<in> positive_y_axis"
	+proof-
	+ from assms obtain c where *: "u = of_complex c"
	+ using inf_or_of_complex
	+ by blast
	+ have "is_imag (cis (pi/2 - arg c) * c)" "Im (cis (pi/2 - arg c) * c) > 0"
	+ using "*" assms is_real_rot_to_x_axis positive_rot_to_x_axis of_complex_zero_iff
	+ by - (simp, simp, simp add: field_simps)
	+ thus ?thesis
	+ using *
	+ by (rule_tac x="pi/2-arg c" in exI) (simp add: positive_y_axis_def circline_set_y_axis)
	+qed
	+
	+lemma wlog_rotation_to_positive_x_axis:
	+ assumes in_disc: "u \<in> unit_disc" and not_zero: "u \<noteq> 0\<^sub>h"
	+ assumes preserving: "\<And>\<phi> u. \<lbrakk>u \<in> unit_disc; u \<noteq> 0\<^sub>h; P (moebius_pt (moebius_rotation \<phi>) u)\<rbrakk> \<Longrightarrow> P u"
	+ assumes x_axis: "\<And>x. \<lbrakk>is_real x; 0 < Re x; Re x < 1\<rbrakk> \<Longrightarrow> P (of_complex x)"
	+ shows "P u"
	+proof-
	+ from in_disc obtain \<phi> where *:
	+ "moebius_pt (moebius_rotation \<phi>) u \<in> positive_x_axis"
	+ using ex_rotation_mapping_u_to_positive_x_axis[of u]
	+ using inf_notin_unit_disc not_zero
	+ by blast
	+ let ?Mu = "moebius_pt (moebius_rotation \<phi>) u"
	+ have "P ?Mu"
	+ proof-
	+ let ?x = "to_complex ?Mu"
	+ have "?Mu \<in> unit_disc" "?Mu \<noteq> 0\<^sub>h" "?Mu \<noteq> \<infinity>\<^sub>h"
	+ using \<open>u \<in> unit_disc\<close> \<open>u \<noteq> 0\<^sub>h\<close>
	+ by auto
	+ hence "is_real (to_complex ?Mu)" "0 < Re ?x" "Re ?x < 1"
	+ using *
	+ unfolding positive_x_axis_def circline_set_x_axis
	+ by (auto simp add: cmod_eq_Re)
	+ thus ?thesis
	+ using x_axis[of ?x] \<open>?Mu \<noteq> \<infinity>\<^sub>h\<close>
	+ by simp
	+ qed
	+ thus ?thesis
	+ using preserving[OF in_disc] not_zero
	+ by simp
	+qed
	+
	+lemma wlog_rotation_to_positive_x_axis':
	+ assumes not_zero: "u \<noteq> 0\<^sub>h" and not_inf: "u \<noteq> \<infinity>\<^sub>h"
	+ assumes preserving: "\<And>\<phi> u. \<lbrakk>u \<noteq> 0\<^sub>h; u \<noteq> \<infinity>\<^sub>h; P (moebius_pt (moebius_rotation \<phi>) u)\<rbrakk> \<Longrightarrow> P u"
	+ assumes x_axis: "\<And>x. \<lbrakk>is_real x; 0 < Re x\<rbrakk> \<Longrightarrow> P (of_complex x)"
	+ shows "P u"
	+proof-
	+ from not_zero and not_inf obtain \<phi> where *:
	+ "moebius_pt (moebius_rotation \<phi>) u \<in> positive_x_axis"
	+ using ex_rotation_mapping_u_to_positive_x_axis[of u]
	+ using inf_notin_unit_disc
	+ by blast
	+ let ?Mu = "moebius_pt (moebius_rotation \<phi>) u"
	+ have "P ?Mu"
	+ proof-
	+ let ?x = "to_complex ?Mu"
	+ have "?Mu \<noteq> 0\<^sub>h" "?Mu \<noteq> \<infinity>\<^sub>h"
	+ using \<open>u \<noteq> \<infinity>\<^sub>h\<close> \<open>u \<noteq> 0\<^sub>h\<close>
	+ by auto
	+ hence "is_real (to_complex ?Mu)" "0 < Re ?x"
	+ using *
	+ unfolding positive_x_axis_def circline_set_x_axis
	+ by (auto simp add: cmod_eq_Re)
	+ thus ?thesis
	+ using x_axis[of ?x] \<open>?Mu \<noteq> \<infinity>\<^sub>h\<close>
	+ by simp
	+ qed
	+ thus ?thesis
	+ using preserving[OF not_zero not_inf]
	+ by simp
	+qed
	+
	+lemma wlog_rotation_to_positive_y_axis:
	+ assumes in_disc: "u \<in> unit_disc" and not_zero: "u \<noteq> 0\<^sub>h"
	+ assumes preserving: "\<And>\<phi> u. \<lbrakk>u \<in> unit_disc; u \<noteq> 0\<^sub>h; P (moebius_pt (moebius_rotation \<phi>) u)\<rbrakk> \<Longrightarrow> P u"
	+ assumes y_axis: "\<And>x. \<lbrakk>is_imag x; 0 < Im x; Im x < 1\<rbrakk> \<Longrightarrow> P (of_complex x)"
	+ shows "P u"
	+proof-
	+ from in_disc and not_zero obtain \<phi> where *:
	+ "moebius_pt (moebius_rotation \<phi>) u \<in> positive_y_axis"
	+ using ex_rotation_mapping_u_to_positive_y_axis[of u]
	+ using inf_notin_unit_disc
	+ by blast
	+ let ?Mu = "moebius_pt (moebius_rotation \<phi>) u"
	+ have "P ?Mu"
	+ proof-
	+ let ?y = "to_complex ?Mu"
	+ have "?Mu \<in> unit_disc" "?Mu \<noteq> 0\<^sub>h" "?Mu \<noteq> \<infinity>\<^sub>h"
	+ using \<open>u \<in> unit_disc\<close> \<open>u \<noteq> 0\<^sub>h\<close>
	+ by auto
	+ hence "is_imag (to_complex ?Mu)" "0 < Im ?y" "Im ?y < 1"
	+ using *
	+ unfolding positive_y_axis_def circline_set_y_axis
	+ by (auto simp add: cmod_eq_Im)
	+ thus ?thesis
	+ using y_axis[of ?y] \<open>?Mu \<noteq> \<infinity>\<^sub>h\<close>
	+ by simp
	+ qed
	+ thus ?thesis
	+ using preserving[OF in_disc not_zero]
	+ by simp
	+qed
	+
	+(* ---------------------------------------------------------------------------- *)
	+subsection \<open>Blaschke factors are unit disc preserving transformations\<close>
	+(* ---------------------------------------------------------------------------- *)
	+
	+text \<open>For a given point $a$, Blaschke factor transformations are of the form $k \cdot
	+\left(\begin{array}{cc}1 & -a\\ -\overline{a} & 1\end{array}\right)$. It is a disc preserving
	+Möbius transformation that maps the point $a$ to zero (by the symmetry principle, it must map the
	+inverse point of $a$ to infinity).\<close>
	+
	+definition blaschke_cmat :: "complex \<Rightarrow> complex_mat" where
	+ [simp]: "blaschke_cmat a = (if cmod a \<noteq> 1 then (1, -a, -cnj a, 1) else eye)"
	+lift_definition blaschke_mmat :: "complex \<Rightarrow> moebius_mat" is blaschke_cmat
	+ by simp
	+lift_definition blaschke :: "complex \<Rightarrow> moebius" is blaschke_mmat
	+ done
	+
	+lemma blaschke_0_id [simp]: "blaschke 0 = id_moebius"
	+ by (transfer, transfer, simp)
	+
	+lemma blaschke_a_to_zero [simp]:
	+ assumes "cmod a \<noteq> 1"
	+ shows "moebius_pt (blaschke a) (of_complex a) = 0\<^sub>h"
	+ using assms
	+ by (transfer, transfer, simp)
	+
	+lemma blaschke_inv_a_inf [simp]:
	+ assumes "cmod a \<noteq> 1"
	+ shows "moebius_pt (blaschke a) (inversion (of_complex a)) = \<infinity>\<^sub>h"
	+ using assms
	+ unfolding inversion_def
	+ by (transfer, transfer) (simp add: vec_cnj_def, rule_tac x="1/(1 - a*cnj a)" in exI, simp)
	+
	+lemma blaschke_inf [simp]:
	+ assumes "cmod a < 1" and "a \<noteq> 0"
	+ shows "moebius_pt (blaschke a) \<infinity>\<^sub>h = of_complex (- 1 / cnj a)"
	+ using assms
	+ by (transfer, transfer, simp add: complex_mod_sqrt_Re_mult_cnj)
	+
	+lemma blaschke_0_minus_a [simp]:
	+ assumes "cmod a \<noteq> 1"
	+ shows "moebius_pt (blaschke a) 0\<^sub>h = ~\<^sub>h (of_complex a)"
	+ using assms
	+ by (transfer, transfer, simp)
	+
	+lemma blaschke_unit_circle_fix [simp]:
	+ assumes "cmod a \<noteq> 1"
	+ shows "unit_circle_fix (blaschke a)"
	+ using assms
	+ by (transfer, transfer) (simp add: unitary11_gen_def mat_adj_def mat_cnj_def)
	+
	+lemma blaschke_unit_disc_fix [simp]:
	+ assumes "cmod a < 1"
	+ shows "unit_disc_fix (blaschke a)"
	+ using assms
	+proof (transfer, transfer)
	+ fix a
	+ assume *: "cmod a < 1"
	+ show "unit_disc_fix_cmat (blaschke_cmat a)"
	+ proof (cases "a = 0")
	+ case True
	+ thus ?thesis
	+ by (simp add: unitary11_gen_def mat_adj_def mat_cnj_def)
	+ next
	+ case False
	+ hence "Re (a * cnj a) < 1"
	+ using *
	+ by (metis complex_mod_sqrt_Re_mult_cnj real_sqrt_lt_1_iff)
	+ hence "1 / Re (a * cnj a) > 1"
	+ using False
	+ by (smt complex_div_gt_0 less_divide_eq_1_pos one_complex.simps(1) right_inverse_eq)
	+ hence "Re (1 / (a * cnj a)) > 1"
	+ by (simp add: complex_is_Real_iff)
	+ thus ?thesis
	+ by (simp add: unitary11_gen_def mat_adj_def mat_cnj_def)
	+ qed
	+qed
	+
	+lemma blaschke_unit_circle_fix':
	+ assumes "cmod a \<noteq> 1"
	+ shows "moebius_circline (blaschke a) unit_circle = unit_circle"
	+ using assms
	+ using blaschke_unit_circle_fix unit_circle_fix_iff
	+ by simp
	+
	+lemma blaschke_ounit_circle_fix':
	+ assumes "cmod a < 1"
	+ shows "moebius_ocircline (blaschke a) ounit_circle = ounit_circle"
	+proof-
	+ have "Re (a * cnj a) < 1"
	+ using assms
	+ by (metis complex_mod_sqrt_Re_mult_cnj real_sqrt_lt_1_iff)
	+ thus ?thesis
	+ using assms
	+ using blaschke_unit_disc_fix unit_disc_fix_iff_ounit_circle
	+ by simp
	+qed
	+
	+lemma moebius_pt_blaschke [simp]:
	+ assumes "cmod a \<noteq> 1" and "z \<noteq> 1 / cnj a"
	+ shows "moebius_pt (blaschke a) (of_complex z) = of_complex ((z - a) / (1 - cnj a * z))"
	+ using assms
	+proof (cases "a = 0")
	+ case True
	+ thus ?thesis
	+ by auto
	+next
	+ case False
	+ thus ?thesis
	+ using assms
	+ apply (transfer, transfer)
	+ apply (simp add: complex_mod_sqrt_Re_mult_cnj)
	+ apply (rule_tac x="1 / (1 - cnj a * z)" in exI)
	+ apply (simp add: field_simps)
	+ done
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Blaschke factors for a real point $a$\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>If the point $a$ is real, the Blaschke factor preserve x-axis and the upper and the lower
	+halfplane.\<close>
	+
	+lemma blaschke_real_preserve_x_axis [simp]:
	+ assumes "is_real a" and "cmod a < 1"
	+ shows "moebius_pt (blaschke a) z \<in> circline_set x_axis \<longleftrightarrow> z \<in> circline_set x_axis"
	+proof (cases "a = 0")
	+ case True
	+ thus ?thesis
	+ by simp
	+next
	+ case False
	+ have "cmod a \<noteq> 1"
	+ using assms
	+ by linarith
	+ let ?a = "of_complex a"
	+ let ?i = "inversion ?a"
	+ let ?M = "moebius_pt (blaschke a)"
	+ have *: "?M ?a = 0\<^sub>h" "?M ?i = \<infinity>\<^sub>h" "?M 0\<^sub>h = of_complex (-a)"
	+ using \<open>cmod a \<noteq> 1\<close> blaschke_a_to_zero[of a] blaschke_inv_a_inf[of a] blaschke_0_minus_a[of a]
	+ by auto
	+ let ?Mx = "moebius_circline (blaschke a) x_axis"
	+ have "?a \<in> circline_set x_axis" "?i \<in> circline_set x_axis" "0\<^sub>h \<in> circline_set x_axis"
	+ using \<open>is_real a\<close> \<open>a \<noteq> 0\<close> eq_cnj_iff_real[of a]
	+ by auto
	+ hence "0\<^sub>h \<in> circline_set ?Mx" "\<infinity>\<^sub>h \<in> circline_set ?Mx" "of_complex (-a) \<in> circline_set ?Mx"
	+ using *
	+ apply -
	+ apply (force simp add: image_iff)+
	+ apply (simp add: image_iff, rule_tac x="0\<^sub>h" in bexI, simp_all)
	+ done
	+ moreover
	+ have "0\<^sub>h \<in> circline_set x_axis" "\<infinity>\<^sub>h \<in> circline_set x_axis" "of_complex (-a) \<in> circline_set x_axis"
	+ using \<open>is_real a\<close>
	+ by auto
	+ moreover
	+ have "of_complex (-a) \<noteq> 0\<^sub>h"
	+ using \<open>a \<noteq> 0\<close>
	+ by simp
	+ hence "0\<^sub>h \<noteq> of_complex (-a)"
	+ by metis
	+ hence "\<exists>!H. 0\<^sub>h \<in> circline_set H \<and> \<infinity>\<^sub>h \<in> circline_set H \<and> of_complex (- a) \<in> circline_set H"
	+ using unique_circline_set[of "0\<^sub>h" "\<infinity>\<^sub>h" "of_complex (-a)"] \<open>a \<noteq> 0\<close>
	+ by simp
	+ ultimately
	+ have "moebius_circline (blaschke a) x_axis = x_axis"
	+ by auto
	+ thus ?thesis
	+ by (metis circline_set_moebius_circline_iff)
	+qed
	+
	+lemma blaschke_real_preserve_sgn_Im [simp]:
	+ assumes "is_real a" and "cmod a < 1" and "z \<noteq> \<infinity>\<^sub>h" and "z \<noteq> inversion (of_complex a)"
	+ shows "sgn (Im (to_complex (moebius_pt (blaschke a) z))) = sgn (Im (to_complex z))"
	+proof (cases "a = 0")
	+ case True
	+ thus ?thesis
	+ by simp
	+next
	+ case False
	+ obtain z' where z': "z = of_complex z'"
	+ using inf_or_of_complex[of z] \<open>z \<noteq> \<infinity>\<^sub>h\<close>
	+ by auto
	+ have "z' \<noteq> 1 / cnj a"
	+ using assms z' \<open>a \<noteq> 0\<close>
	+ by (auto simp add: of_complex_inj)
	+ moreover
	+ have "a * cnj a \<noteq> 1"
	+ using \<open>cmod a < 1\<close>
	+ by auto (simp add: complex_mod_sqrt_Re_mult_cnj)
	+ moreover
	+ have "sgn (Im ((z' - a) / (1 - a * z'))) = sgn (Im z')"
	+ proof-
	+ have "a * z' \<noteq> 1"
	+ using \<open>is_real a\<close> \<open>z' \<noteq> 1 / cnj a\<close> \<open>a \<noteq> 0\<close> eq_cnj_iff_real[of a]
	+ by (simp add: field_simps)
	+ moreover
	+ have "Re (1 - a\<^sup>2) > 0"
	+ using \<open>is_real a\<close> \<open>cmod a < 1\<close>
	+ by (smt Re_power2 minus_complex.simps(1) norm_complex_def one_complex.simps(1) power2_less_0 real_sqrt_lt_1_iff)
	+ moreover
	+ have "Im ((z' - a) / (1 - a * z')) = Re (((1 - a\<^sup>2) * Im z') / (cmod (1 - a*z'))\<^sup>2)"
	+ proof-
	+ have "1 - a * cnj z' \<noteq> 0"
	+ using \<open>z' \<noteq> 1 / cnj a\<close>
	+ by (metis Im_complex_div_eq_0 complex_cnj_zero_iff diff_eq_diff_eq diff_numeral_special(9) eq_divide_imp is_real_div mult_not_zero one_complex.simps(2) zero_neq_one)
	+ hence "Im ((z' - a) / (1 - a * z')) = Im (((z' - a) * (1 - a * cnj z')) / ((1 - a * z') * cnj (1 - a * z')))"
	+ using \<open>is_real a\<close> eq_cnj_iff_real[of a]
	+ by simp
	+ also have "... = Im ((z' - a - a * z' * cnj z' + a\<^sup>2 * cnj z') / (cmod (1 - a*z'))\<^sup>2)"
	+ unfolding complex_mult_cnj_cmod
	+ by (simp add: power2_eq_square field_simps)
	+ finally show ?thesis
	+ using \<open>is_real a\<close>
	+ by (simp add: field_simps)
	+ qed
	+ moreover
	+ have "0 < (1 - (Re a)\<^sup>2) * Im z' / (cmod (1 - a * z'))\<^sup>2 \<Longrightarrow> Im z' > 0"
	+ using `is_real a` `0 < Re (1 - a\<^sup>2)`
	+ by (smt Re_power_real divide_le_0_iff minus_complex.simps(1) not_sum_power2_lt_zero one_complex.simps(1) zero_less_mult_pos)
	+ ultimately
	+ show ?thesis
	+ unfolding sgn_real_def
	+ using \<open>cmod a < 1\<close> \<open>a * z' \<noteq> 1\<close> \<open>is_real a\<close>
	+ by (auto simp add: cmod_eq_Re)
	+ qed
	+ ultimately
	+ show ?thesis
	+ using assms z' moebius_pt_blaschke[of a z'] \<open>is_real a\<close> eq_cnj_iff_real[of a]
	+ by simp
	+qed
	+
	+lemma blaschke_real_preserve_sgn_arg [simp]:
	+ assumes "is_real a" and "cmod a < 1" and "z \<notin> circline_set x_axis"
	+ shows "sgn (arg (to_complex (moebius_pt (blaschke a) z))) = sgn (arg (to_complex z))"
	+proof-
	+ have "z \<noteq> \<infinity>\<^sub>h"
	+ using assms
	+ using special_points_on_x_axis''(3) by blast
	+ moreover
	+ have "z \<noteq> inversion (of_complex a)"
	+ using assms
	+ by (metis calculation circline_equation_x_axis circline_set_x_axis_I conjugate_of_complex inversion_of_complex inversion_sym is_real_inversion o_apply of_complex_zero reciprocal_zero to_complex_of_complex)
	+ ultimately
	+ show ?thesis
	+ using blaschke_real_preserve_sgn_Im[OF assms(1) assms(2), of z]
	+ by (smt arg_Im_sgn assms(3) circline_set_x_axis_I norm_sgn of_complex_to_complex)
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Inverse Blaschke transform\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+definition inv_blaschke_cmat :: "complex \<Rightarrow> complex_mat" where
	+ [simp]: "inv_blaschke_cmat a = (if cmod a \<noteq> 1 then (1, a, cnj a, 1) else eye)"
	+lift_definition inv_blaschke_mmat :: "complex \<Rightarrow> moebius_mat" is inv_blaschke_cmat
	+ by simp
	+lift_definition inv_blaschke :: "complex \<Rightarrow> moebius" is inv_blaschke_mmat
	+ done
	+
	+lemma inv_blaschke_neg [simp]: "inv_blaschke a = blaschke (-a)"
	+ by (transfer, transfer) simp
	+
	+lemma inv_blaschke:
	+ assumes "cmod a \<noteq> 1"
	+ shows "blaschke a + inv_blaschke a = 0"
	+ apply simp
	+ apply (transfer, transfer)
	+ by auto (rule_tac x="1/(1 - a*cnj a)" in exI, simp)
	+
	+lemma ex_unit_disc_fix_mapping_u_to_zero:
	+ assumes "u \<in> unit_disc"
	+ shows "\<exists> M. unit_disc_fix M \<and> moebius_pt M u = 0\<^sub>h"
	+proof-
	+ from assms obtain c where *: "u = of_complex c"
	+ by (metis inf_notin_unit_disc inf_or_of_complex)
	+ hence "cmod c < 1"
	+ using assms unit_disc_iff_cmod_lt_1
	+ by simp
	+ thus ?thesis
	+ using *
	+ by (rule_tac x="blaschke c" in exI)
	+ (smt blaschke_a_to_zero blaschke_ounit_circle_fix' unit_disc_fix_iff_ounit_circle)
	+qed
	+
	+lemma wlog_zero:
	+ assumes in_disc: "u \<in> unit_disc"
	+ assumes preserving: "\<And> a u. \<lbrakk>u \<in> unit_disc; cmod a < 1; P (moebius_pt (blaschke a) u)\<rbrakk> \<Longrightarrow> P u"
	+ assumes zero: "P 0\<^sub>h"
	+ shows "P u"
	+proof-
	+ have *: "moebius_pt (blaschke (to_complex u)) u = 0\<^sub>h"
	+ by (smt blaschke_a_to_zero in_disc inf_notin_unit_disc of_complex_to_complex unit_disc_iff_cmod_lt_1)
	+ thus ?thesis
	+ using preserving[of u "to_complex u"] in_disc zero
	+ using inf_or_of_complex[of u]
	+ by auto
	+qed
	+
	+lemma wlog_real_zero:
	+ assumes in_disc: "u \<in> unit_disc" and real: "is_real (to_complex u)"
	+ assumes preserving: "\<And> a u. \<lbrakk>u \<in> unit_disc; is_real a; cmod a < 1; P (moebius_pt (blaschke a) u)\<rbrakk> \<Longrightarrow> P u"
	+ assumes zero: "P 0\<^sub>h"
	+ shows "P u"
	+proof-
	+ have *: "moebius_pt (blaschke (to_complex u)) u = 0\<^sub>h"
	+ by (smt blaschke_a_to_zero in_disc inf_notin_unit_disc of_complex_to_complex unit_disc_iff_cmod_lt_1)
	+ thus ?thesis
	+ using preserving[of u "to_complex u"] in_disc zero real
	+ using inf_or_of_complex[of u]
	+ by auto
	+qed
	+
	+lemma unit_disc_fix_transitive:
	+ assumes in_disc: "u \<in> unit_disc" and "u' \<in> unit_disc"
	+ shows "\<exists> M. unit_disc_fix M \<and> moebius_pt M u = u'"
	+proof-
	+ have "\<forall> u \<in> unit_disc. \<exists> M. unit_disc_fix M \<and> moebius_pt M u = u'" (is "?P u'")
	+ proof (rule wlog_zero)
	+ show "u' \<in> unit_disc" by fact
	+ next
	+ show "?P 0\<^sub>h"
	+ by (simp add: ex_unit_disc_fix_mapping_u_to_zero)
	+ next
	+ fix a u
	+ assume "cmod a < 1" and *: "?P (moebius_pt (blaschke a) u)"
	+ show "?P u"
	+ proof
	+ fix u'
	+ assume "u' \<in> unit_disc"
	+ then obtain M' where "unit_disc_fix M'" "moebius_pt M' u' = moebius_pt (blaschke a) u"
	+ using *
	+ by auto
	+ thus "\<exists>M. unit_disc_fix M \<and> moebius_pt M u' = u"
	+ using \<open>cmod a < 1\<close> blaschke_unit_disc_fix[of a]
	+ using unit_disc_fix_moebius_comp[of "- blaschke a" "M'"]
	+ using unit_disc_fix_moebius_inv[of "blaschke a"]
	+ by (rule_tac x="(- (blaschke a)) + M'" in exI, simp)
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms
	+ by auto
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Decomposition of unit disc preserving Möbius transforms\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Each transformation preserving unit disc can be decomposed to a rotation around the origin and
	+a Blaschke factors that maps a point within the unit disc to zero.\<close>
	+
	+lemma unit_disc_fix_decompose_blaschke_rotation:
	+ assumes "unit_disc_fix M"
	+ shows "\<exists> k \<phi>. cmod k < 1 \<and> M = moebius_rotation \<phi> + blaschke k"
	+ using assms
	+ unfolding moebius_rotation_def moebius_similarity_def
	+proof (simp, transfer, transfer)
	+ fix M
	+ assume *: "mat_det M \<noteq> 0" "unit_disc_fix_cmat M"
	+ then obtain k a b :: complex where
	+ *: "k \<noteq> 0" "mat_det (a, b, cnj b, cnj a) \<noteq> 0" "M = k \<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
	+ using unitary11_gen_iff[of M]
	+ by auto
	+ have "a \<noteq> 0"
	+ using * **
	+ by auto
	+ then obtain a' k' \<phi>
	+ where **: "k' \<noteq> 0 \<and> a' cnj a' \<noteq> 1 \<and> M = k' \<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) \<^sub>m\<^sub>m (1, - a', - cnj a', 1)"
	+ using ** unitary11_gen_cis_blaschke[of k M a b]
	+ by auto
	+ have "a' = 0 \<or> 1 < 1 / (cmod a')\<^sup>2"
	+ using * *** complex_mult_cnj_cmod[of a']
	+ by simp
	+ hence "cmod a' < 1"
	+ by (smt less_divide_eq_1_pos norm_zero one_less_power one_power2 pos2)
	+ thus "\<exists>k. cmod k < 1 \<and>
	+ (\<exists>\<phi>. moebius_cmat_eq M (moebius_comp_cmat (mk_moebius_cmat (cis \<phi>) 0 0 1) (blaschke_cmat k)))"
	+ using ***
	+ apply (rule_tac x=a' in exI)
	+ apply simp
	+ apply (rule_tac x=\<phi> in exI)
	+ apply simp
	+ apply (rule_tac x="1/k'" in exI)
	+ by auto
	+qed
	+
	+lemma wlog_unit_disc_fix:
	+ assumes "unit_disc_fix M"
	+ assumes b: "\<And> k. cmod k < 1 \<Longrightarrow> P (blaschke k)"
	+ assumes r: "\<And> \<phi>. P (moebius_rotation \<phi>)"
	+ assumes comp: "\<And>M1 M2. \<lbrakk>unit_disc_fix M1; P M1; unit_disc_fix M2; P M2\<rbrakk> \<Longrightarrow> P (M1 + M2)"
	+ shows "P M"
	+ using assms
	+ using unit_disc_fix_decompose_blaschke_rotation[OF assms(1)]
	+ using blaschke_unit_disc_fix
	+ by auto
	+
	+lemma ex_unit_disc_fix_to_zero_positive_x_axis:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "u \<noteq> v"
	+ shows "\<exists> M. unit_disc_fix M \<and>
	+ moebius_pt M u = 0\<^sub>h \<and> moebius_pt M v \<in> positive_x_axis"
	+proof-
	+ from assms obtain B where
	+ *: "unit_disc_fix B" "moebius_pt B u = 0\<^sub>h"
	+ using ex_unit_disc_fix_mapping_u_to_zero
	+ by blast
	+
	+ let ?v = "moebius_pt B v"
	+ have "?v \<in> unit_disc"
	+ using \<open>v \<in> unit_disc\<close> *
	+ by auto
	+ hence "?v \<noteq> \<infinity>\<^sub>h"
	+ using inf_notin_unit_disc by auto
	+ have "?v \<noteq> 0\<^sub>h"
	+ using \<open>u \<noteq> v\<close> *
	+ by (metis moebius_pt_invert)
	+
	+ obtain R where
	+ "unit_disc_fix R"
	+ "moebius_pt R 0\<^sub>h = 0\<^sub>h" "moebius_pt R ?v \<in> positive_x_axis"
	+ using ex_rotation_mapping_u_to_positive_x_axis[of ?v] \<open>?v \<noteq> 0\<^sub>h\<close> \<open>?v \<noteq> \<infinity>\<^sub>h\<close>
	+ using moebius_pt_rotation_inf_iff moebius_pt_moebius_rotation_zero unit_disc_fix_rotation
	+ by blast
	+ thus ?thesis
	+ using * moebius_comp[of R B, symmetric]
	+ using unit_disc_fix_moebius_comp
	+ by (rule_tac x="R + B" in exI) (simp add: comp_def)
	+qed
	+
	+lemma wlog_x_axis:
	+ assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc"
	+ assumes preserved: "\<And> M u v. \<lbrakk>unit_disc_fix M; u \<in> unit_disc; v \<in> unit_disc; P (moebius_pt M u) (moebius_pt M v)\<rbrakk> \<Longrightarrow> P u v"
	+ assumes axis: "\<And> x. \<lbrakk>is_real x; 0 \<le> Re x; Re x < 1\<rbrakk> \<Longrightarrow> P 0\<^sub>h (of_complex x)"
	+ shows "P u v"
	+proof (cases "u = v")
	+ case True
	+ have "P u u" (is "?Q u")
	+ proof (rule wlog_zero[where P="?Q"])
	+ show "u \<in> unit_disc"
	+ by fact
	+ next
	+ show "?Q 0\<^sub>h"
	+ using axis[of 0]
	+ by simp
	+ next
	+ fix a u
	+ assume "u \<in> unit_disc" "cmod a < 1" "?Q (moebius_pt (blaschke a) u)"
	+ thus "?Q u"
	+ using preserved[of "blaschke a" u u]
	+ using blaschke_unit_disc_fix[of a]
	+ by simp
	+ qed
	+ thus ?thesis
	+ using True
	+ by simp
	+next
	+ case False
	+ from in_disc obtain M where
	+ *: "unit_disc_fix M" "moebius_pt M u = 0\<^sub>h" "moebius_pt M v \<in> positive_x_axis"
	+ using ex_unit_disc_fix_to_zero_positive_x_axis False
	+ by auto
	+ then obtain x where **: "moebius_pt M v = of_complex x" "is_real x"
	+ unfolding positive_x_axis_def circline_set_x_axis
	+ by auto
	+ moreover
	+ have "of_complex x \<in> unit_disc"
	+ using \<open>unit_disc_fix M\<close> \<open>v \<in> unit_disc\<close> **
	+ using unit_disc_fix_discI
	+ by fastforce
	+ hence "0 < Re x" "Re x < 1"
	+ using \<open>moebius_pt M v \<in> positive_x_axis\<close> **
	+ by (auto simp add: positive_x_axis_def cmod_eq_Re)
	+ ultimately
	+ have "P 0\<^sub>h (of_complex x)"
	+ using \<open>is_real x\<close> axis
	+ by auto
	+ thus ?thesis
	+ using preserved[OF (1) assms(1-2)] (2) **(1)
	+ by simp
	+qed
	+
	+lemma wlog_positive_x_axis:
	+ assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ assumes preserved: "\<And> M u v. \<lbrakk>unit_disc_fix M; u \<in> unit_disc; v \<in> unit_disc; u \<noteq> v; P (moebius_pt M u) (moebius_pt M v)\<rbrakk> \<Longrightarrow> P u v"
	+ assumes axis: "\<And> x. \<lbrakk>is_real x; 0 < Re x; Re x < 1\<rbrakk> \<Longrightarrow> P 0\<^sub>h (of_complex x)"
	+ shows "P u v"
	+proof-
	+ have "u \<noteq> v \<longrightarrow> P u v" (is "?Q u v")
	+ proof (rule wlog_x_axis)
	+ show "u \<in> unit_disc" "v \<in> unit_disc"
	+ by fact+
	+ next
	+ fix M u v
	+ assume "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc"
	+ "?Q (moebius_pt M u) (moebius_pt M v)"
	+ thus "?Q u v"
	+ using preserved[of M u v]
	+ using moebius_pt_invert
	+ by blast
	+ next
	+ fix x
	+ assume "is_real x" "0 \<le> Re x" "Re x < 1"
	+ thus "?Q 0\<^sub>h (of_complex x)"
	+ using axis[of x] of_complex_zero_iff[of x] complex.expand[of x 0]
	+ by fastforce
	+ qed
	+ thus ?thesis
	+ using \<open>u \<noteq> v\<close>
	+ by simp
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>All functions that fix the unit disc\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>It can be proved that continuous functions that fix the unit disc are either actions of
	+Möbius transformations that fix the unit disc (homographies), or are compositions of actions of
	+Möbius transformations that fix the unit disc and the conjugation (antihomographies). We postulate
	+this as a definition, but it this characterisation could also be formally shown (we do not need this
	+for our further applications).\<close>
	+
	+definition unit_disc_fix_f where
	+ "unit_disc_fix_f f \<longleftrightarrow>
	+ (\<exists> M. unit_disc_fix M \<and> (f = moebius_pt M \<or> f = moebius_pt M \<circ> conjugate))"
	+
	+text \<open>Unit disc fixing functions really fix unit disc.\<close>
	+lemma unit_disc_fix_f_unit_disc:
	+ assumes "unit_disc_fix_f M"
	+ shows "M ` unit_disc = unit_disc"
	+ using assms
	+ unfolding unit_disc_fix_f_def
	+ using image_comp
	+ by force
	+
	+text \<open>Actions of unit disc fixing Möbius transformations (unit disc fixing homographies) are unit
	+disc fixing functions.\<close>
	+lemma unit_disc_fix_f_moebius_pt [simp]:
	+ assumes "unit_disc_fix M"
	+ shows "unit_disc_fix_f (moebius_pt M)"
	+ using assms
	+ unfolding unit_disc_fix_f_def
	+ by auto
	+
	+text \<open>Compositions of unit disc fixing Möbius transformations and conjugation (unit disc fixing
	+antihomographies) are unit disc fixing functions.\<close>
	+lemma unit_disc_fix_conjugate_moebius [simp]:
	+ assumes "unit_disc_fix M"
	+ shows "unit_disc_fix (conjugate_moebius M)"
	+proof-
	+ have "\<And>a aa ab b. \<lbrakk>1 < Re (a * b / (aa * ab)); \<not> 1 < Re (cnj a * cnj b / (cnj aa * cnj ab))\<rbrakk> \<Longrightarrow> aa = 0"
	+ by (metis cnj.simps(1) complex_cnj_divide complex_cnj_mult)
	+ thus ?thesis
	+ using assms
	+ by (transfer, transfer)
	+ (auto simp add: mat_cnj_def unitary11_gen_def mat_adj_def field_simps)
	+qed
	+
	+lemma unit_disc_fix_conjugate_comp_moebius [simp]:
	+ assumes "unit_disc_fix M"
	+ shows "unit_disc_fix_f (conjugate \<circ> moebius_pt M)"
	+ using assms
	+ apply (subst conjugate_moebius)
	+ apply (simp add: unit_disc_fix_f_def)
	+ apply (rule_tac x="conjugate_moebius M" in exI, simp)
	+ done
	+
	+
	+text \<open>Uniti disc fixing functions form a group under function composition.\<close>
	+
	+lemma unit_disc_fix_f_comp [simp]:
	+ assumes "unit_disc_fix_f f1" and "unit_disc_fix_f f2"
	+ shows "unit_disc_fix_f (f1 \<circ> f2)"
	+ using assms
	+ apply (subst (asm) unit_disc_fix_f_def)
	+ apply (subst (asm) unit_disc_fix_f_def)
	+proof safe
	+ fix M M'
	+ assume "unit_disc_fix M" "unit_disc_fix M'"
	+ thus "unit_disc_fix_f (moebius_pt M \<circ> moebius_pt M')"
	+ unfolding unit_disc_fix_f_def
	+ by (rule_tac x="M + M'" in exI) auto
	+next
	+ fix M M'
	+ assume "unit_disc_fix M" "unit_disc_fix M'"
	+ thus "unit_disc_fix_f (moebius_pt M \<circ> (moebius_pt M' \<circ> conjugate))"
	+ unfolding unit_disc_fix_f_def
	+ by (subst comp_assoc[symmetric])+
	+ (rule_tac x="M + M'" in exI, auto)
	+next
	+ fix M M'
	+ assume "unit_disc_fix M" "unit_disc_fix M'"
	+ thus "unit_disc_fix_f ((moebius_pt M \<circ> conjugate) \<circ> moebius_pt M')"
	+ unfolding unit_disc_fix_f_def
	+ by (subst comp_assoc, subst conjugate_moebius, subst comp_assoc[symmetric])+
	+ (rule_tac x="M + conjugate_moebius M'" in exI, auto)
	+next
	+ fix M M'
	+ assume "unit_disc_fix M" "unit_disc_fix M'"
	+ thus "unit_disc_fix_f ((moebius_pt M \<circ> conjugate) \<circ> (moebius_pt M' \<circ> conjugate))"
	+ apply (subst comp_assoc[symmetric], subst comp_assoc)
	+ apply (subst conjugate_moebius, subst comp_assoc, subst comp_assoc)
	+ apply (simp add: unit_disc_fix_f_def)
	+ apply (rule_tac x="M + conjugate_moebius M'" in exI, auto)
	+ done
	+qed
	+
	+lemma unit_disc_fix_f_inv:
	+ assumes "unit_disc_fix_f M"
	+ shows "unit_disc_fix_f (inv M)"
	+ using assms
	+ apply (subst (asm) unit_disc_fix_f_def)
	+proof safe
	+ fix M
	+ assume "unit_disc_fix M"
	+ have "inv (moebius_pt M) = moebius_pt (-M)"
	+ by (rule ext) (simp add: moebius_inv)
	+ thus "unit_disc_fix_f (inv (moebius_pt M))"
	+ using \<open>unit_disc_fix M\<close>
	+ unfolding unit_disc_fix_f_def
	+ by (rule_tac x="-M" in exI, simp)
	+next
	+ fix M
	+ assume "unit_disc_fix M"
	+ have "inv (moebius_pt M \<circ> conjugate) = conjugate \<circ> inv (moebius_pt M)"
	+ by (subst o_inv_distrib, simp_all)
	+ also have "... = conjugate \<circ> (moebius_pt (-M))"
	+ using moebius_inv
	+ by auto
	+ also have "... = moebius_pt (conjugate_moebius (-M)) \<circ> conjugate"
	+ by (simp add: conjugate_moebius)
	+ finally
	+ show "unit_disc_fix_f (inv (moebius_pt M \<circ> conjugate))"
	+ using \<open>unit_disc_fix M\<close>
	+ unfolding unit_disc_fix_f_def
	+ by (rule_tac x="conjugate_moebius (-M)" in exI, simp)
	+qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Action of unit disc fixing functions on circlines\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+definition unit_disc_fix_f_circline where
	+ "unit_disc_fix_f_circline f H =
	+ (if \<exists> M. unit_disc_fix M \<and> f = moebius_pt M then
	+ moebius_circline (THE M. unit_disc_fix M \<and> f = moebius_pt M) H
	+ else if \<exists> M. unit_disc_fix M \<and> f = moebius_pt M \<circ> conjugate then
	+ (moebius_circline (THE M. unit_disc_fix M \<and> f = moebius_pt M \<circ> conjugate) \<circ> conjugate_circline) H
	+ else
	+ H)"
	+
	+
	+lemma unique_moebius_pt_conjugate:
	+ assumes "moebius_pt M1 \<circ> conjugate = moebius_pt M2 \<circ> conjugate"
	+ shows "M1 = M2"
	+proof-
	+ from assms have "moebius_pt M1 = moebius_pt M2"
	+ using conjugate_conjugate_comp rewriteL_comp_comp2 by fastforce
	+ thus ?thesis
	+ using unique_moebius_pt
	+ by auto
	+qed
	+
	+lemma unit_disc_fix_f_circline_direct:
	+ assumes "unit_disc_fix M" and "f = moebius_pt M"
	+ shows "unit_disc_fix_f_circline f H = moebius_circline M H"
	+proof-
	+ have "M = (THE M. unit_disc_fix M \<and> f = moebius_pt M)"
	+ using assms
	+ using theI_unique[of "\<lambda> M. unit_disc_fix M \<and> f = moebius_pt M" M]
	+ using unique_moebius_pt[of M]
	+ by auto
	+ thus ?thesis
	+ using assms
	+ unfolding unit_disc_fix_f_circline_def
	+ by auto
	+qed
	+
	+lemma unit_disc_fix_f_circline_indirect:
	+ assumes "unit_disc_fix M" and "f = moebius_pt M \<circ> conjugate"
	+ shows "unit_disc_fix_f_circline f H = ((moebius_circline M) \<circ> conjugate_circline) H"
	+proof-
	+ have "\<not> (\<exists> M. unit_disc_fix M \<and> f = moebius_pt M)"
	+ using assms homography_antihomography_exclusive[of f]
	+ unfolding is_homography_def is_antihomography_def is_moebius_def
	+ by auto
	+ moreover
	+ have "M = (THE M. unit_disc_fix M \<and> f = moebius_pt M \<circ> conjugate)"
	+ using assms
	+ using theI_unique[of "\<lambda> M. unit_disc_fix M \<and> f = moebius_pt M \<circ> conjugate" M]
	+ using unique_moebius_pt_conjugate[of M]
	+ by auto
	+ ultimately
	+ show ?thesis
	+ using assms
	+ unfolding unit_disc_fix_f_circline_def
	+ by metis
	+qed
	+
	+text \<open>Disc automorphisms - it would be nice to show that there are no disc automorphisms other than
	+unit disc fixing homographies and antihomographies, but this part of the theory is not yet
	+developed.\<close>
	+
	+definition is_disc_aut where "is_disc_aut f \<longleftrightarrow> bij_betw f unit_disc unit_disc"
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Complex_Geometry/Unitary11_Matrices.thy b/thys/Complex_Geometry/Unitary11_Matrices.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Unitary11_Matrices.thy
	@@ -0,0 +1,607 @@
	+(* ----------------------------------------------------------------- *)
	+subsection \<open>Generalized unitary matrices with signature $(1, 1)$\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+theory Unitary11_Matrices
	+imports Matrices More_Complex
	+begin
	+
	+text \<open> When acting as Möbius transformations in the extended
	+complex plane, generalized complex $2\times 2$ unitary matrices fix
	+the imaginary unit circle (a Hermitean form with (2, 0) signature). We
	+now describe matrices that fix the ordinary unit circle (a Hermitean
	+form with (1, 1) signature, i.e., one positive and one negative
	+element on the diagonal). These are extremely important for further
	+formalization, since they will represent disc automorphisims and
	+isometries of the Poincar\'e disc. The development of this theory
	+follows the development of the theory of generalized unitary matrices.
	+\<close>
	+
	+text \<open>Unitary11 matrices\<close>
	+definition unitary11 where
	+ "unitary11 M \<longleftrightarrow> congruence M (1, 0, 0, -1) = (1, 0, 0, -1)"
	+
	+text \<open>Generalized unitary11 matrices\<close>
	+definition unitary11_gen where
	+ "unitary11_gen M \<longleftrightarrow> (\<exists> k. k \<noteq> 0 \<and> congruence M (1, 0, 0, -1) = k *\<^sub>s\<^sub>m (1, 0, 0, -1))"
	+
	+text \<open>Scalar can always be a non-zero real number\<close>
	+lemma unitary11_gen_real:
	+ shows "unitary11_gen M \<longleftrightarrow> (\<exists> k. k \<noteq> 0 \<and> congruence M (1, 0, 0, -1) = cor k *\<^sub>s\<^sub>m (1, 0, 0, -1))"
	+ unfolding unitary11_gen_def
	+proof (auto simp del: congruence_def)
	+ fix k
	+ assume "k \<noteq> 0" "congruence M (1, 0, 0, -1) = (k, 0, 0, - k)"
	+ hence "mat_det (congruence M (1, 0, 0, -1)) = -k*k"
	+ by simp
	+ moreover
	+ have "is_real (mat_det (congruence M (1, 0, 0, -1)))" "Re (mat_det (congruence M (1, 0, 0, -1))) \<le> 0"
	+ by (auto simp add: mat_det_adj)
	+ ultimately
	+ have "is_real (kk)" "Re (-kk) \<le> 0"
	+ by auto
	+ hence "is_real (kk) \<and> Re (k k) > 0"
	+ using \<open>k \<noteq> 0\<close>
	+ by (smt complex_eq_if_Re_eq mult_eq_0_iff mult_minus_left uminus_complex.simps(1) zero_complex.simps(1) zero_complex.simps(2))
	+ hence "is_real k"
	+ by auto
	+ thus "\<exists>ka. ka \<noteq> 0 \<and> k = cor ka"
	+ using \<open>k \<noteq> 0\<close>
	+ by (rule_tac x="Re k" in exI) (cases k, auto simp add: Complex_eq)
	+qed
	+
	+text \<open>Unitary11 matrices are special cases of generalized unitary 11 matrices\<close>
	+lemma unitary11_unitary11_gen [simp]:
	+ assumes "unitary11 M"
	+ shows "unitary11_gen M"
	+ using assms
	+ unfolding unitary11_gen_def unitary11_def
	+ by (rule_tac x="1" in exI, auto)
	+
	+text \<open>All generalized unitary11 matrices are regular\<close>
	+lemma unitary11_gen_regular:
	+ assumes "unitary11_gen M"
	+ shows "mat_det M \<noteq> 0"
	+proof-
	+ from assms obtain k where
	+ "k \<noteq> 0" "mat_adj M \<^sub>m\<^sub>m (1, 0, 0, -1) \<^sub>m\<^sub>m M = cor k *\<^sub>s\<^sub>m (1, 0, 0, -1)"
	+ unfolding unitary11_gen_real
	+ by auto
	+ hence "mat_det (mat_adj M \<^sub>m\<^sub>m (1, 0, 0, -1) \<^sub>m\<^sub>m M) \<noteq> 0"
	+ by simp
	+ thus ?thesis
	+ by (simp add: mat_det_adj)
	+qed
	+
	+lemmas unitary11_regular = unitary11_gen_regular[OF unitary11_unitary11_gen]
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>The characterization in terms of matrix elements\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Special matrices are those having the determinant equal to 1. We first give their characterization.\<close>
	+lemma unitary11_special:
	+ assumes "unitary11 M" and "mat_det M = 1"
	+ shows "\<exists> a b. M = (a, b, cnj b, cnj a)"
	+proof-
	+ have "mat_adj M \<^sub>m\<^sub>m (1, 0, 0, -1) = (1, 0, 0, -1) \<^sub>m\<^sub>m mat_inv M"
	+ using assms mult_mm_inv_r
	+ by (simp add: unitary11_def)
	+ thus ?thesis
	+ using assms(2)
	+ by (cases M) (simp add: mat_adj_def mat_cnj_def)
	+qed
	+
	+lemma unitary11_gen_special:
	+ assumes "unitary11_gen M" and "mat_det M = 1"
	+ shows "\<exists> a b. M = (a, b, cnj b, cnj a) \<or> M = (a, b, -cnj b, -cnj a)"
	+proof-
	+ from assms
	+ obtain k where : "k \<noteq> 0" "mat_adj M \<^sub>m\<^sub>m (1, 0, 0, -1) \<^sub>m\<^sub>m M = cor k \<^sub>s\<^sub>m (1, 0, 0, -1)"
	+ unfolding unitary11_gen_real
	+ by auto
	+ hence "mat_det (mat_adj M \<^sub>m\<^sub>m (1, 0, 0, -1) \<^sub>m\<^sub>m M) = - cor k* cor k"
	+ by simp
	+ hence "mat_det (mat_adj M \<^sub>m\<^sub>m M) = cor k cor k"
	+ by simp
	+ hence "cor k* cor k = 1"
	+ using assms(2)
	+ by (simp add: mat_det_adj)
	+ hence "cor k = 1 \<or> cor k = -1"
	+ using square_eq_1_iff[of "cor k"]
	+ by simp
	+ moreover
	+ have "mat_adj M \<^sub>m\<^sub>m (1, 0, 0, -1) = (cor k \<^sub>s\<^sub>m (1, 0, 0, -1)) *\<^sub>m\<^sub>m mat_inv M "
	+ using *
	+ using assms mult_mm_inv_r mat_eye_r mat_eye_l
	+ by auto
	+ moreover
	+ obtain a b c d where "M = (a, b, c, d)"
	+ by (cases M) auto
	+ ultimately
	+ have "M = (a, b, cnj b, cnj a) \<or> M = (a, b, -cnj b, -cnj a)"
	+ using assms(2)
	+ by (auto simp add: mat_adj_def mat_cnj_def)
	+ thus ?thesis
	+ by auto
	+qed
	+
	+text \<open>A characterization of all generalized unitary11 matrices\<close>
	+lemma unitary11_gen_iff':
	+ shows "unitary11_gen M \<longleftrightarrow>
	+ (\<exists> a b k. k \<noteq> 0 \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0 \<and>
	+ (M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<or>
	+ M = k \<^sub>s\<^sub>m (-1, 0, 0, 1) \<^sub>m\<^sub>m (a, b, cnj b, cnj a)))" (is "?lhs = ?rhs")
	+proof
	+ assume ?lhs
	+ obtain d where : "dd = mat_det M"
	+ using ex_complex_sqrt
	+ by auto
	+ hence "d \<noteq> 0"
	+ using unitary11_gen_regular[OF \<open>unitary11_gen M\<close>]
	+ by auto
	+ from \<open>unitary11_gen M\<close>
	+ obtain k where "k \<noteq> 0" "mat_adj M \<^sub>m\<^sub>m (1, 0, 0, -1) \<^sub>m\<^sub>m M = cor k *\<^sub>s\<^sub>m (1, 0, 0, -1)"
	+ unfolding unitary11_gen_real
	+ by auto
	+ hence "mat_adj ((1/d)\<^sub>s\<^sub>mM)\<^sub>m\<^sub>m (1, 0, 0, -1) \<^sub>m\<^sub>m ((1/d)\<^sub>s\<^sub>mM) = (cor k / (dcnj d)) \<^sub>s\<^sub>m (1, 0, 0, -1)"
	+ by simp
	+ moreover
	+ have "is_real (cor k / (d * cnj d))"
	+ by (metis complex_In_mult_cnj_zero div_reals Im_complex_of_real)
	+ hence "cor (Re (cor k / (d * cnj d))) = cor k / (d * cnj d)"
	+ by simp
	+ ultimately
	+ have "unitary11_gen ((1/d)*\<^sub>s\<^sub>mM)"
	+ unfolding unitary11_gen_real
	+ using \<open>d \<noteq> 0\<close> \<open>k \<noteq> 0\<close>
	+ using \<open>cor (Re (cor k / (d * cnj d))) = cor k / (d * cnj d)\<close>
	+ by (rule_tac x="Re (cor k / (d * cnj d))" in exI, auto, simp add: *)
	+ moreover
	+ have "mat_det ((1 / d) *\<^sub>s\<^sub>m M) = 1"
	+ using * unitary11_gen_regular[of M] \<open>unitary11_gen M\<close>
	+ by auto
	+ ultimately
	+ obtain a b where "(a, b, cnj b, cnj a) = (1 / d) \<^sub>s\<^sub>m M \<or> (a, b, -cnj b, -cnj a) = (1 / d) \<^sub>s\<^sub>m M"
	+ using unitary11_gen_special[of "(1 / d) *\<^sub>s\<^sub>m M"]
	+ by force
	+ thus ?rhs
	+ proof
	+ assume "(a, b, cnj b, cnj a) = (1 / d) *\<^sub>s\<^sub>m M"
	+ moreover
	+ hence "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
	+ using unitary11_gen_regular[OF \<open>unitary11_gen M\<close>] \<open>d \<noteq> 0\<close>
	+ by auto
	+ ultimately
	+ show ?rhs
	+ using \<open>d \<noteq> 0\<close>
	+ by (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="d" in exI, simp)
	+ next
	+ assume : "(a, b, -cnj b, -cnj a) = (1 / d) \<^sub>s\<^sub>m M"
	+ hence " (1 / d) *\<^sub>s\<^sub>m M = (a, b, -cnj b, -cnj a)"
	+ by simp
	+ hence "M = (a * d, b * d, - (d * cnj b), - (d * cnj a))"
	+ using \<open>d \<noteq> 0\<close>
	+ using mult_sm_inv_l[of "1/d" M "(a, b, -cnj b, -cnj a)", symmetric]
	+ by (simp add: field_simps)
	+ moreover
	+ have "mat_det (a, b, -cnj b, -cnj a) \<noteq> 0"
	+ using * unitary11_gen_regular[OF \<open>unitary11_gen M\<close>] \<open>d \<noteq> 0\<close>
	+ by auto
	+ ultimately
	+ show ?thesis
	+ using \<open>d \<noteq> 0\<close>
	+ by (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="-d" in exI) (simp add: field_simps)
	+ qed
	+next
	+ assume ?rhs
	+ then obtain a b k where "k \<noteq> 0" "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
	+ "M = k \<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<or> M = k \<^sub>s\<^sub>m (-1, 0, 0, 1) *\<^sub>m\<^sub>m (a, b, cnj b, cnj a)"
	+ by auto
	+ moreover
	+ let ?x = "cnj k * cnj a * (k * a) + - (cnj k * b * (k * cnj b))"
	+ have "?x = (kcnj k)(acnj a - bcnj b)"
	+ by (auto simp add: field_simps)
	+ hence "is_real ?x"
	+ by simp
	+ hence "cor (Re ?x) = ?x"
	+ by (rule complex_of_real_Re)
	+ moreover
	+ have "?x \<noteq> 0"
	+ using mult_eq_0_iff[of "cnj k * k" "(cnj a * a + - cnj b * b)"]
	+ using \<open>mat_det (a, b, cnj b, cnj a) \<noteq> 0\<close> \<open>k \<noteq> 0\<close>
	+ by (auto simp add: field_simps)
	+ hence "Re ?x \<noteq> 0"
	+ using \<open>is_real ?x\<close>
	+ by (metis calculation(4) of_real_0)
	+ ultimately
	+ show ?lhs
	+ unfolding unitary11_gen_real
	+ by (rule_tac x="Re ?x" in exI) (auto simp add: mat_adj_def mat_cnj_def)
	+qed
	+
	+text \<open>Another characterization of all generalized unitary11 matrices. They are products of
	+rotation and Blaschke factor matrices.\<close>
	+lemma unitary11_gen_cis_blaschke:
	+ assumes "k \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)" and
	+ "a \<noteq> 0" and "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
	+ shows "\<exists> k' \<phi> a'. k' \<noteq> 0 \<and> a' * cnj a' \<noteq> 1 \<and>
	+ M = k' \<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) \<^sub>m\<^sub>m (1, -a', -cnj a', 1)"
	+proof-
	+ have "a = cnj a * cis (2 * arg a)"
	+ using rcis_cmod_arg[of a] rcis_cnj[of a]
	+ using cis_rcis_eq rcis_mult
	+ by simp
	+ thus ?thesis
	+ using assms
	+ by (rule_tac x="kcnj a" in exI, rule_tac x="2arg a" in exI, rule_tac x="- b / a" in exI) (auto simp add: field_simps)
	+qed
	+
	+lemma unitary11_gen_cis_blaschke':
	+ assumes "k \<noteq> 0" and "M = k \<^sub>s\<^sub>m (-1, 0, 0, 1) \<^sub>m\<^sub>m (a, b, cnj b, cnj a)" and
	+ "a \<noteq> 0" and "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
	+ shows "\<exists> k' \<phi> a'. k' \<noteq> 0 \<and> a' * cnj a' \<noteq> 1 \<and>
	+ M = k' \<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) \<^sub>m\<^sub>m (1, -a', -cnj a', 1)"
	+proof-
	+ obtain k' \<phi> a' where : "k' \<noteq> 0" "k \<^sub>s\<^sub>m (a, b, cnj b, cnj a) = k' \<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) \<^sub>m\<^sub>m (1, -a', -cnj a', 1)" "a' * cnj a' \<noteq> 1"
	+ using unitary11_gen_cis_blaschke[OF \<open>k \<noteq> 0\<close> _ \<open>a \<noteq> 0\<close>] \<open>mat_det (a, b, cnj b, cnj a) \<noteq> 0\<close>
	+ by blast
	+ have "(cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (-1, 0, 0, 1) = (cis (\<phi> + pi), 0, 0, 1)"
	+ by (simp add: cis_def complex.corec Complex_eq)
	+ thus ?thesis
	+ using * \<open>M = k \<^sub>s\<^sub>m (-1, 0, 0, 1) \<^sub>m\<^sub>m (a, b, cnj b, cnj a)\<close>
	+ by (rule_tac x="k'" in exI, rule_tac x="\<phi> + pi" in exI, rule_tac x="a'" in exI, simp)
	+qed
	+
	+lemma unitary11_gen_cis_blaschke_rev:
	+ assumes "k' \<noteq> 0" and "M = k' \<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) \<^sub>m\<^sub>m (1, -a', -cnj a', 1)" and
	+ "a' * cnj a' \<noteq> 1"
	+ shows "\<exists> k a b. k \<noteq> 0 \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0 \<and>
	+ M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
	+ using assms
	+ apply (rule_tac x="k'cis(\<phi>/2)" in exI, rule_tac x="cis(\<phi>/2)" in exI, rule_tac x="-a'cis(\<phi>/2)" in exI)
	+ apply (simp add: cis_mult mult.commute mult.left_commute)
	+ done
	+
	+lemma unitary11_gen_cis_inversion:
	+ assumes "k \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (0, b, cnj b, 0)" and "b \<noteq> 0"
	+ shows "\<exists> k' \<phi>. k' \<noteq> 0 \<and>
	+ M = k' \<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) \<^sub>m\<^sub>m (0, 1, 1, 0)"
	+using assms
	+using rcis_cmod_arg[of b, symmetric] rcis_cnj[of b] cis_rcis_eq
	+by simp (rule_tac x="2*arg b" in exI, simp add: rcis_mult)
	+
	+lemma unitary11_gen_cis_inversion':
	+ assumes "k \<noteq> 0" and "M = k \<^sub>s\<^sub>m (-1, 0, 0, 1) \<^sub>m\<^sub>m (0, b, cnj b, 0)" and "b \<noteq> 0"
	+ shows "\<exists> k' \<phi>. k' \<noteq> 0 \<and>
	+ M = k' \<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) \<^sub>m\<^sub>m (0, 1, 1, 0)"
	+proof-
	+ obtain k' \<phi> where : "k' \<noteq> 0" "k \<^sub>s\<^sub>m (0, b, cnj b, 0) = k' \<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) \<^sub>m\<^sub>m (0, 1, 1, 0)"
	+ using unitary11_gen_cis_inversion[OF \<open>k \<noteq> 0\<close> _ \<open>b \<noteq> 0\<close>]
	+ by metis
	+ have "(cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (-1, 0, 0, 1) = (cis (\<phi> + pi), 0, 0, 1)"
	+ by (simp add: cis_def complex.corec Complex_eq)
	+ thus ?thesis
	+ using * \<open>M = k \<^sub>s\<^sub>m (-1, 0, 0, 1) \<^sub>m\<^sub>m (0, b, cnj b, 0)\<close>
	+ by (rule_tac x="k'" in exI, rule_tac x="\<phi> + pi" in exI, simp)
	+qed
	+
	+lemma unitary11_gen_cis_inversion_rev:
	+ assumes "k' \<noteq> 0" and "M = k' \<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) \<^sub>m\<^sub>m (0, 1, 1, 0)"
	+ shows "\<exists> k a b. k \<noteq> 0 \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0 \<and>
	+ M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
	+ using assms
	+ by (rule_tac x="k'*cis(\<phi>/2)" in exI, rule_tac x=0 in exI, rule_tac x="cis(\<phi>/2)" in exI) (simp add: cis_mult)
	+
	+text \<open>Another characterization of generalized unitary11 matrices\<close>
	+lemma unitary11_gen_iff:
	+ shows "unitary11_gen M \<longleftrightarrow>
	+ (\<exists> k a b. k \<noteq> 0 \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0 \<and>
	+ M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a))" (is "?lhs = ?rhs")
	+proof
	+ assume ?lhs
	+ then obtain a b k where : "k \<noteq> 0" "mat_det (a, b, cnj b, cnj a) \<noteq> 0" "M = k \<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<or> M = k \<^sub>s\<^sub>m (-1, 0, 0, 1) \<^sub>m\<^sub>m (a, b, cnj b, cnj a)"
	+ using unitary11_gen_iff'
	+ by auto
	+ show ?rhs
	+ proof (cases "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)")
	+ case True
	+ thus ?thesis
	+ using *
	+ by auto
	+ next
	+ case False
	+ hence *: "M = k \<^sub>s\<^sub>m (-1, 0, 0, 1) *\<^sub>m\<^sub>m (a, b, cnj b, cnj a)"
	+ using *
	+ by simp
	+ show ?thesis
	+ proof (cases "a = 0")
	+ case True
	+ hence "b \<noteq> 0"
	+ using *
	+ by auto
	+ show ?thesis
	+ using unitary11_gen_cis_inversion_rev[of _ M]
	+ using ** \<open>a = 0\<close>
	+ using unitary11_gen_cis_inversion'[OF \<open>k \<noteq> 0\<close> _ \<open>b \<noteq> 0\<close>, of M]
	+ by auto
	+ next
	+ case False
	+ show ?thesis
	+ using unitary11_gen_cis_blaschke_rev[of _ M]
	+ using **
	+ using unitary11_gen_cis_blaschke'[OF \<open>k \<noteq> 0\<close> _ \<open>a \<noteq> 0\<close>, of M b] \<open>mat_det (a, b, cnj b, cnj a) \<noteq> 0\<close>
	+ by blast
	+ qed
	+ qed
	+next
	+ assume ?rhs
	+ thus ?lhs
	+ using unitary11_gen_iff'
	+ by auto
	+qed
	+
	+lemma unitary11_iff:
	+ shows "unitary11 M \<longleftrightarrow>
	+ (\<exists> a b k. (cmod a)\<^sup>2 > (cmod b)\<^sup>2 \<and>
	+ (cmod k)\<^sup>2 = 1 / ((cmod a)\<^sup>2 - (cmod b)\<^sup>2) \<and>
	+ M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a))" (is "?lhs = ?rhs")
	+proof
	+ assume ?lhs
	+ obtain k a b where *:
	+ "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)""mat_det (a, b, cnj b, cnj a) \<noteq> 0" "k \<noteq> 0"
	+ using unitary11_gen_iff unitary11_unitary11_gen[OF \<open>unitary11 M\<close>]
	+ by auto
	+
	+ have md: "mat_det (a, b, cnj b, cnj a) = cor ((cmod a)\<^sup>2 - (cmod b)\<^sup>2)"
	+ by (auto simp add: complex_mult_cnj_cmod)
	+ hence **: "(cmod a)\<^sup>2 \<noteq> (cmod b)\<^sup>2"
	+ using \<open>mat_det (a, b, cnj b, cnj a) \<noteq> 0\<close>
	+ by auto
	+
	+ have "k * cnj k * mat_det (a, b, cnj b, cnj a) = 1"
	+ using \<open>M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)\<close>
	+ using \<open>unitary11 M\<close>
	+ unfolding unitary11_def
	+ by (auto simp add: mat_adj_def mat_cnj_def) (simp add: field_simps)
	+ hence **: "(cmod k)\<^sup>2 ((cmod a)\<^sup>2 - (cmod b)\<^sup>2) = 1"
	+ by (subst (asm) complex_mult_cnj_cmod, subst (asm) md, subst (asm) cor_mult[symmetric]) (metis of_real_1 of_real_eq_iff)
	+ hence "((cmod a)\<^sup>2 - (cmod b)\<^sup>2) = 1 / (cmod k)\<^sup>2"
	+ by (cases "k=0") (auto simp add: field_simps)
	+ hence "cmod a ^ 2 = cmod b ^ 2 + 1 / cmod k ^ 2"
	+ by simp
	+ thus ?rhs
	+ using \<open>M = k \<^sub>s\<^sub>m (a, b, cnj b, cnj a)\<close> * mat_eye_l
	+ by (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="k" in exI)
	+ (auto simp add: complex_mult_cnj_cmod intro!: )
	+next
	+ assume ?rhs
	+ then obtain a b k where "(cmod b)\<^sup>2 < (cmod a)\<^sup>2 \<and> (cmod k)\<^sup>2 = 1 / ((cmod a)\<^sup>2 - (cmod b)\<^sup>2) \<and> M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
	+ by auto
	+ moreover
	+ have "cnj k * cnj a * (k * a) + - (cnj k * b * (k * cnj b)) = (cor ((cmod k)\<^sup>2 * ((cmod a)\<^sup>2 - (cmod b)\<^sup>2)))"
	+ proof-
	+ have "cnj k * cnj a * (k * a) = cor ((cmod k)\<^sup>2 * (cmod a)\<^sup>2)"
	+ using complex_mult_cnj_cmod[of a] complex_mult_cnj_cmod[of k]
	+ by (auto simp add: field_simps)
	+ moreover
	+ have "cnj k * b * (k * cnj b) = cor ((cmod k)\<^sup>2 * (cmod b)\<^sup>2)"
	+ using complex_mult_cnj_cmod[of b, symmetric] complex_mult_cnj_cmod[of k]
	+ by (auto simp add: field_simps)
	+ ultimately
	+ show ?thesis
	+ by (auto simp add: field_simps)
	+ qed
	+ ultimately
	+ show ?lhs
	+ unfolding unitary11_def
	+ by (auto simp add: mat_adj_def mat_cnj_def field_simps)
	+qed
	+
	+(* ----------------------------------------------------------------- *)
	+subsubsection \<open>Group properties\<close>
	+(* ----------------------------------------------------------------- *)
	+
	+text \<open>Generalized unitary11 matrices form a group under
	+multiplication (it is sometimes denoted by $GU_{1, 1}(2,
	+\mathbb{C})$). The group is also closed under non-zero complex scalar
	+multiplication. Since these matrices are always regular, they form a
	+subgroup of general linear group (usually denoted by $GL(2,
	+\mathbb{C})$) of all regular matrices.\<close>
	+
	+lemma unitary11_gen_mult_sm:
	+ assumes "k \<noteq> 0" and "unitary11_gen M"
	+ shows "unitary11_gen (k *\<^sub>s\<^sub>m M)"
	+proof-
	+ have "k * cnj k = cor (Re (k * cnj k))"
	+ by (subst complex_of_real_Re) auto
	+ thus ?thesis
	+ using assms
	+ unfolding unitary11_gen_real
	+ by auto (rule_tac x="Re (kcnj k) ka" in exI, auto)
	+qed
	+
	+lemma unitary11_gen_div_sm:
	+ assumes "k \<noteq> 0" and "unitary11_gen (k *\<^sub>s\<^sub>m M)"
	+ shows "unitary11_gen M"
	+ using assms unitary11_gen_mult_sm[of "1/k" "k *\<^sub>s\<^sub>m M"]
	+ by simp
	+
	+
	+lemma unitary11_inv:
	+ assumes "k \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)" and "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
	+ shows "\<exists> k' a' b'. k' \<noteq> 0 \<and> mat_inv M = k' *\<^sub>s\<^sub>m (a', b', cnj b', cnj a') \<and> mat_det (a', b', cnj b', cnj a') \<noteq> 0"
	+ using assms
	+ by (subst assms, subst mat_inv_mult_sm[OF assms(1)])
	+ (rule_tac x="1/(k * mat_det (a, b, cnj b, cnj a))" in exI, rule_tac x="cnj a" in exI, rule_tac x="-b" in exI, simp add: field_simps)
	+
	+lemma unitary11_comp:
	+ assumes "k1 \<noteq> 0" and "M1 = k1 *\<^sub>s\<^sub>m (a1, b1, cnj b1, cnj a1)" and "mat_det (a1, b1, cnj b1, cnj a1) \<noteq> 0"
	+ "k2 \<noteq> 0" "M2 = k2 *\<^sub>s\<^sub>m (a2, b2, cnj b2, cnj a2)" "mat_det (a2, b2, cnj b2, cnj a2) \<noteq> 0"
	+ shows "\<exists> k a b. k \<noteq> 0 \<and> M1 \<^sub>m\<^sub>m M2 = k \<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0"
	+ using assms
	+ apply (rule_tac x="k1*k2" in exI)
	+ apply (rule_tac x="a1a2 + b1cnj b2" in exI)
	+ apply (rule_tac x="a1b2 + b1cnj a2" in exI)
	+proof (auto simp add: algebra_simps)
	+ assume : "a1 (a2 * (cnj a1 * cnj a2)) + b1 * (b2 * (cnj b1 * cnj b2)) =
	+ a1 * (b2 * (cnj a1 * cnj b2)) + a2 * (b1 * (cnj a2 * cnj b1))" and
	+ *: "a1cnj a1 \<noteq> b1 * cnj b1" "a2cnj a2 \<noteq> b2cnj b2"
	+ hence "(a1cnj a1)(a2cnj a2 - b2cnj b2) = (b1cnj b1)(a2cnj a2 - b2cnj b2)"
	+ by (simp add: field_simps)
	+ hence "a1cnj a1 = b1cnj b1"
	+ using **(2)
	+ by simp
	+ thus False
	+ using **(1)
	+ by simp
	+qed
	+
	+lemma unitary11_gen_mat_inv:
	+ assumes "unitary11_gen M" and "mat_det M \<noteq> 0"
	+ shows "unitary11_gen (mat_inv M)"
	+proof-
	+ obtain k a b where "k \<noteq> 0 \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0 \<and> M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
	+ using assms unitary11_gen_iff[of M]
	+ by auto
	+ then obtain k' a' b' where "k' \<noteq> 0 \<and> mat_inv M = k' *\<^sub>s\<^sub>m (a', b', cnj b', cnj a') \<and> mat_det (a', b', cnj b', cnj a') \<noteq> 0"
	+ using unitary11_inv [of k M a b]
	+ by auto
	+ thus ?thesis
	+ using unitary11_gen_iff[of "mat_inv M"]
	+ by auto
	+qed
	+
	+lemma unitary11_gen_comp:
	+ assumes "unitary11_gen M1" and "mat_det M1 \<noteq> 0" and "unitary11_gen M2" and "mat_det M2 \<noteq> 0"
	+ shows "unitary11_gen (M1 *\<^sub>m\<^sub>m M2)"
	+proof-
	+ from assms obtain k1 k2 a1 a2 b1 b2 where
	+ "k1 \<noteq> 0 \<and> mat_det (a1, b1, cnj b1, cnj a1) \<noteq> 0 \<and> M1 = k1 *\<^sub>s\<^sub>m (a1, b1, cnj b1, cnj a1)"
	+ "k2 \<noteq> 0 \<and> mat_det (a2, b2, cnj b2, cnj a2) \<noteq> 0 \<and> M2 = k2 *\<^sub>s\<^sub>m (a2, b2, cnj b2, cnj a2)"
	+ using unitary11_gen_iff[of M1] unitary11_gen_iff[of M2]
	+ by blast
	+ then obtain k a b where "k \<noteq> 0 \<and> M1 \<^sub>m\<^sub>m M2 = k \<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<and> mat_det (a, b, cnj b, cnj a) \<noteq> 0"
	+ using unitary11_comp[of k1 M1 a1 b1 k2 M2 a2 b2]
	+ by blast
	+ thus ?thesis
	+ using unitary11_gen_iff[of "M1 *\<^sub>m\<^sub>m M2"]
	+ by blast
	+qed
	+
	+text \<open>Classification into orientation-preserving and orientation-reversing matrices\<close>
	+lemma unitary11_sgn_det_orientation:
	+ assumes "k \<noteq> 0" and "mat_det (a, b, cnj b, cnj a) \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
	+ shows "\<exists> k'. sgn k' = sgn (Re (mat_det (a, b, cnj b, cnj a))) \<and> congruence M (1, 0, 0, -1) = cor k' *\<^sub>s\<^sub>m (1, 0, 0, -1)"
	+proof-
	+ let ?x = "cnj k * cnj a * (k * a) - (cnj k * b * (k * cnj b))"
	+ have : "?x = k cnj k * (a * cnj a - b * cnj b)"
	+ by (auto simp add: field_simps)
	+ hence "is_real ?x"
	+ by auto
	+ hence "cor (Re ?x) = ?x"
	+ by (rule complex_of_real_Re)
	+ moreover
	+ have "sgn (Re ?x) = sgn (Re (a * cnj a - b * cnj b))"
	+ proof-
	+ have : "Re ?x = (cmod k)\<^sup>2 Re (a * cnj a - b * cnj b)"
	+ by (subst *, subst complex_mult_cnj_cmod, subst Re_mult_real) (metis Im_complex_of_real, metis Re_complex_of_real)
	+ show ?thesis
	+ using \<open>k \<noteq> 0\<close>
	+ by (subst *) (simp add: sgn_mult)
	+ qed
	+ ultimately
	+ show ?thesis
	+ using assms(3)
	+ by (rule_tac x="Re ?x" in exI) (auto simp add: mat_adj_def mat_cnj_def)
	+qed
	+
	+lemma unitary11_sgn_det:
	+ assumes "k \<noteq> 0" and "mat_det (a, b, cnj b, cnj a) \<noteq> 0" and "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)" and "M = (A, B, C, D)"
	+ shows "sgn (Re (mat_det (a, b, cnj b, cnj a))) = (if b = 0 then 1 else sgn (Re ((AD)/(BC)) - 1))"
	+proof (cases "b = 0")
	+ case True
	+ thus ?thesis
	+ using assms
	+ by (simp only: mat_det.simps, subst complex_mult_cnj_cmod, subst minus_complex.sel, subst Re_complex_of_real, simp)
	+next
	+ case False
	+ from assms have : "A = k a" "B = k * b" "C = k * cnj b" "D = k * cnj a"
	+ by auto
	+ hence : "(AD)/(BC) = (acnj a)/(b*cnj b)"
	+ using \<open>k \<noteq> 0\<close>
	+ by simp
	+ show ?thesis
	+ using \<open>b \<noteq> 0\<close>
	+ apply (subst *, subst Re_divide_real, simp, simp)
	+ apply (simp only: mat_det.simps)
	+ apply (subst complex_mult_cnj_cmod)+
	+ apply ((subst Re_complex_of_real)+, subst minus_complex.sel, (subst Re_complex_of_real)+, simp add: field_simps sgn_if)
	+ done
	+qed
	+
	+lemma unitary11_orientation:
	+ assumes "unitary11_gen M" and "M = (A, B, C, D)"
	+ shows "\<exists> k'. sgn k' = sgn (if B = 0 then 1 else sgn (Re ((AD)/(BC)) - 1)) \<and> congruence M (1, 0, 0, -1) = cor k' *\<^sub>s\<^sub>m (1, 0, 0, -1)"
	+proof-
	+ from \<open>unitary11_gen M\<close>
	+ obtain k a b where : "k \<noteq> 0" "mat_det (a, b, cnj b, cnj a) \<noteq> 0" "M = k\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
	+ using unitary11_gen_iff[of M]
	+ by auto
	+ moreover
	+ have "b = 0 \<longleftrightarrow> B = 0"
	+ using \<open>M = (A, B, C, D)\<close> *
	+ by auto
	+ ultimately
	+ show ?thesis
	+ using unitary11_sgn_det_orientation[OF ] unitary11_sgn_det[OF \<open>M = (A, B, C, D)\<close>]
	+ by auto
	+qed
	+
	+lemma unitary11_sgn_det_orientation':
	+ assumes "congruence M (1, 0, 0, -1) = cor k' *\<^sub>s\<^sub>m (1, 0, 0, -1)" and "k' \<noteq> 0"
	+ shows "\<exists> a b k. k \<noteq> 0 \<and> M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a) \<and> sgn k' = sgn (Re (mat_det (a, b, cnj b, cnj a)))"
	+proof-
	+ obtain a b k where
	+ "k \<noteq> 0" "mat_det (a, b, cnj b, cnj a) \<noteq> 0" "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
	+ using assms
	+ using unitary11_gen_iff[of M]
	+ unfolding unitary11_gen_def
	+ by auto
	+ moreover
	+ have "sgn k' = sgn (Re (mat_det (a, b, cnj b, cnj a)))"
	+ proof-
	+ let ?x = "cnj k * cnj a * (k * a) - (cnj k * b * (k * cnj b))"
	+ have : "?x = k cnj k * (a * cnj a - b * cnj b)"
	+ by (auto simp add: field_simps)
	+ hence "is_real ?x"
	+ by auto
	+ hence "cor (Re ?x) = ?x"
	+ by (rule complex_of_real_Re)
	+
	+ have *: "sgn (Re ?x) = sgn (Re (a cnj a - b * cnj b))"
	+ proof-
	+ have : "Re ?x = (cmod k)\<^sup>2 Re (a * cnj a - b * cnj b)"
	+ by (subst *, subst complex_mult_cnj_cmod, subst Re_mult_real) (metis Im_complex_of_real, metis Re_complex_of_real)
	+ show ?thesis
	+ using \<open>k \<noteq> 0\<close>
	+ by (subst *) (simp add: sgn_mult)
	+ qed
	+ moreover
	+ have "?x = cor k'"
	+ using \<open>M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)\<close> assms
	+ by (simp add: mat_adj_def mat_cnj_def)
	+ hence "sgn (Re ?x) = sgn k'"
	+ using \<open>cor (Re ?x) = ?x\<close>
	+ unfolding complex_of_real_def
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by simp
	+ qed
	+ ultimately
	+ show ?thesis
	+ by (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="k" in exI) simp
	+qed
	+
	+end
	diff --git a/thys/Complex_Geometry/Unitary_Matrices.thy b/thys/Complex_Geometry/Unitary_Matrices.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/Unitary_Matrices.thy
	@@ -0,0 +1,330 @@
	+(* -------------------------------------------------------------------------- *)
	+subsection \<open>Generalized Unitary Matrices\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+theory Unitary_Matrices
	+imports Matrices More_Complex
	+begin
	+
	+text \<open>In this section (generalized) $2\times 2$ unitary matrices are introduced.\<close>
	+
	+text \<open>Unitary matrices\<close>
	+definition unitary where
	+ "unitary M \<longleftrightarrow> mat_adj M *\<^sub>m\<^sub>m M = eye"
	+
	+text \<open>Generalized unitary matrices\<close>
	+definition unitary_gen where
	+ "unitary_gen M \<longleftrightarrow>
	+ (\<exists> k::complex. k \<noteq> 0 \<and> mat_adj M \<^sub>m\<^sub>m M = k \<^sub>s\<^sub>m eye)"
	+
	+text \<open>Scalar can be always be a positive real\<close>
	+lemma unitary_gen_real:
	+ assumes "unitary_gen M"
	+ shows "(\<exists> k::real. k > 0 \<and> mat_adj M \<^sub>m\<^sub>m M = cor k \<^sub>s\<^sub>m eye)"
	+proof-
	+ obtain k where : "mat_adj M \<^sub>m\<^sub>m M = k *\<^sub>s\<^sub>m eye" "k \<noteq> 0"
	+ using assms
	+ by (auto simp add: unitary_gen_def)
	+ obtain a b c d where "M = (a, b, c, d)"
	+ by (cases M) auto
	+ hence "k = cor ((cmod a)\<^sup>2) + cor ((cmod c)\<^sup>2)"
	+ using *
	+ by (subst complex_mult_cnj_cmod[symmetric])+ (auto simp add: mat_adj_def mat_cnj_def)
	+ hence "is_real k \<and> Re k > 0"
	+ using \<open>k \<noteq> 0\<close>
	+ by (smt add_cancel_left_left arg_0_iff arg_complex_of_real_positive not_sum_power2_lt_zero of_real_0 plus_complex.simps(1) plus_complex.simps(2))
	+ thus ?thesis
	+ using *
	+ by (rule_tac x="Re k" in exI) simp
	+qed
	+
	+text \<open>Generalized unitary matrices can be factored into a product of a unitary matrix and a real
	+positive scalar multiple of the identity matrix\<close>
	+lemma unitary_gen_unitary:
	+ shows "unitary_gen M \<longleftrightarrow>
	+ (\<exists> k M'. k > 0 \<and> unitary M' \<and> M = (cor k \<^sub>s\<^sub>m eye) \<^sub>m\<^sub>m M')" (is "?lhs = ?rhs")
	+proof
	+ assume ?lhs
	+ then obtain k where : "k>0" "mat_adj M \<^sub>m\<^sub>m M = cor k *\<^sub>s\<^sub>m eye"
	+ using unitary_gen_real[of M]
	+ by auto
	+
	+ let ?k' = "cor (sqrt k)"
	+ have "?k' * cnj ?k' = cor k"
	+ using \<open>k > 0\<close>
	+ by simp
	+ moreover
	+ have "Re ?k' > 0" "is_real ?k'" "?k' \<noteq> 0"
	+ using \<open>k > 0\<close>
	+ by auto
	+ ultimately
	+ show ?rhs
	+ using * mat_eye_l
	+ unfolding unitary_gen_def unitary_def
	+ by (rule_tac x="Re ?k'" in exI) (rule_tac x="(1/?k')*\<^sub>s\<^sub>mM" in exI, simp add: mult_sm_mm[symmetric])
	+next
	+ assume ?rhs
	+ then obtain k M' where "k > 0" "unitary M'" "M = (cor k \<^sub>s\<^sub>m eye) \<^sub>m\<^sub>m M'"
	+ by blast
	+ hence "M = cor k *\<^sub>s\<^sub>m M'"
	+ using mult_sm_mm[of "cor k" eye M'] mat_eye_l
	+ by simp
	+ thus ?lhs
	+ using \<open>unitary M'\<close> \<open>k > 0\<close>
	+ by (simp add: unitary_gen_def unitary_def)
	+qed
	+
	+text \<open>When they represent Möbius transformations, eneralized unitary matrices fix the imaginary unit circle. Therefore, they
	+fix a Hermitean form with (2, 0) signature (two positive and no negative diagonal elements).\<close>
	+lemma unitary_gen_iff':
	+ shows "unitary_gen M \<longleftrightarrow>
	+ (\<exists> k::complex. k \<noteq> 0 \<and> congruence M (1, 0, 0, 1) = k *\<^sub>s\<^sub>m (1, 0, 0, 1))"
	+ unfolding unitary_gen_def
	+ using mat_eye_r
	+ by (auto simp add: mult.assoc)
	+
	+text \<open>Unitary matrices are special cases of general unitary matrices\<close>
	+lemma unitary_unitary_gen [simp]:
	+ assumes "unitary M"
	+ shows "unitary_gen M"
	+ using assms
	+ unfolding unitary_gen_def unitary_def
	+ by auto
	+
	+text \<open>Generalized unitary matrices are regular\<close>
	+lemma unitary_gen_regular:
	+ assumes "unitary_gen M"
	+ shows "mat_det M \<noteq> 0"
	+proof-
	+ from assms obtain k where
	+ "k \<noteq> 0" "mat_adj M \<^sub>m\<^sub>m M = k \<^sub>s\<^sub>m eye"
	+ unfolding unitary_gen_def
	+ by auto
	+ hence "mat_det (mat_adj M *\<^sub>m\<^sub>m M) \<noteq> 0"
	+ by simp
	+ thus ?thesis
	+ by (simp add: mat_det_adj)
	+qed
	+
	+lemmas unitary_regular = unitary_gen_regular[OF unitary_unitary_gen]
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>Group properties\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Generalized $2\times 2$ unitary matrices form a group under
	+multiplication (usually denoted by $GU(2, \mathbb{C})$). The group is closed
	+under non-zero complex scalar multiplication. Since these matrices are
	+always regular, they form a subgroup of general linear group (usually
	+denoted by $GL(2, \mathbb{C})$) of all regular matrices.\<close>
	+
	+lemma unitary_gen_scale [simp]:
	+ assumes "unitary_gen M" and "k \<noteq> 0"
	+ shows "unitary_gen (k *\<^sub>s\<^sub>m M)"
	+ using assms
	+ unfolding unitary_gen_def
	+ by auto
	+
	+lemma unitary_comp:
	+ assumes "unitary M1" and "unitary M2"
	+ shows "unitary (M1 *\<^sub>m\<^sub>m M2)"
	+ using assms
	+ unfolding unitary_def
	+ by (metis mat_adj_mult_mm mat_eye_l mult_mm_assoc)
	+
	+lemma unitary_gen_comp:
	+ assumes "unitary_gen M1" and "unitary_gen M2"
	+ shows "unitary_gen (M1 *\<^sub>m\<^sub>m M2)"
	+proof-
	+ obtain k1 k2 where : "k1 k2 \<noteq> 0" "mat_adj M1 \<^sub>m\<^sub>m M1 = k1 \<^sub>s\<^sub>m eye" "mat_adj M2 \<^sub>m\<^sub>m M2 = k2 \<^sub>s\<^sub>m eye"
	+ using assms
	+ unfolding unitary_gen_def
	+ by auto
	+ have "mat_adj M2 \<^sub>m\<^sub>m mat_adj M1 \<^sub>m\<^sub>m (M1 \<^sub>m\<^sub>m M2) = mat_adj M2 \<^sub>m\<^sub>m (mat_adj M1 \<^sub>m\<^sub>m M1) \<^sub>m\<^sub>m M2"
	+ by (auto simp add: mult_mm_assoc)
	+ also have "... = mat_adj M2 \<^sub>m\<^sub>m ((k1 \<^sub>s\<^sub>m eye) *\<^sub>m\<^sub>m M2)"
	+ using *
	+ by (auto simp add: mult_mm_assoc)
	+ also have "... = mat_adj M2 \<^sub>m\<^sub>m (k1 \<^sub>s\<^sub>m M2)"
	+ using mult_sm_eye_mm[of k1 M2]
	+ by (simp del: eye_def)
	+ also have "... = k1 \<^sub>s\<^sub>m (k2 \<^sub>s\<^sub>m eye)"
	+ using *
	+ by auto
	+ finally
	+ show ?thesis
	+ using *
	+ unfolding unitary_gen_def
	+ by (rule_tac x="k1*k2" in exI, simp del: eye_def)
	+qed
	+
	+lemma unitary_adj_eq_inv:
	+ shows "unitary M \<longleftrightarrow> mat_det M \<noteq> 0 \<and> mat_adj M = mat_inv M"
	+ using unitary_regular[of M] mult_mm_inv_r[of M "mat_adj M" eye] mat_eye_l[of "mat_inv M"] mat_inv_l[of M]
	+ unfolding unitary_def
	+ by - (rule, simp_all)
	+
	+lemma unitary_inv:
	+ assumes "unitary M"
	+ shows "unitary (mat_inv M)"
	+ using assms
	+ unfolding unitary_adj_eq_inv
	+ using mat_adj_inv[of M] mat_det_inv[of M]
	+ by simp
	+
	+lemma unitary_gen_inv:
	+ assumes "unitary_gen M"
	+ shows "unitary_gen (mat_inv M)"
	+proof-
	+ obtain k M' where "0 < k" "unitary M'" "M = cor k \<^sub>s\<^sub>m eye \<^sub>m\<^sub>m M'"
	+ using unitary_gen_unitary[of M] assms
	+ by blast
	+ hence "mat_inv M = cor (1/k) *\<^sub>s\<^sub>m mat_inv M'"
	+ by (metis mat_inv_mult_sm mult_sm_eye_mm norm_not_less_zero of_real_1 of_real_divide of_real_eq_0_iff sgn_1_neg sgn_greater sgn_if sgn_pos sgn_sgn)
	+ thus ?thesis
	+ using \<open>k > 0\<close> \<open>unitary M'\<close>
	+ by (subst unitary_gen_unitary[of "mat_inv M"]) (rule_tac x="1/k" in exI, rule_tac x="mat_inv M'" in exI, metis divide_pos_pos mult_sm_eye_mm unitary_inv zero_less_one)
	+ qed
	+
	+(* -------------------------------------------------------------------------- *)
	+subsubsection \<open>The characterization in terms of matrix elements\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text \<open>Special matrices are those having the determinant equal to 1. We first give their characterization.\<close>
	+lemma unitary_special:
	+ assumes "unitary M" and "mat_det M = 1"
	+ shows "\<exists> a b. M = (a, b, -cnj b, cnj a)"
	+proof-
	+ have "mat_adj M = mat_inv M"
	+ using assms mult_mm_inv_r[of M "mat_adj M" "eye"] mat_eye_r mat_eye_l
	+ by (simp add: unitary_def)
	+ thus ?thesis
	+ using \<open>mat_det M = 1\<close>
	+ by (cases M) (auto simp add: mat_adj_def mat_cnj_def)
	+qed
	+
	+lemma unitary_gen_special:
	+ assumes "unitary_gen M" and "mat_det M = 1"
	+ shows "\<exists> a b. M = (a, b, -cnj b, cnj a)"
	+proof-
	+ from assms
	+ obtain k where : "k \<noteq> 0" "mat_adj M \<^sub>m\<^sub>m M = k *\<^sub>s\<^sub>m eye"
	+ unfolding unitary_gen_def
	+ by auto
	+ hence "mat_det (mat_adj M \<^sub>m\<^sub>m M) = kk"
	+ by simp
	+ hence "k*k = 1"
	+ using assms(2)
	+ by (simp add: mat_det_adj)
	+ hence "k = 1 \<or> k = -1"
	+ using square_eq_1_iff[of k]
	+ by simp
	+ moreover
	+ have "mat_adj M = k *\<^sub>s\<^sub>m mat_inv M"
	+ using *
	+ using assms mult_mm_inv_r[of M "mat_adj M" "k *\<^sub>s\<^sub>m eye"] mat_eye_r mat_eye_l
	+ by simp (metis mult_sm_eye_mm *(2))
	+ moreover
	+ obtain a b c d where "M = (a, b, c, d)"
	+ by (cases M) auto
	+ ultimately
	+ have "M = (a, b, -cnj b, cnj a) \<or> M = (a, b, cnj b, -cnj a)"
	+ using assms(2)
	+ by (auto simp add: mat_adj_def mat_cnj_def)
	+ moreover
	+ have "Re (- (cor (cmod a))\<^sup>2 - (cor (cmod b))\<^sup>2) < 1"
	+ by (smt cmod_square complex_norm_square minus_complex.simps(1) of_real_power realpow_square_minus_le uminus_complex.simps(1))
	+ hence "- (cor (cmod a))\<^sup>2 - (cor (cmod b))\<^sup>2 \<noteq> 1"
	+ by force
	+ hence "M \<noteq> (a, b, cnj b, -cnj a)"
	+ using \<open>mat_det M = 1\<close> complex_mult_cnj_cmod[of a] complex_mult_cnj_cmod[of b]
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by auto
	+qed
	+
	+text \<open>A characterization of all generalized unitary matrices\<close>
	+lemma unitary_gen_iff:
	+ shows "unitary_gen M \<longleftrightarrow>
	+ (\<exists> a b k. k \<noteq> 0 \<and> mat_det (a, b, -cnj b, cnj a) \<noteq> 0 \<and>
	+ M = k *\<^sub>s\<^sub>m (a, b, -cnj b, cnj a))" (is "?lhs = ?rhs")
	+proof
	+ assume ?lhs
	+ obtain d where : "dd = mat_det M"
	+ using ex_complex_sqrt
	+ by auto
	+ hence "d \<noteq> 0"
	+ using unitary_gen_regular[OF \<open>unitary_gen M\<close>]
	+ by auto
	+ from \<open>unitary_gen M\<close>
	+ obtain k where "k \<noteq> 0" "mat_adj M \<^sub>m\<^sub>m M = k \<^sub>s\<^sub>m eye"
	+ unfolding unitary_gen_def
	+ by auto
	+ hence "mat_adj ((1/d)\<^sub>s\<^sub>mM) \<^sub>m\<^sub>m ((1/d)\<^sub>s\<^sub>mM) = (k / (dcnj d)) *\<^sub>s\<^sub>m eye"
	+ by simp
	+ obtain a b where "(a, b, - cnj b, cnj a) = (1 / d) *\<^sub>s\<^sub>m M"
	+ using unitary_gen_special[of "(1 / d) \<^sub>s\<^sub>m M"] \<open>unitary_gen M\<close> unitary_gen_regular[of M] \<open>d \<noteq> 0\<close>
	+ by force
	+ moreover
	+ hence "mat_det (a, b, - cnj b, cnj a) \<noteq> 0"
	+ using unitary_gen_regular[OF \<open>unitary_gen M\<close>] \<open>d \<noteq> 0\<close>
	+ by auto
	+ ultimately
	+ show ?rhs
	+ apply (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="d" in exI)
	+ using mult_sm_inv_l[of "1/d" M]
	+ by (auto simp add: field_simps)
	+next
	+ assume ?rhs
	+ then obtain a b k where "k \<noteq> 0 \<and> mat_det (a, b, - cnj b, cnj a) \<noteq> 0 \<and> M = k *\<^sub>s\<^sub>m (a, b, - cnj b, cnj a)"
	+ by auto
	+ thus ?lhs
	+ unfolding unitary_gen_def
	+ apply (auto simp add: mat_adj_def mat_cnj_def)
	+ using mult_eq_0_iff[of "cnj k * k" "cnj a * a + cnj b * b"]
	+ by (auto simp add: field_simps)
	+qed
	+
	+text \<open>A characterization of unitary matrices\<close>
	+
	+lemma unitary_iff:
	+ shows "unitary M \<longleftrightarrow>
	+ (\<exists> a b k. (cmod a)\<^sup>2 + (cmod b)\<^sup>2 \<noteq> 0 \<and>
	+ (cmod k)\<^sup>2 = 1 / ((cmod a)\<^sup>2 + (cmod b)\<^sup>2) \<and>
	+ M = k *\<^sub>s\<^sub>m (a, b, -cnj b, cnj a))" (is "?lhs = ?rhs")
	+proof
	+ assume ?lhs
	+ obtain k a b where : "M = k \<^sub>s\<^sub>m (a, b, -cnj b, cnj a)" "k \<noteq> 0" "mat_det (a, b, -cnj b, cnj a) \<noteq> 0"
	+ using unitary_gen_iff unitary_unitary_gen[OF \<open>unitary M\<close>]
	+ by auto
	+
	+ have md: "mat_det (a, b, -cnj b, cnj a) = cor ((cmod a)\<^sup>2 + (cmod b)\<^sup>2)"
	+ by (auto simp add: complex_mult_cnj_cmod)
	+
	+ have "k * cnj k * mat_det (a, b, -cnj b, cnj a) = 1"
	+ using \<open>unitary M\<close> *
	+ unfolding unitary_def
	+ by (auto simp add: mat_adj_def mat_cnj_def field_simps)
	+ hence "(cmod k)\<^sup>2 * ((cmod a)\<^sup>2 + (cmod b)\<^sup>2) = 1"
	+ by (subst (asm) complex_mult_cnj_cmod, subst (asm) md, subst (asm) cor_mult[symmetric]) (metis of_real_1 of_real_eq_iff)
	+ thus ?rhs
	+ using * mat_eye_l
	+ apply (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="k" in exI)
	+ apply (auto simp add: complex_mult_cnj_cmod)
	+ by (metis \<open>(cmod k)\<^sup>2 * ((cmod a)\<^sup>2 + (cmod b)\<^sup>2) = 1\<close> mult_eq_0_iff nonzero_eq_divide_eq zero_neq_one)
	+next
	+ assume ?rhs
	+ then obtain a b k where : "(cmod a)\<^sup>2 + (cmod b)\<^sup>2 \<noteq> 0" "(cmod k)\<^sup>2 = 1 / ((cmod a)\<^sup>2 + (cmod b)\<^sup>2)" "M = k \<^sub>s\<^sub>m (a, b, -cnj b, cnj a)"
	+ by auto
	+ have "(k * cnj k) * (a * cnj a) + (k * cnj k) * (b * cnj b) = 1"
	+ apply (subst complex_mult_cnj_cmod)+
	+ using *(1-2)
	+ by (metis (no_types, lifting) distrib_left nonzero_eq_divide_eq of_real_1 of_real_add of_real_divide of_real_eq_0_iff)
	+ thus ?lhs
	+ using *
	+ unfolding unitary_def
	+ by (simp add: mat_adj_def mat_cnj_def field_simps)
	+qed
	+
	+end
	diff --git a/thys/Complex_Geometry/document/root.bib b/thys/Complex_Geometry/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Complex_Geometry/document/root.bib
	@@ -0,0 +1,128 @@
	+@incollection{harrison05,
	+ title={A {HOL} theory of {Euclidean} space},
	+ author={Harrison, John},
	+ booktitle={Theorem proving in higher order logics},
	+ pages={114--129},
	+ year={2005},
	+ publisher={Springer}
	+}
	+
	+@incollection{wlog,
	+ title={Without loss of generality},
	+ author={Harrison, John},
	+ booktitle={Theorem Proving in Higher Order Logics},
	+ pages={43--59},
	+ year={2009},
	+ publisher={Springer}
	+}
	+
	+@book{schwerdtfeger,
	+ title={Geometry of complex numbers: circle geometry, {Moebius} transformation, non-euclidean geometry},
	+ author={Schwerdtfeger, Hans},
	+ year={1979},
	+ publisher={Courier Corporation}
	+}
	+
	+@book{needham,
	+ title={Visual complex analysis},
	+ author={Needham, Tristan},
	+ year={1998},
	+ publisher={Oxford University Press}
	+}
	+
	+@book{hilbert,
	+ title={Grundlagen der geometrie},
	+ author={Hilbert, David},
	+ year={2013},
	+ publisher={Springer-Verlag}
	+}
	+
	+@incollection{hilbert-coq,
	+ title={Higher-order intuitionistic formalization and proofs in {Hilbert’s} elementary geometry},
	+ author={Dehlinger, Christophe and Dufourd, Jean-Fran{\c{c}}ois and Schreck, Pascal},
	+ booktitle={Automated Deduction in Geometry},
	+ pages={306--323},
	+ year={2001},
	+ publisher={Springer}
	+}
	+
	+@incollection{hilbert-isabelle,
	+ title={Formalizing {Hilbert’s} {Grundlagen} in {Isabelle/Isar}},
	+ author={Meikle, Laura I and Fleuriot, Jacques D},
	+ booktitle={Theorem proving in higher order logics},
	+ pages={319--334},
	+ year={2003},
	+ publisher={Springer}
	+}
	+
	+@article{hilbert-scott,
	+ title={Mechanising {Hilbert’s} foundations of geometry in {Isabelle}},
	+ author={Scott, Phil},
	+ journal={Master's thesis, University of Edinburgh},
	+ year={2008},
	+ publisher={Citeseer}
	+}
	+
	+@book{tarski,
	+ author = {Wolfram Schwabhäuser and Wanda Szmielew and Alfred Tarski},
	+ title = {{Metamathematische Methoden in der Geometrie}},
	+ publisher = {Springer-Verlag},
	+ year = {1983},
	+ address = {Berlin}
	+}
	+
	+@incollection{narboux-tarski,
	+ title={Mechanical theorem proving in {Tarski’s} geometry},
	+ author={Narboux, Julien},
	+ booktitle={Automated Deduction in Geometry},
	+ pages={139--156},
	+ year={2007},
	+ publisher={Springer}
	+}
	+
	+@article{von-plato-formalization,
	+ title={Constructive geometry according to {Jan} von {Plato}},
	+ author={Kahn, Gilles},
	+ journal={Coq contribution. Coq},
	+ volume={5},
	+ pages={10},
	+ year={1995}
	+}
	+
	+@article{vonPlato,
	+ title={The axioms of constructive geometry},
	+ author={von Plato, Jan},
	+ journal={Annals of pure and applied logic},
	+ volume={76},
	+ number={2},
	+ pages={169--200},
	+ year={1995},
	+ publisher={Elsevier}
	+}
	+
	+@article{guilhot,
	+ title={Formalisation en {Coq} et visualisation d'un cours de g{\'e}om{\'e}trie pour le lyc{\'e}e.},
	+ author={Guilhot, Fr{\'e}d{\'e}rique},
	+ journal={Technique et Science informatiques},
	+ volume={24},
	+ number={9},
	+ pages={1113--1138},
	+ year={2005}
	+}
	+
	+@article{duprat2008,
	+ title={Une axiomatique de la g{\'e}om{\'e}trie plane en {Coq}},
	+ author={Duprat, Jean},
	+ journal={Actes des JFLA},
	+ pages={123--136},
	+ year={2008}
	+}
	+
	+@inproceedings{petrovic2012formalizing,
	+ title={Formalizing analytic geometries},
	+ author={Petrovic, Danijela and Maric, Filip},
	+ booktitle={This volume contains the papers presented at ADG 2012: The 9th International Workshop on Automated Deduction in Geometry, held on September 17--19, 2012 at the University of Edinburgh. The submissions were each reviewed by at least 3 program committee mem-bers, and the committee decided to accept 15 papers for the workshop. The},
	+ pages={107},
	+ year={2012}
	+}
	+
	diff --git a/thys/Complex_Geometry/document/root.tex b/thys/Complex_Geometry/document/root.tex
	new file mode 100755
	--- /dev/null
	+++ b/thys/Complex_Geometry/document/root.tex
	@@ -0,0 +1,73 @@
	+\documentclass[8pt,a4paper]{article}
	+\usepackage[margin=2cm]{geometry}
	+\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}
	+
	+\usepackage{amsmath}
	+
	+\begin{document}
	+
	+\title{Complex Geometry}
	+\author{Filip Mari\'c \and
	+ Danijela Simi\'c
	+ }
	+\maketitle
	+
	+\begin{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\"obius
	+transformations). Most objects are defined algebraically, but
	+correspondence with classical geometric definitions is shown.
	+\end{abstract}
	+
	+\tableofcontents
	+
	+% sane default for proof documents
	+\parindent 0pt\parskip 0.5ex
	+
	+% generated text of all theories
	+\input{session}
	+
	+% optional bibliography
	+\clearpage
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	+
	+%%% Local Variables:
	+%%% mode: latex
	+%%% TeX-master: t
	+%%% End:
	diff --git a/thys/Gauss_Sums/Complex_Roots_Of_Unity.thy b/thys/Gauss_Sums/Complex_Roots_Of_Unity.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Gauss_Sums/Complex_Roots_Of_Unity.thy
	@@ -0,0 +1,286 @@
	+(*
	+ File: Complex_Roots_Of_Unity.thy
	+ Authors: Rodrigo Raya, EPFL; Manuel Eberl, TUM
	+
	+ Complex roots of unity (exp(2i\<pi>/n)) and sums over them.
	+*)
	+theory Complex_Roots_Of_Unity
	+imports
	+ "HOL-Analysis.Analysis"
	+ Periodic_Arithmetic
	+begin
	+
	+section \<open>Complex roots of unity\<close>
	+
	+definition
	+ "unity_root k n = cis (2 * pi * of_int n / of_nat k)"
	+
	+lemma
	+ unity_root_k_0 [simp]: "unity_root k 0 = 1" and
	+ unity_root_0_n [simp]: "unity_root 0 n = 1"
	+ unfolding unity_root_def by simp+
	+
	+lemma unity_root_conv_exp:
	+ "unity_root k n = exp (of_real (2pin/k) * \<i>)"
	+ unfolding unity_root_def
	+ by (subst cis_conv_exp,subst mult.commute,blast)
	+
	+lemma unity_root_mod:
	+ "unity_root k (n mod int k) = unity_root k n"
	+proof (cases "k = 0")
	+ case True then show ?thesis by simp
	+next
	+ case False
	+ obtain q :: int where q_def: "n = q*k + (n mod k)"
	+ using div_mult_mod_eq[symmetric] by blast
	+ have "n / k = q + (n mod k) / k"
	+ proof (auto simp add: divide_simps False)
	+ have "real_of_int n = real_of_int (q*k + (n mod k))"
	+ using q_def by simp
	+ also have "\<dots> = real_of_int q * real k + real_of_int (n mod k)"
	+ using of_int_add of_int_mult by simp
	+ finally show "real_of_int n = real_of_int q * real k + real_of_int (n mod k)"
	+ by blast
	+ qed
	+ then have "(2pin/k) = 2piq + (2pi(n mod k)/k)"
	+ using False by (auto simp add: field_simps)
	+ then have "(2pin/k)\<i> = 2piq\<i> + (2pi(n mod k)/k)*\<i>" (is "?l = ?r1 + ?r2")
	+ by (auto simp add: algebra_simps)
	+ then have "exp ?l = exp ?r2"
	+ using exp_plus_2pin by (simp add: exp_add mult.commute)
	+ then show ?thesis
	+ using unity_root_def unity_root_conv_exp by simp
	+qed
	+
	+lemma unity_root_cong:
	+ assumes "[m = n] (mod int k)"
	+ shows "unity_root k m = unity_root k n"
	+proof -
	+ from assms have "m mod int k = n mod int k"
	+ by (auto simp: cong_def)
	+ hence "unity_root k (m mod int k) = unity_root k (n mod int k)"
	+ by simp
	+ thus ?thesis by (simp add: unity_root_mod)
	+qed
	+
	+lemma unity_root_mod_nat:
	+ "unity_root k (nat (n mod int k)) = unity_root k n"
	+proof (cases k)
	+ case (Suc l)
	+ then have "n mod int k \<ge> 0" by auto
	+ show ?thesis
	+ unfolding int_nat_eq
	+ by (simp add: \<open>n mod int k \<ge> 0\<close> unity_root_mod)
	+qed auto
	+
	+lemma unity_root_eqD:
	+ assumes gr: "k > 0"
	+ assumes eq: "unity_root k i = unity_root k j"
	+ shows "i mod k = j mod k"
	+proof -
	+ let ?arg1 = "(2pii/k)* \<i>"
	+ let ?arg2 = "(2pij/k)* \<i>"
	+ from eq unity_root_conv_exp have "exp ?arg1 = exp ?arg2" by simp
	+ from this exp_eq
	+ obtain n :: int where "?arg1 = ?arg2 +(2npi)*\<i>" by blast
	+ then have e1: "?arg1 - ?arg2 = 2npi*\<i>" by simp
	+ have e2: "?arg1 - ?arg2 = 2(i-j)(1/k)pi\<i>"
	+ by (auto simp add: algebra_simps)
	+ from e1 e2 have "2npi\<i> = 2(i-j)(1/k)pi*\<i>" by simp
	+ then have "2nkpi\<i> = 2(i-j)pi*\<i>"
	+ by (simp add: divide_simps \<open>k > 0\<close>)(simp add: field_simps)
	+ then have "2nk = 2*(i-j)"
	+ by (meson complex_i_not_zero mult_cancel_right of_int_eq_iff of_real_eq_iff pi_neq_zero)
	+ then have "n*k = i-j" by auto
	+ then show ?thesis by Groebner_Basis.algebra
	+qed
	+
	+lemma unity_root_eq_1_iff:
	+ fixes k n :: nat
	+ assumes "k > 0"
	+ shows "unity_root k n = 1 \<longleftrightarrow> k dvd n"
	+proof -
	+ have "unity_root k n = exp ((2pin/k) * \<i>)"
	+ by (simp add: unity_root_conv_exp)
	+ also have "exp ((2pin/k)* \<i>) = 1 \<longleftrightarrow> k dvd n"
	+ using complex_root_unity_eq_1[of k n] assms
	+ by (auto simp add: algebra_simps)
	+ finally show ?thesis by simp
	+qed
	+
	+lemma unity_root_pow: "unity_root k n ^ m = unity_root k (n * m)"
	+ using unity_root_def
	+ by (simp add: Complex.DeMoivre linordered_field_class.sign_simps(6) mult.commute)
	+
	+lemma unity_root_add: "unity_root k (m + n) = unity_root k m * unity_root k n"
	+ by (simp add: unity_root_conv_exp add_divide_distrib algebra_simps exp_add)
	+
	+lemma unity_root_uminus: "unity_root k (-m) = cnj (unity_root k m)"
	+ unfolding unity_root_conv_exp exp_cnj by simp
	+
	+lemma inverse_unity_root: "inverse (unity_root k m) = cnj (unity_root k m)"
	+ unfolding unity_root_conv_exp exp_cnj by (simp add: field_simps exp_minus)
	+
	+lemma unity_root_diff: "unity_root k (m - n) = unity_root k m * cnj (unity_root k n)"
	+ using unity_root_add[of k m "-n"] by (simp add: unity_root_uminus)
	+
	+lemma unity_root_eq_1_iff_int:
	+ fixes k :: nat and n :: int
	+ assumes "k > 0"
	+ shows "unity_root k n = 1 \<longleftrightarrow> k dvd n"
	+proof (cases "n \<ge> 0")
	+ case True
	+ obtain n' where "n = int n'"
	+ using zero_le_imp_eq_int[OF True] by blast
	+ then show ?thesis
	+ using unity_root_eq_1_iff[OF \<open>k > 0\<close>, of n'] of_nat_dvd_iff by blast
	+next
	+ case False
	+ then have "-n \<ge> 0" by auto
	+ have "unity_root k n = inverse (unity_root k (-n))"
	+ unfolding inverse_unity_root by (simp add: unity_root_uminus)
	+ then have "(unity_root k n = 1) = (unity_root k (-n) = 1)"
	+ by simp
	+ also have "(unity_root k (-n) = 1) = (k dvd (-n))"
	+ using unity_root_eq_1_iff[of k "nat (-n)",OF \<open>k > 0\<close>] False
	+ int_dvd_int_iff[of k "nat (-n)"] nat_0_le[OF \<open>-n \<ge> 0\<close>] by auto
	+ finally show ?thesis by simp
	+qed
	+
	+lemma unity_root_eq_1 [simp]: "int k dvd n \<Longrightarrow> unity_root k n = 1"
	+ by (cases "k = 0") (auto simp: unity_root_eq_1_iff_int)
	+
	+lemma unity_periodic_arithmetic:
	+ "periodic_arithmetic (unity_root k) k"
	+ unfolding periodic_arithmetic_def
	+proof
	+ fix n
	+ have "unity_root k (n + k) = unity_root k ((n+k) mod k)"
	+ using unity_root_mod[of k] zmod_int by presburger
	+ also have "unity_root k ((n+k) mod k) = unity_root k n"
	+ using unity_root_mod zmod_int by auto
	+ finally show "unity_root k (n + k) = unity_root k n" by simp
	+qed
	+
	+lemma unity_periodic_arithmetic_mult:
	+ "periodic_arithmetic (\<lambda>n. unity_root k (m * int n)) k"
	+ unfolding periodic_arithmetic_def
	+proof
	+ fix n
	+ have "unity_root k (m * int (n + k)) =
	+ unity_root k (mn + mk)"
	+ by (simp add: algebra_simps)
	+ also have "\<dots> = unity_root k (m*n)"
	+ using unity_root_mod[of k "m * int n"] unity_root_mod[of k "m * int n + m * int k"]
	+ mod_mult_self3 by presburger
	+ finally show "unity_root k (m * int (n + k)) =
	+ unity_root k (m * int n)" by simp
	+qed
	+
	+lemma unity_root_periodic_arithmetic_mult_minus:
	+ shows "periodic_arithmetic (\<lambda>i. unity_root k (-int i*int m)) k"
	+ unfolding periodic_arithmetic_def
	+proof
	+ fix n
	+ have "unity_root k (-(n + k) * m) = cnj (unity_root k (nm+km))"
	+ by (simp add: ring_distribs unity_root_diff unity_root_add unity_root_uminus)
	+ also have "\<dots> = cnj (unity_root k (n*m))"
	+ using mult_period[of "unity_root k" k m] unity_periodic_arithmetic[of k]
	+ unfolding periodic_arithmetic_def by presburger
	+ also have "\<dots> = unity_root k (-n*m)"
	+ by (simp add: unity_root_uminus)
	+ finally show "unity_root k (-(n + k) * m) = unity_root k (-n*m)"
	+ by simp
	+qed
	+
	+lemma unity_div:
	+ fixes a :: int and d :: nat
	+ assumes "d dvd k"
	+ shows "unity_root k (a*d) = unity_root (k div d) a"
	+proof -
	+ have 1: "(2pi(ad)/k) = (2pi*a)/(k div d)"
	+ using Suc_pred assms by (simp add: divide_simps, fastforce)
	+ have "unity_root k (ad) = exp ((2pi(ad)/k)* \<i>)"
	+ using unity_root_conv_exp by simp
	+ also have "\<dots> = exp (((2pia)/(k div d))* \<i>)"
	+ using 1 by simp
	+ also have "\<dots> = unity_root (k div d) a"
	+ using unity_root_conv_exp by simp
	+ finally show ?thesis by simp
	+qed
	+
	+lemma unity_div_num:
	+ assumes "k > 0" "d > 0" "d dvd k"
	+ shows "unity_root k (x * (k div d)) = unity_root d x"
	+ using assms dvd_div_mult_self unity_div by auto
	+
	+
	+section \<open>Geometric sums of roots of unity\<close>
	+
	+text\<open>
	+ Apostol calls these `geometric sums', which is a bit too generic. We therefore decided
	+ to refer to them as `sums of roots of unity'.
	+\<close>
	+definition "unity_root_sum k n = (\<Sum>m<k. unity_root k (n * of_nat m))"
	+
	+lemma unity_root_sum_0_left [simp]: "unity_root_sum 0 n = 0" and
	+ unity_root_sum_0_right [simp]: "k > 0 \<Longrightarrow> unity_root_sum k 0 = k"
	+ unfolding unity_root_sum_def by simp_all
	+
	+text \<open>Theorem 8.1\<close>
	+theorem unity_root_sum:
	+ fixes k :: nat and n :: int
	+ assumes gr: "k \<ge> 1"
	+ shows "k dvd n \<Longrightarrow> unity_root_sum k n = k"
	+ and "\<not>k dvd n \<Longrightarrow> unity_root_sum k n = 0"
	+proof -
	+ assume dvd: "k dvd n"
	+ let ?x = "unity_root k n"
	+ have unit: "?x = 1" using dvd gr unity_root_eq_1_iff_int by auto
	+ have exp: "?x^m = unity_root k (n*m)" for m using unity_root_pow by simp
	+ have "unity_root_sum k n = (\<Sum>m<k. unity_root k (n*m))"
	+ using unity_root_sum_def by simp
	+ also have "\<dots> = (\<Sum>m<k. ?x^m)" using exp by auto
	+ also have "\<dots> = (\<Sum>m<k. 1)" using unit by simp
	+ also have "\<dots> = k" using gr by (induction k, auto)
	+ finally show "unity_root_sum k n = k" by simp
	+next
	+ assume dvd: "\<not>k dvd n"
	+ let ?x = "unity_root k n"
	+ have "?x \<noteq> 1" using dvd gr unity_root_eq_1_iff_int by auto
	+ have "(?x^k - 1)/(?x - 1) = (\<Sum>m<k. ?x^m)"
	+ using geometric_sum[of ?x k, OF \<open>?x \<noteq> 1\<close>] by auto
	+ then have sum: "unity_root_sum k n = (?x^k - 1)/(?x - 1)"
	+ using unity_root_sum_def unity_root_pow by simp
	+ have "?x^k = 1"
	+ using gr unity_root_eq_1_iff_int unity_root_pow by simp
	+ then show "unity_root_sum k n = 0" using sum by auto
	+qed
	+
	+corollary unity_root_sum_periodic_arithmetic:
	+ "periodic_arithmetic (unity_root_sum k) k"
	+ unfolding periodic_arithmetic_def
	+proof
	+ fix n
	+ show "unity_root_sum k (n + k) = unity_root_sum k n"
	+ by (cases "k = 0"; cases "k dvd n") (auto simp add: unity_root_sum)
	+qed
	+
	+lemma unity_root_sum_nonzero_iff:
	+ fixes r :: int
	+ assumes "k \<ge> 1" and "r \<in> {-k<..<k}"
	+ shows "unity_root_sum k r \<noteq> 0 \<longleftrightarrow> r = 0"
	+proof
	+ assume "unity_root_sum k r \<noteq> 0"
	+ then have "k dvd r" using unity_root_sum assms by blast
	+ then show "r = 0" using assms(2)
	+ using dvd_imp_le_int by force
	+next
	+ assume "r = 0"
	+ then have "k dvd r" by auto
	+ then have "unity_root_sum k r = k"
	+ using assms(1) unity_root_sum by blast
	+ then show "unity_root_sum k r \<noteq> 0" using assms(1) by simp
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Gauss_Sums/Finite_Fourier_Series.thy b/thys/Gauss_Sums/Finite_Fourier_Series.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Gauss_Sums/Finite_Fourier_Series.thy
	@@ -0,0 +1,525 @@
	+(*
	+ File: Finite_Fourier_Series.thy
	+ Authors: Rodrigo Raya, EPFL; Manuel Eberl, TUM
	+
	+ Existence and uniqueness of finite Fourier series for periodic arithmetic functions
	+*)
	+section \<open>Finite Fourier series\<close>
	+theory Finite_Fourier_Series
	+imports
	+ Polynomial_Interpolation.Lagrange_Interpolation
	+ Complex_Roots_Of_Unity
	+begin
	+
	+subsection \<open>Auxiliary facts\<close>
	+
	+lemma lagrange_exists:
	+ assumes d: "distinct (map fst zs_ws)"
	+ defines e: "(p :: complex poly) \<equiv> lagrange_interpolation_poly zs_ws"
	+ shows "degree p \<le> (length zs_ws)-1"
	+ "(\<forall>x y. (x,y) \<in> set zs_ws \<longrightarrow> poly p x = y)"
	+proof -
	+ from e show "degree p \<le> (length zs_ws - 1)"
	+ using degree_lagrange_interpolation_poly by auto
	+ from e d have
	+ "poly p x = y" if "(x,y) \<in> set zs_ws" for x y
	+ using that lagrange_interpolation_poly by auto
	+ then show "(\<forall>x y. (x,y) \<in> set zs_ws \<longrightarrow> poly p x = y)"
	+ by auto
	+qed
	+
	+lemma lagrange_unique:
	+ assumes o: "length zs_ws > 0" (* implicit in theorem *)
	+ assumes d: "distinct (map fst zs_ws)"
	+ assumes 1: "degree (p1 :: complex poly) \<le> (length zs_ws)-1 \<and>
	+ (\<forall>x y. (x,y) \<in> set zs_ws \<longrightarrow> poly p1 x = y)"
	+ assumes 2: "degree (p2 :: complex poly) \<le> (length zs_ws)-1 \<and>
	+ (\<forall>x y. (x,y) \<in> set zs_ws \<longrightarrow> poly p2 x = y)"
	+ shows "p1 = p2"
	+proof (cases "p1 - p2 = 0")
	+ case True then show ?thesis by simp
	+next
	+ case False
	+ have "poly (p1-p2) x = 0" if "x \<in> set (map fst zs_ws)" for x
	+ using 1 2 that by (auto simp add: field_simps)
	+ from this d have 3: "card {x. poly (p1-p2) x = 0} \<ge> length zs_ws"
	+ proof (induction zs_ws)
	+ case Nil then show ?case by simp
	+ next
	+ case (Cons z_w zs_ws)
	+ from False poly_roots_finite
	+ have f: "finite {x. poly (p1 - p2) x = 0}" by blast
	+ from Cons have "set (map fst (z_w # zs_ws)) \<subseteq> {x. poly (p1 - p2) x = 0}"
	+ by auto
	+ then have i: "card (set (map fst (z_w # zs_ws))) \<le> card {x. poly (p1 - p2) x = 0}"
	+ using card_mono f by blast
	+ have "length (z_w # zs_ws) \<le> card (set (map fst (z_w # zs_ws)))"
	+ using Cons.prems(2) distinct_card by fastforce
	+ from this i show ?case by simp
	+ qed
	+ from 1 2 have 4: "degree (p1 - p2) \<le> (length zs_ws)-1"
	+ using degree_diff_le by blast
	+
	+ have "p1 - p2 = 0"
	+ proof (rule ccontr)
	+ assume "p1 - p2 \<noteq> 0"
	+ then have "card {x. poly (p1-p2) x = 0} \<le> degree (p1-p2)"
	+ using poly_roots_degree by blast
	+ then have "card {x. poly (p1-p2) x = 0} \<le> (length zs_ws)-1"
	+ using 4 by auto
	+ then show "False" using 3 o by linarith
	+ qed
	+ then show ?thesis by simp
	+qed
	+
	+text \<open>Theorem 8.2\<close>
	+corollary lagrange:
	+ assumes "length zs_ws > 0" "distinct (map fst zs_ws)"
	+ shows "(\<exists>! (p :: complex poly).
	+ degree p \<le> length zs_ws - 1 \<and>
	+ (\<forall>x y. (x, y) \<in> set zs_ws \<longrightarrow> poly p x = y))"
	+ using assms lagrange_exists lagrange_unique by blast
	+
	+lemma poly_altdef':
	+ assumes gr: "k \<ge> degree p"
	+ shows "poly p (z::complex) = (\<Sum>i\<le>k. coeff p i * z ^ i)"
	+proof -
	+ {fix z
	+ have 1: "poly p z = (\<Sum>i\<le>degree p. coeff p i * z ^ i)"
	+ using poly_altdef[of p z] by simp
	+ have "poly p z = (\<Sum>i\<le>k. coeff p i * z ^ i)"
	+ using gr
	+ proof (induction k)
	+ case 0 then show ?case by (simp add: poly_altdef)
	+ next
	+ case (Suc k)
	+ then show ?case
	+ using "1" le_degree not_less_eq_eq by fastforce
	+ qed}
	+ then show ?thesis using gr by blast
	+qed
	+
	+
	+subsection \<open>Definition and uniqueness\<close>
	+
	+definition finite_fourier_poly :: "complex list \<Rightarrow> complex poly" where
	+ "finite_fourier_poly ws =
	+ (let k = length ws
	+ in poly_of_list [1 / k * (\<Sum>m<k. ws ! m * unity_root k (-n*m)). n \<leftarrow> [0..<k]])"
	+
	+lemma degree_poly_of_list_le: "degree (poly_of_list ws) \<le> length ws - 1"
	+ by (intro degree_le) (auto simp: nth_default_def)
	+
	+lemma degree_finite_fourier_poly: "degree (finite_fourier_poly ws) \<le> length ws - 1"
	+ unfolding finite_fourier_poly_def
	+proof (subst Let_def)
	+ let ?unrolled_list = "
	+ (map (\<lambda>n. complex_of_real (1 / real (length ws)) *
	+ (\<Sum>m<length ws.
	+ ws ! m *
	+ unity_root (length ws) (- int n * int m)))
	+ [0..<length ws])"
	+ have "degree (poly_of_list ?unrolled_list) \<le> length ?unrolled_list - 1"
	+ by (rule degree_poly_of_list_le)
	+ also have "\<dots> = length [0..<length ws] - 1"
	+ using length_map by auto
	+ also have "\<dots> = length ws - 1" by auto
	+ finally show "degree (poly_of_list ?unrolled_list) \<le> length ws - 1" by blast
	+qed
	+
	+lemma coeff_finite_fourier_poly:
	+ assumes "n < length ws"
	+ defines "k \<equiv> length ws"
	+ shows "coeff (finite_fourier_poly ws) n =
	+ (1/k) * (\<Sum>m < k. ws ! m * unity_root k (-n*m))"
	+ using assms degree_finite_fourier_poly
	+ by (auto simp: Let_def nth_default_def finite_fourier_poly_def)
	+
	+lemma poly_finite_fourier_poly:
	+ fixes m :: int and ws
	+ defines "k \<equiv> length ws"
	+ assumes "m \<in> {0..<k}"
	+ assumes "m < length ws"
	+ shows "poly (finite_fourier_poly ws) (unity_root k m) = ws ! (nat m)"
	+proof -
	+ have "k > 0" using assms by auto
	+
	+ have distr: "
	+ (\<Sum>j<length ws. ws ! j * unity_root k (-ij))(unity_root k (m*i)) =
	+ (\<Sum>j<length ws. ws ! j * unity_root k (-ij)(unity_root k (m*i)))"
	+ for i
	+ using sum_distrib_right[of "\<lambda>j. ws ! j * unity_root k (-i*j)"
	+ "{..<k}" "(unity_root k (m*i))"]
	+ using k_def by blast
	+
	+ {fix j i :: nat
	+ have "unity_root k (-ij)(unity_root k (mi)) = unity_root k (-ij+m*i)"
	+ by (simp add: unity_root_diff unity_root_uminus field_simps)
	+ also have "\<dots> = unity_root k (i*(m-j))"
	+ by (simp add: algebra_simps)
	+ finally have "unity_root k (-ij)(unity_root k (mi)) = unity_root k (i(m-j))"
	+ by simp
	+ then have "ws ! j * unity_root k (-ij)(unity_root k (m*i)) =
	+ ws ! j * unity_root k (i*(m-j))"
	+ by auto
	+ } note prod = this
	+
	+ have zeros:
	+ "(unity_root_sum k (m-j) \<noteq> 0 \<longleftrightarrow> m = j)
	+ " if "j \<ge> 0 \<and> j < k" for j
	+ using k_def that assms unity_root_sum_nonzero_iff[of _ "m-j"] by simp
	+ then have sum_eq:
	+ "(\<Sum>j\<le>k-1. ws ! j * unity_root_sum k (m-j)) =
	+ (\<Sum>j\<in>{nat m}. ws ! j * unity_root_sum k (m-j))"
	+ using assms(2) by (intro sum.mono_neutral_right,auto)
	+
	+ have "poly (finite_fourier_poly ws) (unity_root k m) =
	+ (\<Sum>i\<le>k-1. coeff (finite_fourier_poly ws) i * (unity_root k m) ^ i)"
	+ using degree_finite_fourier_poly[of ws] k_def
	+ poly_altdef'[of "finite_fourier_poly ws" "k-1" "unity_root k m"] by blast
	+ also have "\<dots> = (\<Sum>i<k. coeff (finite_fourier_poly ws) i * (unity_root k m) ^ i)"
	+ using assms(2) by (intro sum.cong) auto
	+ also have "\<dots> = (\<Sum>i<k. 1 / k *
	+ (\<Sum>j<k. ws ! j * unity_root k (-ij)) (unity_root k m) ^ i)"
	+ using coeff_finite_fourier_poly[of _ ws] k_def by auto
	+ also have "\<dots> = (\<Sum>i<k. 1 / k *
	+ (\<Sum>j<k. ws ! j * unity_root k (-ij))(unity_root k (m*i)))"
	+ using unity_root_pow by auto
	+ also have "\<dots> = (\<Sum>i<k. 1 / k *
	+ (\<Sum>j<k. ws ! j * unity_root k (-ij)(unity_root k (m*i))))"
	+ using distr k_def by simp
	+ also have "\<dots> = (\<Sum>i<k. 1 / k *
	+ (\<Sum>j<k. ws ! j * unity_root k (i*(m-j))))"
	+ using prod by presburger
	+ also have "\<dots> = 1 / k * (\<Sum>i<k.
	+ (\<Sum>j<k. ws ! j * unity_root k (i*(m-j))))"
	+ by (simp add: sum_distrib_left)
	+ also have "\<dots> = 1 / k * (\<Sum>j<k.
	+ (\<Sum>i<k. ws ! j * unity_root k (i*(m-j))))"
	+ using sum.swap by fastforce
	+ also have "\<dots> = 1 / k * (\<Sum>j<k. ws ! j * (\<Sum>i<k. unity_root k (i*(m-j))))"
	+ by (simp add: vector_space_over_itself.scale_sum_right)
	+ also have "\<dots> = 1 / k * (\<Sum>j<k. ws ! j * unity_root_sum k (m-j))"
	+ unfolding unity_root_sum_def by (simp add: algebra_simps)
	+ also have "(\<Sum>j<k. ws ! j * unity_root_sum k (m-j)) = (\<Sum>j\<le>k-1. ws ! j * unity_root_sum k (m-j))"
	+ using \<open>k > 0\<close> by (intro sum.cong) auto
	+ also have "\<dots> = (\<Sum>j\<in>{nat m}. ws ! j * unity_root_sum k (m-j))"
	+ using sum_eq .
	+ also have "\<dots> = ws ! (nat m) * k"
	+ using assms(2) by (auto simp: algebra_simps)
	+ finally have "poly (finite_fourier_poly ws) (unity_root k m) = ws ! (nat m)"
	+ using assms(2) by auto
	+ then show ?thesis by simp
	+qed
	+
	+text \<open>Theorem 8.3\<close>
	+theorem finite_fourier_poly_unique:
	+ assumes "length ws > 0"
	+ defines "k \<equiv> length ws"
	+ assumes "(degree p \<le> k - 1)"
	+ assumes "(\<forall>m \<le> k-1. (ws ! m) = poly p (unity_root k m))"
	+ shows "p = finite_fourier_poly ws"
	+proof -
	+ let ?z = "map (\<lambda>m. unity_root k m) [0..<k]"
	+ have k: "k > 0" using assms by auto
	+ from k have d1: "distinct ?z"
	+ unfolding distinct_conv_nth using unity_root_eqD[OF k] by force
	+ let ?zs_ws = "zip ?z ws"
	+ from d1 k_def have d2: "distinct (map fst ?zs_ws)" by simp
	+ have l2: "length ?zs_ws > 0" using assms(1) k_def by auto
	+ have l3: "length ?zs_ws = k" by (simp add: k_def)
	+
	+ from degree_finite_fourier_poly have degree: "degree (finite_fourier_poly ws) \<le> k - 1"
	+ using k_def by simp
	+
	+ have interp: "poly (finite_fourier_poly ws) x = y"
	+ if "(x, y) \<in> set ?zs_ws" for x y
	+ proof -
	+ from that obtain n where "
	+ x = map (unity_root k \<circ> int) [0..<k] ! n \<and>
	+ y = ws ! n \<and>
	+ n < length ws"
	+ using in_set_zip[of "(x,y)" "(map (unity_root k) (map int [0..<k]))" ws]
	+ by auto
	+ then have "
	+ x = unity_root k (int n) \<and>
	+ y = ws ! n \<and>
	+ n < length ws"
	+ using nth_map[of n "[0..<k]" "unity_root k \<circ> int" ] k_def by simp
	+ thus "poly (finite_fourier_poly ws) x = y"
	+ by (simp add: poly_finite_fourier_poly k_def)
	+ qed
	+
	+ have interp_p: "poly p x = y" if "(x,y) \<in> set ?zs_ws" for x y
	+ proof -
	+ from that obtain n where "
	+ x = map (unity_root k \<circ> int) [0..<k] ! n \<and>
	+ y = ws ! n \<and>
	+ n < length ws"
	+ using in_set_zip[of "(x,y)" "(map (unity_root k) (map int [0..<k]))" ws]
	+ by auto
	+ then have rw: "x = unity_root k (int n)" "y = ws ! n" "n < length ws"
	+ using nth_map[of n "[0..<k]" "unity_root k \<circ> int" ] k_def by simp+
	+ show "poly p x = y"
	+ unfolding rw(1,2) using assms(4) rw(3) k_def by simp
	+ qed
	+
	+ from lagrange_unique[of _ p "finite_fourier_poly ws"] d2 l2
	+ have l: "
	+ degree p \<le> k - 1 \<and>
	+ (\<forall>x y. (x, y) \<in> set ?zs_ws \<longrightarrow> poly p x = y) \<Longrightarrow>
	+ degree (finite_fourier_poly ws) \<le> k - 1 \<and>
	+ (\<forall>x y. (x, y) \<in> set ?zs_ws \<longrightarrow> poly (finite_fourier_poly ws) x = y) \<Longrightarrow>
	+ p = (finite_fourier_poly ws)"
	+ using l3 by fastforce
	+ from assms degree interp interp_p l3
	+ show "p = (finite_fourier_poly ws)" using l by blast
	+qed
	+
	+
	+text \<open>
	+ The following alternative formulation returns a coefficient
	+\<close>
	+definition finite_fourier_poly' :: "(nat \<Rightarrow> complex) \<Rightarrow> nat \<Rightarrow> complex poly" where
	+ "finite_fourier_poly' ws k =
	+ (poly_of_list [1 / k * (\<Sum>m<k. (ws m) * unity_root k (-n*m)). n \<leftarrow> [0..<k]])"
	+
	+lemma finite_fourier_poly'_conv_finite_fourier_poly:
	+ "finite_fourier_poly' ws k = finite_fourier_poly [ws n. n \<leftarrow> [0..<k]]"
	+ unfolding finite_fourier_poly_def finite_fourier_poly'_def by simp
	+
	+lemma coeff_finite_fourier_poly':
	+ assumes "n < k"
	+ shows "coeff (finite_fourier_poly' ws k) n =
	+ (1/k) * (\<Sum>m < k. (ws m) * unity_root k (-n*m))"
	+proof -
	+ let ?ws = "[ws n. n \<leftarrow> [0..<k]]"
	+ have "coeff (finite_fourier_poly' ws k) n =
	+ coeff (finite_fourier_poly ?ws) n"
	+ by (simp add: finite_fourier_poly'_conv_finite_fourier_poly)
	+ also have "coeff (finite_fourier_poly ?ws) n =
	+ 1 / k * (\<Sum>m<k. (?ws ! m) * unity_root k (- n*m))"
	+ using assms by (auto simp: coeff_finite_fourier_poly)
	+ also have "\<dots> = (1/k) * (\<Sum>m < k. (ws m) * unity_root k (-n*m))"
	+ using assms by simp
	+ finally show ?thesis by simp
	+qed
	+
	+lemma degree_finite_fourier_poly': "degree (finite_fourier_poly' ws k) \<le> k - 1"
	+ using degree_finite_fourier_poly[of "[ws n. n \<leftarrow> [0..<k]]"]
	+ by (auto simp: finite_fourier_poly'_conv_finite_fourier_poly)
	+
	+lemma poly_finite_fourier_poly':
	+ fixes m :: int and k
	+ assumes "m \<in> {0..<k}"
	+ shows "poly (finite_fourier_poly' ws k) (unity_root k m) = ws (nat m)"
	+ using assms poly_finite_fourier_poly[of m "[ws n. n \<leftarrow> [0..<k]]"]
	+ by (auto simp: finite_fourier_poly'_conv_finite_fourier_poly poly_finite_fourier_poly)
	+
	+lemma finite_fourier_poly'_unique:
	+ assumes "k > 0"
	+ assumes "degree p \<le> k - 1"
	+ assumes "\<forall>m\<le>k-1. ws m = poly p (unity_root k m)"
	+ shows "p = finite_fourier_poly' ws k"
	+proof -
	+ let ?ws = "[ws n. n \<leftarrow> [0..<k]]"
	+ from finite_fourier_poly_unique have "p = finite_fourier_poly ?ws" using assms by simp
	+ also have "\<dots> = finite_fourier_poly' ws k"
	+ using finite_fourier_poly'_conv_finite_fourier_poly ..
	+ finally show "p = finite_fourier_poly' ws k" by blast
	+qed
	+
	+lemma fourier_unity_root:
	+ fixes k :: nat
	+ assumes "k > 0"
	+ shows "poly (finite_fourier_poly' f k) (unity_root k m) =
	+ (\<Sum>n<k.1/k(\<Sum>m<k.(f m)unity_root k (-nm))unity_root k (m*n))"
	+proof -
	+ have "poly (finite_fourier_poly' f k) (unity_root k m) =
	+ (\<Sum>n\<le>k-1. coeff (finite_fourier_poly' f k) n *(unity_root k m)^n)"
	+ using poly_altdef'[of "finite_fourier_poly' f k" "k-1" "unity_root k m"]
	+ degree_finite_fourier_poly'[of f k] by simp
	+ also have "\<dots> = (\<Sum>n\<le>k-1. coeff (finite_fourier_poly' f k) n (unity_root k (mn)))"
	+ using unity_root_pow by simp
	+ also have "\<dots> = (\<Sum>n<k. coeff (finite_fourier_poly' f k) n (unity_root k (mn)))"
	+ using assms by (intro sum.cong) auto
	+ also have "\<dots> = (\<Sum>n<k.(1/k)(\<Sum>m<k.(f m)unity_root k (-nm))(unity_root k (m*n)))"
	+ using coeff_finite_fourier_poly'[of _ k f] by simp
	+ finally show
	+ "poly (finite_fourier_poly' f k) (unity_root k m) =
	+ (\<Sum>n<k.1/k(\<Sum>m<k.(f m)unity_root k (-nm))unity_root k (m*n))"
	+ by blast
	+qed
	+
	+subsection \<open>Expansion of an arithmetical function\<close>
	+
	+text \<open>Theorem 8.4\<close>
	+theorem fourier_expansion_periodic_arithmetic:
	+ assumes "k > 0"
	+ assumes "periodic_arithmetic f k"
	+ defines "g \<equiv> (\<lambda>n. (1 / k) * (\<Sum>m<k. f m * unity_root k (-n * m)))"
	+ shows "periodic_arithmetic g k"
	+ and "f m = (\<Sum>n<k. g n * unity_root k (m * n))"
	+proof -
	+ {fix l
	+ from unity_periodic_arithmetic mult_period
	+ have period: "periodic_arithmetic (\<lambda>x. unity_root k x) (k*l)" by simp}
	+ note period = this
	+ {fix n l
	+ have "unity_root k (-(n+k)l) = cnj (unity_root k ((n+k)l))"
	+ by (simp add: unity_root_uminus unity_root_diff ring_distribs unity_root_add)
	+ also have "unity_root k ((n+k)l) = unity_root k (nl)"
	+ by (intro unity_root_cong) (auto simp: cong_def algebra_simps)
	+ also have "cnj \<dots> = unity_root k (-n*l)"
	+ using unity_root_uminus by simp
	+ finally have "unity_root k (-(n+k)l) = unity_root k (-nl)" by simp}
	+ note u_period = this
	+
	+ show 1: "periodic_arithmetic g k"
	+ unfolding periodic_arithmetic_def
	+ proof
	+ fix n
	+
	+ have "g(n+k) = (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-(n+k)*m))"
	+ using assms(3) by fastforce
	+ also have "\<dots> = (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))"
	+ proof -
	+ have "(\<Sum>m<k. f(m) * unity_root k (-(n+k)*m)) =
	+ (\<Sum>m<k. f(m) * unity_root k (-n*m))"
	+ by (intro sum.cong) (use u_period in auto)
	+ then show ?thesis by argo
	+ qed
	+ also have "\<dots> = g(n)"
	+ using assms(3) by fastforce
	+ finally show "g(n+k) = g(n)" by simp
	+ qed
	+
	+ show "f(m) = (\<Sum>n<k. g(n)* unity_root k (m * int n))"
	+ proof -
	+ {
	+ fix m
	+ assume range: "m \<in> {0..<k}"
	+ have "f(m) = (\<Sum>n<k. g(n)* unity_root k (m * int n))"
	+ proof -
	+ have "f m = poly (finite_fourier_poly' f k) (unity_root k m)"
	+ using range by (simp add: poly_finite_fourier_poly')
	+ also have "\<dots> = (\<Sum>n<k. (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-nm)) unity_root k (m*n))"
	+ using fourier_unity_root assms(1) by blast
	+ also have "\<dots> = (\<Sum>n<k. g(n)* unity_root k (m*n))"
	+ using assms by simp
	+ finally show ?thesis by auto
	+ qed}
	+ note concentrated = this
	+
	+ have "periodic_arithmetic (\<lambda>m. (\<Sum>n<k. g(n)* unity_root k (m * int n))) k"
	+ proof -
	+ have "periodic_arithmetic (\<lambda>n. g(n)* unity_root k (i * int n)) k" for i :: int
	+ using 1 unity_periodic_arithmetic mult_periodic_arithmetic
	+ unity_periodic_arithmetic_mult by auto
	+ then have p_s: "\<forall>i<k. periodic_arithmetic (\<lambda>n. g(n)* unity_root k (i * int n)) k"
	+ by simp
	+ have "periodic_arithmetic (\<lambda>i. \<Sum>n<k. g(n)* unity_root k (i * int n)) k"
	+ unfolding periodic_arithmetic_def
	+ proof
	+ fix n
	+ show "(\<Sum>na<k. g na * unity_root k (int (n + k) * int na)) =
	+ (\<Sum>na<k. g na * unity_root k (int n * int na))"
	+ by (intro sum.cong refl, simp add: distrib_right flip: of_nat_mult of_nat_add)
	+ (insert period, unfold periodic_arithmetic_def, blast)
	+ qed
	+ then show ?thesis by simp
	+ qed
	+
	+ from this assms(1-2) concentrated
	+ unique_periodic_arithmetic_extension[of k f "(\<lambda>i. \<Sum>n<k. g(n)* unity_root k (i * int n))" m]
	+ show "f m = (\<Sum>n<k. g n * unity_root k (int m * int n))" by simp
	+ qed
	+qed
	+
	+theorem fourier_expansion_periodic_arithmetic_unique:
	+ fixes f g :: "nat \<Rightarrow> complex"
	+ assumes "k > 0"
	+ assumes "periodic_arithmetic f k" and "periodic_arithmetic g k"
	+ assumes "\<And>m. m < k \<Longrightarrow> f m = (\<Sum>n<k. g n * unity_root k (int (m * n)))"
	+ shows "g n = (1 / k) * (\<Sum>m<k. f m * unity_root k (-n * m))"
	+proof -
	+ let ?p = "poly_of_list [g(n). n \<leftarrow> [0..<k]]"
	+ have d: "degree ?p \<le> k-1"
	+ proof -
	+ have "degree ?p \<le> length [g(n). n \<leftarrow> [0..<k]] - 1"
	+ using degree_poly_of_list_le by blast
	+ also have "\<dots> = length [0..<k] - 1"
	+ using length_map by auto
	+ finally show ?thesis by simp
	+ qed
	+ have c: "coeff ?p i = (if i < k then g(i) else 0)" for i
	+ by (simp add: nth_default_def)
	+ {fix z
	+ have "poly ?p z = (\<Sum>n\<le>k-1. coeff ?p n* z^n)"
	+ using poly_altdef'[of ?p "k-1"] d by blast
	+ also have "\<dots> = (\<Sum>n<k. coeff ?p n* z^n)"
	+ using \<open>k > 0\<close> by (intro sum.cong) auto
	+ also have "\<dots> = (\<Sum>n<k. (if n < k then g(n) else 0)* z^n)"
	+ using c by simp
	+ also have "\<dots> = (\<Sum>n<k. g(n)* z^n)"
	+ by (simp split: if_splits)
	+ finally have "poly ?p z = (\<Sum>n<k. g n * z ^ n)" .}
	+ note eval = this
	+ {fix i
	+ have "poly ?p (unity_root k i) = (\<Sum>n<k. g(n)* (unity_root k i)^n)"
	+ using eval by blast
	+ then have "poly ?p (unity_root k i) = (\<Sum>n<k. g(n)* (unity_root k (i*n)))"
	+ using unity_root_pow by auto}
	+ note interpolation = this
	+
	+ {
	+ fix m
	+ assume b: "m \<le> k-1"
	+ from d assms(1)
	+ have "f m = (\<Sum>n<k. g(n) * unity_root k (m*n))"
	+ using assms(4) b by auto
	+ also have "\<dots> = poly ?p (unity_root k m)"
	+ using interpolation by simp
	+ finally have "f m = poly ?p (unity_root k m)" by auto
	+ }
	+
	+ from this finite_fourier_poly'_unique[of k _ f]
	+ have p_is_fourier: "?p = finite_fourier_poly' f k"
	+ using assms(1) d by blast
	+
	+ {
	+ fix n
	+ assume b: "n \<le> k-1"
	+ have f_1: "coeff ?p n = (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))"
	+ using p_is_fourier using assms(1) b by (auto simp: coeff_finite_fourier_poly')
	+ then have "g(n) = (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))"
	+ using c b assms(1)
	+ proof -
	+ have 1: "coeff ?p n = (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))"
	+ using f_1 by blast
	+ have 2: "coeff ?p n = g n"
	+ using c assms(1) b by simp
	+ show ?thesis using 1 2 by argo
	+ qed
	+ }
	+
	+ (* now show right hand side is periodic and use unique_periodic_extension *)
	+ have "periodic_arithmetic (\<lambda>n. (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))) k"
	+ proof -
	+ have "periodic_arithmetic (\<lambda>i. unity_root k (-int i*int m)) k" for m
	+ using unity_root_periodic_arithmetic_mult_minus by simp
	+ then have "periodic_arithmetic (\<lambda>i. f(m) * unity_root k (-i*m)) k" for m
	+ by (simp add: periodic_arithmetic_def)
	+ then show "periodic_arithmetic (\<lambda>i. (1 / k) * (\<Sum>m<k. f m * unity_root k (-i*m))) k"
	+ by (intro scalar_mult_periodic_arithmetic fin_sum_periodic_arithmetic_set) auto
	+ qed
	+ note periodich = this
	+ let ?h = "(\<lambda>i. (1 / k) (\<Sum>m<k. f m unity_root k (-i*m)))"
	+ from unique_periodic_arithmetic_extension[of k g ?h n]
	+ assms(3) assms(1) periodich
	+ have "g n = (1/k) * (\<Sum>m<k. f m * unity_root k (-n*m))"
	+ by (simp add: \<open>\<And>na. na \<le> k - 1 \<Longrightarrow> g na = complex_of_real (1 / real k) * (\<Sum>m<k. f m * unity_root k (- int na * int m))\<close>)
	+ then show ?thesis by simp
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Gauss_Sums/Gauss_Sums.thy b/thys/Gauss_Sums/Gauss_Sums.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Gauss_Sums/Gauss_Sums.thy
	@@ -0,0 +1,1704 @@
	+(*
	+ File: Gauss_Sums.thy
	+ Authors: Rodrigo Raya, EPFL; Manuel Eberl, TUM
	+
	+ Gauss sums and more on Dirichlet characters: induced moduli, separability, primitive characters
	+*)
	+theory Gauss_Sums
	+imports
	+ "HOL-Algebra.Coset"
	+ "HOL-Real_Asymp.Real_Asymp"
	+ Ramanujan_Sums
	+begin
	+
	+section \<open>Gauss sums\<close>
	+
	+bundle vec_lambda_notation
	+begin
	+notation vec_lambda (binder "\<chi>" 10)
	+end
	+
	+bundle no_vec_lambda_notation
	+begin
	+no_notation vec_lambda (binder "\<chi>" 10)
	+end
	+
	+unbundle no_vec_lambda_notation
	+
	+
	+subsection \<open>Definition and basic properties\<close>
	+context dcharacter
	+begin
	+
	+(* TODO remove when integrating periodic and periodic_function *)
	+lemma dir_periodic_arithmetic: "periodic_arithmetic \<chi> n"
	+ unfolding periodic_arithmetic_def by (simp add: periodic)
	+
	+definition "gauss_sum k = (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*k))"
	+
	+lemma gauss_sum_periodic:
	+ "periodic_arithmetic (\<lambda>n. gauss_sum n) n"
	+proof -
	+ have "periodic_arithmetic \<chi> n" using dir_periodic_arithmetic by simp
	+ let ?h = "\<lambda>m k. \<chi>(m) * unity_root n (m*k)"
	+ {fix m :: nat
	+ have "periodic_arithmetic (\<lambda>k. unity_root n (m*k)) n"
	+ using unity_periodic_arithmetic_mult[of n m] by simp
	+ have "periodic_arithmetic (?h m) n"
	+ using scalar_mult_periodic_arithmetic[OF \<open>periodic_arithmetic (\<lambda>k. unity_root n (m*k)) n\<close>]
	+ by blast}
	+ then have per_all: "\<forall>m \<in> {1..n}. periodic_arithmetic (?h m) n" by blast
	+ have "periodic_arithmetic (\<lambda>k. (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*k))) n"
	+ using fin_sum_periodic_arithmetic_set[OF per_all] by blast
	+ then show ?thesis
	+ unfolding gauss_sum_def by blast
	+qed
	+
	+lemma ramanujan_sum_conv_gauss_sum:
	+ assumes "\<chi> = principal_dchar n"
	+ shows "ramanujan_sum n k = gauss_sum k"
	+proof -
	+ {fix m
	+ from assms
	+ have 1: "coprime m n \<Longrightarrow> \<chi>(m) = 1" and
	+ 2: "\<not> coprime m n \<Longrightarrow> \<chi>(m) = 0"
	+ unfolding principal_dchar_def by auto}
	+ note eq = this
	+
	+ have "gauss_sum k = (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*k))"
	+ unfolding gauss_sum_def by simp
	+ also have "\<dots> = (\<Sum>m \| m \<in> {1..n} \<and> coprime m n . \<chi>(m) * unity_root n (m*k))"
	+ by (rule sum.mono_neutral_right,simp,blast,simp add: eq)
	+ also have "\<dots> = (\<Sum>m \| m \<in> {1..n} \<and> coprime m n . unity_root n (m*k))"
	+ by (simp add: eq)
	+ also have "\<dots> = ramanujan_sum n k" unfolding ramanujan_sum_def by blast
	+ finally show ?thesis ..
	+qed
	+
	+lemma cnj_mult_self:
	+ assumes "coprime k n"
	+ shows "cnj (\<chi> k) * \<chi> k = 1"
	+proof -
	+ have "cnj (\<chi> k) * \<chi> k = norm (\<chi> k)^2"
	+ by (simp add: mult.commute complex_mult_cnj cmod_def)
	+ also have "\<dots> = 1"
	+ using norm[of k] assms by simp
	+ finally show ?thesis .
	+qed
	+
	+text \<open>Theorem 8.9\<close>
	+theorem gauss_sum_reduction:
	+ assumes "coprime k n"
	+ shows "gauss_sum k = cnj (\<chi> k) * gauss_sum 1"
	+proof -
	+ from n have n_pos: "n > 0" by simp
	+ have "gauss_sum k = (\<Sum>r = 1..n . \<chi>(r) * unity_root n (r*k))"
	+ unfolding gauss_sum_def by simp
	+ also have "\<dots> = (\<Sum>r = 1..n . cnj (\<chi>(k)) * \<chi> k * \<chi> r * unity_root n (r*k))"
	+ using assms by (intro sum.cong) (auto simp: cnj_mult_self)
	+ also have "\<dots> = (\<Sum>r = 1..n . cnj (\<chi>(k)) * \<chi> (kr) unity_root n (r*k))"
	+ by (intro sum.cong) auto
	+ also have "\<dots> = cnj (\<chi>(k)) * (\<Sum>r = 1..n . \<chi> (kr) unity_root n (r*k))"
	+ by (simp add: sum_distrib_left algebra_simps)
	+ also have "\<dots>= cnj (\<chi>(k)) * (\<Sum>r = 1..n . \<chi> r * unity_root n r)"
	+ proof -
	+ have 1: "periodic_arithmetic (\<lambda>r. \<chi> r * unity_root n r) n"
	+ using dir_periodic_arithmetic unity_periodic_arithmetic mult_periodic_arithmetic by blast
	+ have "(\<Sum>r = 1..n . \<chi> (kr) unity_root n (r*k)) =
	+ (\<Sum>r = 1..n . \<chi> (r)* unity_root n r)"
	+ using periodic_arithmetic_remove_homothecy[OF assms(1) 1 n_pos]
	+ by (simp add: algebra_simps n)
	+ then show ?thesis by argo
	+ qed
	+ also have "\<dots> = cnj (\<chi>(k)) * gauss_sum 1"
	+ using gauss_sum_def by simp
	+ finally show ?thesis .
	+qed
	+
	+
	+text \<open>
	+ The following variant takes an integer argument instead.
	+\<close>
	+definition "gauss_sum_int k = (\<Sum>m=1..n. \<chi> m * unity_root n (int m*k))"
	+
	+sublocale gauss_sum_int: periodic_fun_simple gauss_sum_int "int n"
	+proof
	+ fix k
	+ show "gauss_sum_int (k + int n) = gauss_sum_int k"
	+ by (simp add: gauss_sum_int_def ring_distribs unity_root_add)
	+qed
	+
	+lemma gauss_sum_int_cong:
	+ assumes "[a = b] (mod int n)"
	+ shows "gauss_sum_int a = gauss_sum_int b"
	+proof -
	+ from assms obtain k where k: "b = a + int n * k"
	+ by (subst (asm) cong_iff_lin) auto
	+ thus ?thesis
	+ using gauss_sum_int.plus_of_int[of a k] by (auto simp: algebra_simps)
	+qed
	+
	+lemma gauss_sum_conv_gauss_sum_int:
	+ "gauss_sum k = gauss_sum_int (int k)"
	+ unfolding gauss_sum_def gauss_sum_int_def by auto
	+
	+lemma gauss_sum_int_conv_gauss_sum:
	+ "gauss_sum_int k = gauss_sum (nat (k mod n))"
	+proof -
	+ have "gauss_sum (nat (k mod n)) = gauss_sum_int (int (nat (k mod n)))"
	+ by (simp add: gauss_sum_conv_gauss_sum_int)
	+ also have "\<dots> = gauss_sum_int k"
	+ using n
	+ by (intro gauss_sum_int_cong) (auto simp: cong_def)
	+ finally show ?thesis ..
	+qed
	+
	+lemma gauss_int_periodic: "periodic_arithmetic gauss_sum_int n"
	+ unfolding periodic_arithmetic_def gauss_sum_int_conv_gauss_sum by simp
	+
	+proposition dcharacter_fourier_expansion:
	+ "\<chi> m = (\<Sum>k=1..n. 1 / n * gauss_sum_int (-k) * unity_root n (m*k))"
	+proof -
	+ define g where "g = (\<lambda>x. 1 / of_nat n *
	+ (\<Sum>m<n. \<chi> m * unity_root n (- int x * int m)))"
	+ have per: "periodic_arithmetic \<chi> n" using dir_periodic_arithmetic by simp
	+ have "\<chi> m = (\<Sum>k<n. g k * unity_root n (m * int k))"
	+ using fourier_expansion_periodic_arithmetic(2)[OF _ per, of m] n by (auto simp: g_def)
	+ also have "\<dots> = (\<Sum>k = 1..n. g k * unity_root n (m * int k))"
	+ proof -
	+ have g_per: "periodic_arithmetic g n"
	+ using fourier_expansion_periodic_arithmetic(1)[OF _ per] n by (simp add: g_def)
	+ have fact_per: "periodic_arithmetic (\<lambda>k. g k * unity_root n (int m * int k)) n"
	+ using mult_periodic_arithmetic[OF g_per] unity_periodic_arithmetic_mult by auto
	+ show ?thesis
	+ proof -
	+ have "(\<Sum>k<n. g k * unity_root n (int m * int k)) =
	+ (\<Sum>l = 0..n - Suc 0. g l * unity_root n (int m * int l))"
	+ using n by (intro sum.cong) auto
	+ also have "\<dots> = (\<Sum>l = Suc 0..n. g l * unity_root n (int m * int l))"
	+ using periodic_arithmetic_sum_periodic_arithmetic_shift[OF fact_per, of 1] n by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ also have "\<dots> = (\<Sum>k = 1..n. (1 / of_nat n) * gauss_sum_int (-k) * unity_root n (m*k))"
	+ proof -
	+ {fix k :: nat
	+ have shift: "(\<Sum>m<n. \<chi> m * unity_root n (- int k * int m)) =
	+ (\<Sum>m = 1..n. \<chi> m * unity_root n (- int k * int m))"
	+ proof -
	+ have per_unit: "periodic_arithmetic (\<lambda>m. unity_root n (- int k * int m)) n"
	+ using unity_periodic_arithmetic_mult by blast
	+ then have prod_per: "periodic_arithmetic (\<lambda>m. \<chi> m * unity_root n (- int k * int m)) n"
	+ using per mult_periodic_arithmetic by blast
	+ show ?thesis
	+ proof -
	+ have "(\<Sum>m<n. \<chi> m * unity_root n (- int k * int m)) =
	+ (\<Sum>l = 0..n - Suc 0. \<chi> l * unity_root n (- int k * int l))"
	+ using n by (intro sum.cong) auto
	+ also have "\<dots> = (\<Sum>m = 1..n. \<chi> m * unity_root n (- int k * int m))"
	+ using periodic_arithmetic_sum_periodic_arithmetic_shift[OF prod_per, of 1] n by auto
	+ finally show ?thesis by simp
	+ qed
	+ qed
	+ have "g k = 1 / of_nat n *
	+ (\<Sum>m<n. \<chi> m * unity_root n (- int k * int m))"
	+ using g_def by auto
	+ also have "\<dots> = 1 / of_nat n *
	+ (\<Sum>m = 1..n. \<chi> m * unity_root n (- int k * int m))"
	+ using shift by simp
	+ also have "\<dots> = 1 / of_nat n * gauss_sum_int (-k)"
	+ unfolding gauss_sum_int_def
	+ by (simp add: algebra_simps)
	+ finally have "g k = 1 / of_nat n * gauss_sum_int (-k)" by simp}
	+ note g_expr = this
	+ show ?thesis
	+ by (rule sum.cong, simp, simp add: g_expr)
	+ qed
	+ finally show ?thesis by auto
	+qed
	+
	+
	+subsection \<open>Separability\<close>
	+
	+definition "separable k \<longleftrightarrow> gauss_sum k = cnj (\<chi> k) * gauss_sum 1"
	+
	+corollary gauss_coprime_separable:
	+ assumes "coprime k n"
	+ shows "separable k"
	+ using gauss_sum_reduction[OF assms] unfolding separable_def by simp
	+
	+text \<open>Theorem 8.10\<close>
	+theorem global_separability_condition:
	+ "(\<forall>n>0. separable n) \<longleftrightarrow> (\<forall>k>0. \<not>coprime k n \<longrightarrow> gauss_sum k = 0)"
	+proof -
	+ {fix k
	+ assume "\<not> coprime k n"
	+ then have "\<chi>(k) = 0" by (simp add: eq_zero)
	+ then have "cnj (\<chi> k) = 0" by blast
	+ then have "separable k \<longleftrightarrow> gauss_sum k = 0"
	+ unfolding separable_def by auto}
	+ note not_case = this
	+
	+ show ?thesis
	+ using gauss_coprime_separable not_case separable_def by blast
	+qed
	+
	+lemma of_real_moebius_mu [simp]: "of_real (moebius_mu k) = moebius_mu k"
	+ by (simp add: moebius_mu_def)
	+
	+corollary principal_not_totally_separable:
	+ assumes "\<chi> = principal_dchar n"
	+ shows "\<not>(\<forall>k > 0. separable k)"
	+proof -
	+ have n_pos: "n > 0" using n by simp
	+ have tot_0: "totient n \<noteq> 0" by (simp add: n_pos)
	+ have "moebius_mu (n div gcd n n) \<noteq> 0" by (simp add: \<open>n > 0\<close>)
	+ then have moeb_0: "\<exists>k. moebius_mu (n div gcd k n) \<noteq> 0" by blast
	+
	+ have lem: "gauss_sum k = totient n * moebius_mu (n div gcd k n) / totient (n div gcd k n)"
	+ if "k > 0" for k
	+ proof -
	+ have "gauss_sum k = ramanujan_sum n k"
	+ using ramanujan_sum_conv_gauss_sum[OF assms(1)] ..
	+ also have "\<dots> = totient n * moebius_mu (n div gcd k n) / (totient (n div gcd k n))"
	+ by (simp add: ramanujan_sum_k_n_dirichlet_expr[OF n_pos that])
	+ finally show ?thesis .
	+ qed
	+ have 2: "\<not> coprime n n" using n by auto
	+ have 3: "gauss_sum n \<noteq> 0"
	+ using lem[OF n_pos] tot_0 moebius_mu_1 by simp
	+ from n_pos 2 3 have
	+ "\<exists>k>0. \<not>coprime k n \<and> gauss_sum k \<noteq> 0" by blast
	+ then obtain k where "k > 0 \<and> \<not> coprime k n \<and> gauss_sum k \<noteq> 0" by blast
	+ note right_not_zero = this
	+
	+ have "cnj (\<chi> k) * gauss_sum 1 = 0" if "\<not>coprime k n" for k
	+ using that assms by (simp add: principal_dchar_def)
	+ then show ?thesis
	+ unfolding separable_def using right_not_zero by auto
	+qed
	+
	+text \<open>Theorem 8.11\<close>
	+theorem gauss_sum_1_mod_square_eq_k:
	+ assumes "(\<forall>k. k > 0 \<longrightarrow> separable k)"
	+ shows "norm (gauss_sum 1) ^ 2 = real n"
	+proof -
	+ have "(norm (gauss_sum 1))^2 = gauss_sum 1 * cnj (gauss_sum 1)"
	+ using complex_norm_square by blast
	+ also have "\<dots> = gauss_sum 1 * (\<Sum>m = 1..n. cnj (\<chi>(m)) * unity_root n (-m))"
	+ proof -
	+ have "cnj (gauss_sum 1) = (\<Sum>m = 1..n. cnj (\<chi>(m)) * unity_root n (-m))"
	+ unfolding gauss_sum_def by (simp add: unity_root_uminus)
	+ then show ?thesis by argo
	+ qed
	+ also have "\<dots> = (\<Sum>m = 1..n. gauss_sum 1 * cnj (\<chi>(m)) * unity_root n (-m))"
	+ by (subst sum_distrib_left)(simp add: algebra_simps)
	+ also have "\<dots> = (\<Sum>m = 1..n. gauss_sum m * unity_root n (-m))"
	+ proof (rule sum.cong,simp)
	+ fix x
	+ assume as: "x \<in> {1..n}"
	+ show "gauss_sum 1 * cnj (\<chi> x) * unity_root n (-x) =
	+ gauss_sum x * unity_root n (-x)"
	+ using assms(1) unfolding separable_def
	+ by (rule allE[of _ x]) (use as in auto)
	+ qed
	+ also have "\<dots> = (\<Sum>m = 1..n. (\<Sum>r = 1..n. \<chi> r * unity_root n (rm) unity_root n (-m)))"
	+ unfolding gauss_sum_def
	+ by (rule sum.cong,simp,rule sum_distrib_right)
	+ also have "\<dots> = (\<Sum>m = 1..n. (\<Sum>r = 1..n. \<chi> r * unity_root n (m*(r-1)) ))"
	+ by (intro sum.cong refl) (auto simp: unity_root_diff of_nat_diff unity_root_uminus field_simps)
	+ also have "\<dots> = (\<Sum>r=1..n. (\<Sum>m=1..n. \<chi>(r) unity_root n (m(r-1))))"
	+ by (rule sum.swap)
	+ also have "\<dots> = (\<Sum>r=1..n. \<chi>(r) (\<Sum>m=1..n. unity_root n (m(r-1))))"
	+ by (rule sum.cong, simp, simp add: sum_distrib_left)
	+ also have "\<dots> = (\<Sum>r=1..n. \<chi>(r) * unity_root_sum n (r-1))"
	+ proof (intro sum.cong refl)
	+ fix x
	+ assume "x \<in> {1..n}"
	+ then have 1: "periodic_arithmetic (\<lambda>m. unity_root n (int (m * (x - 1)))) n"
	+ using unity_periodic_arithmetic_mult[of n "x-1"]
	+ by (simp add: mult.commute)
	+ have "(\<Sum>m = 1..n. unity_root n (int (m * (x - 1)))) =
	+ (\<Sum>m = 0..n-1. unity_root n (int (m * (x - 1))))"
	+ using periodic_arithmetic_sum_periodic_arithmetic_shift[OF 1 _, of 1] n by simp
	+ also have "\<dots> = unity_root_sum n (x-1)"
	+ using n unfolding unity_root_sum_def by (intro sum.cong) (auto simp: mult_ac)
	+ finally have "(\<Sum>m = 1..n. unity_root n (int (m * (x - 1)))) =
	+ unity_root_sum n (int (x - 1))" .
	+ then show "\<chi> x * (\<Sum>m = 1..n. unity_root n (int (m * (x - 1)))) =
	+ \<chi> x * unity_root_sum n (int (x - 1))" by argo
	+ qed
	+ also have "\<dots> = (\<Sum>r \<in> {1}. \<chi> r * unity_root_sum n (int (r - 1)))"
	+ using n unity_root_sum_nonzero_iff int_ops(6)
	+ by (intro sum.mono_neutral_right) auto
	+ also have "\<dots> = \<chi> 1 * n" using n by simp
	+ also have "\<dots> = n" by simp
	+ finally show ?thesis
	+ using of_real_eq_iff by fastforce
	+qed
	+
	+text \<open>Theorem 8.12\<close>
	+theorem gauss_sum_nonzero_noncoprime_necessary_condition:
	+ assumes "gauss_sum k \<noteq> 0" "\<not>coprime k n" "k > 0"
	+ defines "d \<equiv> n div gcd k n"
	+ assumes "coprime a n" "[a = 1] (mod d)"
	+ shows "d dvd n" "d < n" "\<chi> a = 1"
	+proof -
	+ show "d dvd n"
	+ unfolding d_def using n by (subst div_dvd_iff_mult) auto
	+ from assms(2) have "gcd k n \<noteq> 1" by blast
	+ then have "gcd k n > 1" using assms(3,4) by (simp add: nat_neq_iff)
	+ with n show "d < n" by (simp add: d_def)
	+
	+ have "periodic_arithmetic (\<lambda>r. \<chi> (r)* unity_root n (k*r)) n"
	+ using mult_periodic_arithmetic[OF dir_periodic_arithmetic unity_periodic_arithmetic_mult] by auto
	+ then have 1: "periodic_arithmetic (\<lambda>r. \<chi> (r)* unity_root n (r*k)) n"
	+ by (simp add: algebra_simps)
	+
	+ have "gauss_sum k = (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*k))"
	+ unfolding gauss_sum_def by blast
	+ also have "\<dots> = (\<Sum>m = 1..n . \<chi>(ma) unity_root n (mak))"
	+ using periodic_arithmetic_remove_homothecy[OF assms(5) 1] n by auto
	+ also have "\<dots> = (\<Sum>m = 1..n . \<chi>(ma) unity_root n (m*k))"
	+ proof (intro sum.cong refl)
	+ fix m
	+ from assms(6) obtain b where "a = 1 + b*d"
	+ using \<open>d < n\<close> assms(5) cong_to_1'_nat by auto
	+ then have "mak = mk+mb(n div gcd k n)k"
	+ by (simp add: algebra_simps d_def)
	+ also have "\<dots> = mk+mbn(k div gcd k n)"
	+ by (simp add: div_mult_swap dvd_div_mult)
	+ also obtain p where "\<dots> = mk+mbnp" by blast
	+ finally have "mak = mk+mbpn" by simp
	+ then have 1: "mak mod n= m*k mod n"
	+ using mod_mult_self1 by simp
	+ then have "unity_root n (m * a * k) = unity_root n (m * k)"
	+ proof -
	+ have "unity_root n (m * a * k) = unity_root n ((m * a * k) mod n)"
	+ using unity_root_mod[of n] zmod_int by simp
	+ also have "\<dots> = unity_root n (m * k)"
	+ using unity_root_mod[of n] zmod_int 1 by presburger
	+ finally show ?thesis by blast
	+ qed
	+ then show "\<chi> (m * a) * unity_root n (int (m * a * k)) =
	+ \<chi> (m * a) * unity_root n (int (m * k))" by auto
	+ qed
	+ also have "\<dots> = (\<Sum>m = 1..n . \<chi>(a) * (\<chi>(m) * unity_root n (m*k)))"
	+ by (rule sum.cong,simp,subst mult,simp)
	+ also have "\<dots> = \<chi>(a) * (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*k))"
	+ by (simp add: sum_distrib_left[symmetric])
	+ also have "\<dots> = \<chi>(a) * gauss_sum k"
	+ unfolding gauss_sum_def by blast
	+ finally have "gauss_sum k = \<chi>(a) * gauss_sum k" by blast
	+ then show "\<chi> a = 1"
	+ using assms(1) by simp
	+qed
	+
	+
	+subsection \<open>Induced moduli and primitive characters\<close>
	+
	+definition "induced_modulus d \<longleftrightarrow> d dvd n \<and> (\<forall>a. coprime a n \<and> [a = 1] (mod d) \<longrightarrow> \<chi> a = 1)"
	+
	+lemma induced_modulus_dvd: "induced_modulus d \<Longrightarrow> d dvd n"
	+ unfolding induced_modulus_def by blast
	+
	+lemma induced_modulusI [intro?]:
	+ "d dvd n \<Longrightarrow> (\<And>a. coprime a n \<Longrightarrow> [a = 1] (mod d) \<Longrightarrow> \<chi> a = 1) \<Longrightarrow> induced_modulus d"
	+ unfolding induced_modulus_def by auto
	+
	+lemma induced_modulusD: "induced_modulus d \<Longrightarrow> coprime a n \<Longrightarrow> [a = 1] (mod d) \<Longrightarrow> \<chi> a = 1"
	+ unfolding induced_modulus_def by blast
	+
	+lemma zero_not_ind_mod: "\<not>induced_modulus 0"
	+ unfolding induced_modulus_def using n by simp
	+
	+lemma div_gcd_dvd1: "(a :: 'a :: semiring_gcd) div gcd a b dvd a"
	+ by (metis dvd_def dvd_div_mult_self gcd_dvd1)
	+
	+lemma div_gcd_dvd2: "(b :: 'a :: semiring_gcd) div gcd a b dvd b"
	+ by (metis div_gcd_dvd1 gcd.commute)
	+
	+lemma g_non_zero_ind_mod:
	+ assumes "gauss_sum k \<noteq> 0" "\<not>coprime k n" "k > 0"
	+ shows "induced_modulus (n div gcd k n)"
	+proof
	+ show "n div gcd k n dvd n"
	+ by (metis dvd_div_mult_self dvd_triv_left gcd.commute gcd_dvd1)
	+ fix a :: nat
	+ assume "coprime a n" "[a = 1] (mod n div gcd k n)"
	+ thus "\<chi> a = 1"
	+ using assms n gauss_sum_nonzero_noncoprime_necessary_condition(3) by auto
	+qed
	+
	+lemma induced_modulus_modulus: "induced_modulus n"
	+ unfolding induced_modulus_def
	+proof (rule conjI,simp,safe)
	+ fix a
	+ assume "[a = 1] (mod n)"
	+ then have "a mod n = 1 mod n"
	+ using cong_def[of a 1 n] by blast
	+ also have "\<dots> = 1"
	+ using eq_zero_iff zero_eq_0 by fastforce
	+ finally have 1: "a mod n = 1" by simp
	+
	+ have "\<chi> a = \<chi> (a mod n)" by simp
	+ also have "\<dots> = \<chi> 1" using cong_def 1 by auto
	+ also have "\<dots> = 1" by simp
	+ finally show "\<chi> a = 1" by blast
	+qed
	+
	+text \<open>Theorem 8.13\<close>
	+theorem one_induced_iff_principal:
	+ "induced_modulus 1 \<longleftrightarrow> \<chi> = principal_dchar n"
	+proof
	+ assume "induced_modulus 1"
	+ then have "(\<forall>a. coprime a n \<longrightarrow> \<chi> a = 1)"
	+ unfolding induced_modulus_def by simp
	+ then show "\<chi> = principal_dchar n"
	+ unfolding principal_dchar_def using eq_zero by auto
	+next
	+ assume as: "\<chi> = principal_dchar n"
	+ {fix a
	+ assume "coprime a n"
	+ then have "\<chi> a = 1"
	+ using principal_dchar_def as by simp}
	+ then show "induced_modulus 1"
	+ unfolding induced_modulus_def by auto
	+qed
	+
	+end
	+
	+
	+locale primitive_dchar = dcharacter +
	+ assumes no_induced_modulus: "\<not>(\<exists>d<n. induced_modulus d)"
	+
	+locale nonprimitive_dchar = dcharacter +
	+ assumes induced_modulus: "\<exists>d<n. induced_modulus d"
	+
	+lemma (in nonprimitive_dchar) nonprimitive: "\<not>primitive_dchar n \<chi>"
	+proof
	+ assume "primitive_dchar n \<chi>"
	+ then interpret A: primitive_dchar n "residue_mult_group n" \<chi>
	+ by auto
	+ from A.no_induced_modulus induced_modulus show False by contradiction
	+qed
	+
	+lemma (in dcharacter) primitive_dchar_iff:
	+ "primitive_dchar n \<chi> \<longleftrightarrow> \<not>(\<exists>d<n. induced_modulus d)"
	+ unfolding primitive_dchar_def primitive_dchar_axioms_def
	+ using dcharacter_axioms by metis
	+
	+lemma (in residues_nat) principal_not_primitive:
	+ "\<not>primitive_dchar n (principal_dchar n)"
	+ unfolding principal.primitive_dchar_iff
	+ using principal.one_induced_iff_principal n by auto
	+
	+lemma (in dcharacter) not_primitive_imp_nonprimitive:
	+ assumes "\<not>primitive_dchar n \<chi>"
	+ shows "nonprimitive_dchar n \<chi>"
	+ using assms dcharacter_axioms
	+ unfolding nonprimitive_dchar_def primitive_dchar_def
	+ primitive_dchar_axioms_def nonprimitive_dchar_axioms_def by auto
	+
	+
	+text \<open>Theorem 8.14\<close>
	+theorem (in dcharacter) prime_nonprincipal_is_primitive:
	+ assumes "prime n"
	+ assumes "\<chi> \<noteq> principal_dchar n"
	+ shows "primitive_dchar n \<chi>"
	+proof -
	+ {fix m
	+ assume "induced_modulus m"
	+ then have "m = n"
	+ using assms prime_nat_iff induced_modulus_def
	+ one_induced_iff_principal by blast}
	+ then show ?thesis using primitive_dchar_iff by blast
	+qed
	+
	+text \<open>Theorem 8.15\<close>
	+corollary (in primitive_dchar) primitive_encoding:
	+ "\<forall>k>0. \<not>coprime k n \<longrightarrow> gauss_sum k = 0"
	+ "\<forall>k>0. separable k"
	+ "norm (gauss_sum 1) ^ 2 = n"
	+proof safe
	+ show 1: "gauss_sum k = 0" if "k > 0" and "\<not>coprime k n" for k
	+ proof (rule ccontr)
	+ assume "gauss_sum k \<noteq> 0"
	+ hence "induced_modulus (n div gcd k n)"
	+ using that by (intro g_non_zero_ind_mod) auto
	+ moreover have "n div gcd k n < n"
	+ using n that
	+ by (meson coprime_iff_gcd_eq_1 div_eq_dividend_iff le_less_trans
	+ linorder_neqE_nat nat_dvd_not_less principal.div_gcd_dvd2 zero_le_one)
	+ ultimately show False using no_induced_modulus by blast
	+ qed
	+
	+ have "(\<forall>n>0. separable n)"
	+ unfolding global_separability_condition by (auto intro!: 1)
	+ thus "separable n" if "n > 0" for n
	+ using that by blast
	+ thus "norm (gauss_sum 1) ^ 2 = n"
	+ using gauss_sum_1_mod_square_eq_k by blast
	+qed
	+
	+text \<open>Theorem 8.16\<close>
	+lemma (in dcharacter) induced_modulus_altdef1:
	+ "induced_modulus d \<longleftrightarrow>
	+ d dvd n \<and> (\<forall>a b. coprime a n \<and> coprime b n \<and> [a = b] (mod d) \<longrightarrow> \<chi> a = \<chi> b)"
	+proof
	+ assume 1: "induced_modulus d"
	+ with n have d: "d dvd n" "d > 0"
	+ by (auto simp: induced_modulus_def intro: Nat.gr0I)
	+ show " d dvd n \<and> (\<forall>a b. coprime a n \<and> coprime b n \<and> [a = b] (mod d) \<longrightarrow> \<chi>(a) = \<chi>(b))"
	+ proof safe
	+ fix a b
	+ assume 2: "coprime a n" "coprime b n" "[a = b] (mod d)"
	+ show "\<chi>(a) = \<chi>(b)"
	+ proof -
	+ from 2(1) obtain a' where eq: "[a*a' = 1] (mod n)"
	+ using cong_solve by blast
	+ from this d have "[a*a' = 1] (mod d)"
	+ using cong_dvd_modulus_nat by blast
	+ from this 1 have "\<chi>(a*a') = 1"
	+ unfolding induced_modulus_def
	+ by (meson "2"(2) eq cong_imp_coprime cong_sym coprime_divisors gcd_nat.refl one_dvd)
	+ then have 3: "\<chi>(a)*\<chi>(a') = 1"
	+ by simp
	+
	+ from 2(3) have "[aa' = ba'] (mod d)"
	+ by (simp add: cong_scalar_right)
	+ moreover have 4: "[b*a' = 1] (mod d)"
	+ using \<open>[a * a' = 1] (mod d)\<close> calculation cong_sym cong_trans by blast
	+ have "\<chi>(b*a') = 1"
	+ proof -
	+ have "coprime (b*a') n"
	+ using "2"(2) cong_imp_coprime[OF cong_sym[OF eq]] by simp
	+ then show ?thesis using 4 induced_modulus_def 1 by blast
	+ qed
	+ then have 4: "\<chi>(b)*\<chi>(a') = 1"
	+ by simp
	+ from 3 4 show "\<chi>(a) = \<chi>(b)"
	+ using mult_cancel_left
	+ by (cases "\<chi>(a') = 0") (fastforce simp add: field_simps)+
	+ qed
	+ qed fact+
	+next
	+ assume *: "d dvd n \<and> (\<forall>a b. coprime a n \<and> coprime b n \<and> [a = b] (mod d) \<longrightarrow> \<chi> a = \<chi> b)"
	+ then have "\<forall>a . coprime a n \<and> coprime 1 n \<and> [a = 1] (mod d) \<longrightarrow> \<chi> a = \<chi> 1"
	+ by blast
	+ then have "\<forall>a . coprime a n \<and> [a = 1] (mod d) \<longrightarrow> \<chi> a = 1"
	+ using coprime_1_left by simp
	+ then show "induced_modulus d"
	+ unfolding induced_modulus_def using * by blast
	+qed
	+
	+text \<open>Exercise 8.4\<close>
	+
	+lemma induced_modulus_altdef2_lemma:
	+ fixes n a d q :: nat
	+ defines "q \<equiv> (\<Prod> p \| prime p \<and> p dvd n \<and> \<not> (p dvd a). p)"
	+ defines "m \<equiv> a + q * d"
	+ assumes "n > 0" "coprime a d"
	+ shows "[m = a] (mod d)" and "coprime m n"
	+proof (simp add: assms(2) cong_add_lcancel_0_nat cong_mult_self_right)
	+ have fin: "finite {p. prime p \<and> p dvd n \<and> \<not> (p dvd a)}" by (simp add: assms)
	+ { fix p
	+ assume 4: "prime p" "p dvd m" "p dvd n"
	+ have "p = 1"
	+ proof (cases "p dvd a")
	+ case True
	+ from this assms 4(2) have "p dvd q*d"
	+ by (simp add: dvd_add_right_iff)
	+ then have a1: "p dvd q \<or> p dvd d"
	+ using 4(1) prime_dvd_mult_iff by blast
	+
	+ have a2: "\<not> (p dvd q)"
	+ proof (rule ccontr,simp)
	+ assume "p dvd q"
	+ then have "p dvd (\<Prod> p \| prime p \<and> p dvd n \<and> \<not> (p dvd a). p)"
	+ unfolding assms by simp
	+ then have "\<exists>x\<in>{p. prime p \<and> p dvd n \<and> \<not> p dvd a}. p dvd x"
	+ using prime_dvd_prod_iff[OF fin 4(1)] by simp
	+ then obtain x where c: "p dvd x \<and> prime x \<and> \<not> x dvd a" by blast
	+ then have "p = x" using 4(1) by (simp add: primes_dvd_imp_eq)
	+ then show "False" using True c by auto
	+ qed
	+ have a3: "\<not> (p dvd d)"
	+ using True assms "4"(1) coprime_def not_prime_unit by auto
	+
	+ from a1 a2 a3 show ?thesis by simp
	+ next
	+ case False
	+ then have "p dvd q"
	+ proof -
	+ have in_s: "p \<in> {p. prime p \<and> p dvd n \<and> \<not> p dvd a}"
	+ using False 4(3) 4(1) by simp
	+ show "p dvd q"
	+ unfolding assms using dvd_prodI[OF fin in_s ] by fast
	+ qed
	+ then have "p dvd q*d" by simp
	+ then have "p dvd a" using 4(2) assms
	+ by (simp add: dvd_add_left_iff)
	+ then show ?thesis using False by auto
	+ qed
	+ }
	+ note lem = this
	+ show "coprime m n"
	+ proof (subst coprime_iff_gcd_eq_1)
	+ {fix a
	+ assume "a dvd m" "a dvd n" "a \<noteq> 1"
	+ {fix p
	+ assume "prime p" "p dvd a"
	+ then have "p dvd m" "p dvd n"
	+ using \<open>a dvd m\<close> \<open>a dvd n\<close> by auto
	+ from lem have "p = a"
	+ using not_prime_1 \<open>prime p\<close> \<open>p dvd m\<close> \<open>p dvd n\<close> by blast}
	+ then have "prime a"
	+ using prime_prime_factor[of a] \<open>a \<noteq> 1\<close> by blast
	+ then have "a = 1" using lem \<open>a dvd m\<close> \<open>a dvd n\<close> by blast
	+ then have "False" using \<open>a = 1\<close> \<open>a \<noteq> 1\<close> by blast
	+ }
	+ then show "gcd m n = 1" by blast
	+ qed
	+qed
	+
	+text \<open>Theorem 8.17\<close>
	+text\<open>The case \<open>d = 1\<close> is exactly the case described in @{thm dcharacter.one_induced_iff_principal}.\<close>
	+theorem (in dcharacter) induced_modulus_altdef2:
	+ assumes "d dvd n" "d \<noteq> 1"
	+ defines "\<chi>\<^sub>1 \<equiv> principal_dchar n"
	+ shows "induced_modulus d \<longleftrightarrow> (\<exists>\<Phi>. dcharacter d \<Phi> \<and> (\<forall>k. \<chi> k = \<Phi> k * \<chi>\<^sub>1 k))"
	+proof
	+ from n have n_pos: "n > 0" by simp
	+ assume as_im: "induced_modulus d"
	+ define f where
	+ "f \<equiv> (\<lambda>k. k +
	+ (if k = 1 then
	+ 0
	+ else (prod id {p. prime p \<and> p dvd n \<and> \<not> (p dvd k)})*d)
	+ )"
	+ have [simp]: "f (Suc 0) = 1" unfolding f_def by simp
	+ {
	+ fix k
	+ assume as: "coprime k d"
	+ hence "[f k = k] (mod d)" "coprime (f k) n"
	+ using induced_modulus_altdef2_lemma[OF n_pos as] by (simp_all add: f_def)
	+ }
	+ note m_prop = this
	+
	+ define \<Phi> where
	+ "\<Phi> \<equiv> (\<lambda>n. (if \<not> coprime n d then 0 else \<chi>(f n)))"
	+
	+ have \<Phi>_1: "\<Phi> 1 = 1"
	+ unfolding \<Phi>_def by simp
	+
	+ from assms(1,2) n have "d > 0" by (intro Nat.gr0I) auto
	+ from induced_modulus_altdef1 assms(1) \<open>d > 0\<close> as_im
	+ have b: "(\<forall>a b. coprime a n \<and> coprime b n \<and>
	+ [a = b] (mod d) \<longrightarrow> \<chi> a = \<chi> b)" by blast
	+
	+ have \<Phi>_periodic: " \<forall>a. \<Phi> (a + d) = \<Phi> a"
	+ proof
	+ fix a
	+ have "gcd (a+d) d = gcd a d" by auto
	+ then have cop: "coprime (a+d) d = coprime a d"
	+ using coprime_iff_gcd_eq_1 by presburger
	+ show "\<Phi> (a + d) = \<Phi> a"
	+ proof (cases "coprime a d")
	+ case True
	+ from True cop have cop_ad: "coprime (a+d) d" by blast
	+ have p1: "[f (a+d) = f a] (mod d)"
	+ using m_prop(1)[of "a+d", OF cop_ad]
	+ m_prop(1)[of "a",OF True] by (simp add: cong_def)
	+ have p2: "coprime (f (a+d)) n" "coprime (f a) n"
	+ using m_prop(2)[of "a+d", OF cop_ad]
	+ m_prop(2)[of "a", OF True] by blast+
	+ from b p1 p2 have eq: "\<chi> (f (a + d)) = \<chi> (f a)" by blast
	+ show ?thesis
	+ unfolding \<Phi>_def
	+ by (subst cop,simp,safe, simp add: eq)
	+ next
	+ case False
	+ then show ?thesis unfolding \<Phi>_def by (subst cop,simp)
	+ qed
	+ qed
	+
	+ have \<Phi>_mult: "\<forall>a b. a \<in> totatives d \<longrightarrow>
	+ b \<in> totatives d \<longrightarrow> \<Phi> (a * b) = \<Phi> a * \<Phi> b"
	+ proof (safe)
	+ fix a b
	+ assume "a \<in> totatives d" "b \<in> totatives d"
	+ consider (ab) "coprime a d \<and> coprime b d" \|
	+ (a) "coprime a d \<and> \<not> coprime b d" \|
	+ (b) "coprime b d \<and> \<not> coprime a d" \|
	+ (n) "\<not> coprime a d \<and> \<not> coprime b d" by blast
	+ then show "\<Phi> (a * b) = \<Phi> a * \<Phi> b"
	+ proof cases
	+ case ab
	+ then have c_ab:
	+ "coprime (a*b) d" "coprime a d" "coprime b d" by simp+
	+ then have p1: "[f (a * b) = a * b] (mod d)" "coprime (f (a * b)) n"
	+ using m_prop[of "a*b", OF c_ab(1)] by simp+
	+ moreover have p2: "[f a = a] (mod d)" "coprime (f a) n"
	+ "[f b = b] (mod d)" "coprime (f b) n"
	+ using m_prop[of "a",OF c_ab(2)]
	+ m_prop[of "b",OF c_ab(3) ] by simp+
	+ have p1s: "[f (a * b) = (f a) * (f b)] (mod d)"
	+ proof -
	+ have "[f (a * b) = a * b] (mod d)"
	+ using p1(1) by blast
	+ moreover have "[a * b = f(a) * f(b)] (mod d)"
	+ using p2(1) p2(3) by (simp add: cong_mult cong_sym)
	+ ultimately show ?thesis using cong_trans by blast
	+ qed
	+ have p2s: "coprime (f a*f b) n"
	+ using p2(2) p2(4) by simp
	+ have "\<chi> (f (a * b)) = \<chi> (f a * f b)"
	+ using p1s p2s p1(2) b by blast
	+ then show ?thesis
	+ unfolding \<Phi>_def by (simp add: c_ab)
	+ qed (simp_all add: \<Phi>_def)
	+ qed
	+ have d_gr_1: "d > 1" using assms(1,2)
	+ using \<open>0 < d\<close> by linarith
	+ show "\<exists>\<Phi>. dcharacter d \<Phi> \<and> (\<forall>n. \<chi> n = \<Phi> n * \<chi>\<^sub>1 n)"
	+ proof (standard,rule conjI)
	+ show "dcharacter d \<Phi>"
	+ unfolding dcharacter_def residues_nat_def dcharacter_axioms_def
	+ using d_gr_1 \<Phi>_def f_def \<Phi>_mult \<Phi>_1 \<Phi>_periodic by simp
	+ show "\<forall>n. \<chi> n = \<Phi> n * \<chi>\<^sub>1 n"
	+ proof
	+ fix k
	+ show "\<chi> k = \<Phi> k * \<chi>\<^sub>1 k"
	+ proof (cases "coprime k n")
	+ case True
	+ then have "coprime k d" using assms(1) by auto
	+ then have "\<Phi>(k) = \<chi>(f k)" using \<Phi>_def by simp
	+ moreover have "[f k = k] (mod d)"
	+ using m_prop[OF \<open>coprime k d\<close>] by simp
	+ moreover have "\<chi>\<^sub>1 k = 1"
	+ using assms(3) principal_dchar_def \<open>coprime k n\<close> by auto
	+ ultimately show "\<chi>(k) = \<Phi>(k) * \<chi>\<^sub>1(k)"
	+ proof -
	+ assume "\<Phi> k = \<chi> (f k)" "[f k = k] (mod d)" "\<chi>\<^sub>1 k = 1"
	+ then have "\<chi> k = \<chi> (f k)"
	+ using \<open>local.induced_modulus d\<close> induced_modulus_altdef1 assms(1) \<open>d > 0\<close>
	+ True \<open>coprime k d\<close> m_prop(2) by auto
	+ also have "\<dots> = \<Phi> k" by (simp add: \<open>\<Phi> k = \<chi> (f k)\<close>)
	+ also have "\<dots> = \<Phi> k * \<chi>\<^sub>1 k" by (simp add: \<open>\<chi>\<^sub>1 k = 1\<close>)
	+ finally show ?thesis by simp
	+ qed
	+ next
	+ case False
	+ hence "\<chi> k = 0"
	+ using eq_zero_iff by blast
	+ moreover have "\<chi>\<^sub>1 k = 0"
	+ using False assms(3) principal_dchar_def by simp
	+ ultimately show ?thesis by simp
	+ qed
	+ qed
	+ qed
	+next
	+ assume "(\<exists>\<Phi>. dcharacter d \<Phi> \<and> (\<forall>k. \<chi> k = \<Phi> k * \<chi>\<^sub>1 k))"
	+ then obtain \<Phi> where 1: "dcharacter d \<Phi>" "(\<forall>k. \<chi> k = \<Phi> k * \<chi>\<^sub>1 k)" by blast
	+ show "induced_modulus d"
	+ unfolding induced_modulus_def
	+ proof (rule conjI,fact,safe)
	+ fix k
	+ assume 2: "coprime k n" "[k = 1] (mod d)"
	+ then have "\<chi>\<^sub>1 k = 1" "\<Phi> k = 1"
	+ proof (simp add: assms(3) principal_dchar_def)
	+ have "\<Phi> k = \<Phi> (k mod d)" by (simp add: dcharacter.mod[OF 1(1), of k])
	+ also have "\<dots> = \<Phi> (1 mod d)" using cong_def[of k 1 d] 2(2) by simp
	+ also have "\<dots> = \<Phi> 1" using assms(2) "1"(1) dcharacter.mod by blast
	+ also have "\<dots> = 1" using dcharacter.Suc_0[OF 1(1)] by simp
	+ finally show "\<Phi> k = 1" by simp
	+ qed
	+ then show "\<chi> k = 1" using 1(2) by simp
	+ qed
	+qed
	+
	+
	+subsection \<open>The conductor of a character\<close>
	+
	+context dcharacter
	+begin
	+
	+definition "conductor = Min {d. induced_modulus d}"
	+
	+lemma conductor_fin: "finite {d. induced_modulus d}"
	+proof -
	+ let ?A = "{d. induced_modulus d}"
	+ have "?A \<subseteq> {d. d dvd n}"
	+ unfolding induced_modulus_def by blast
	+ moreover have "finite {d. d dvd n}" using n by simp
	+ ultimately show "finite ?A" using finite_subset by auto
	+qed
	+
	+lemma conductor_induced: "induced_modulus conductor"
	+proof -
	+ have "{d. induced_modulus d} \<noteq> {}" using induced_modulus_modulus by blast
	+ then show "induced_modulus conductor"
	+ using Min_in[OF conductor_fin ] conductor_def by auto
	+qed
	+
	+lemma conductor_le_iff: "conductor \<le> a \<longleftrightarrow> (\<exists>d\<le>a. induced_modulus d)"
	+ unfolding conductor_def using conductor_fin induced_modulus_modulus by (subst Min_le_iff) auto
	+
	+lemma conductor_ge_iff: "conductor \<ge> a \<longleftrightarrow> (\<forall>d. induced_modulus d \<longrightarrow> d \<ge> a)"
	+ unfolding conductor_def using conductor_fin induced_modulus_modulus by (subst Min_ge_iff) auto
	+
	+lemma conductor_leI: "induced_modulus d \<Longrightarrow> conductor \<le> d"
	+ by (subst conductor_le_iff) auto
	+
	+lemma conductor_geI: "(\<And>d. induced_modulus d \<Longrightarrow> d \<ge> a) \<Longrightarrow> conductor \<ge> a"
	+ by (subst conductor_ge_iff) auto
	+
	+lemma conductor_dvd: "conductor dvd n"
	+ using conductor_induced unfolding induced_modulus_def by blast
	+
	+lemma conductor_le_modulus: "conductor \<le> n"
	+ using conductor_dvd by (rule dvd_imp_le) (use n in auto)
	+
	+lemma conductor_gr_0: "conductor > 0"
	+ unfolding conductor_def using zero_not_ind_mod
	+ using conductor_def conductor_induced neq0_conv by fastforce
	+
	+lemma conductor_eq_1_iff_principal: "conductor = 1 \<longleftrightarrow> \<chi> = principal_dchar n"
	+proof
	+ assume "conductor = 1"
	+ then have "induced_modulus 1"
	+ using conductor_induced by auto
	+ then show "\<chi> = principal_dchar n"
	+ using one_induced_iff_principal by blast
	+next
	+ assume "\<chi> = principal_dchar n"
	+ then have im_1: "induced_modulus 1" using one_induced_iff_principal by auto
	+ show "conductor = 1"
	+ proof -
	+ have "conductor \<le> 1"
	+ using conductor_fin Min_le[OF conductor_fin,simplified,OF im_1]
	+ by (simp add: conductor_def[symmetric])
	+ then show ?thesis using conductor_gr_0 by auto
	+ qed
	+qed
	+
	+lemma conductor_principal [simp]: "\<chi> = principal_dchar n \<Longrightarrow> conductor = 1"
	+ by (subst conductor_eq_1_iff_principal)
	+
	+lemma nonprimitive_imp_conductor_less:
	+ assumes "\<not>primitive_dchar n \<chi>"
	+ shows "conductor < n"
	+proof -
	+ obtain d where d: "induced_modulus d" "d < n"
	+ using primitive_dchar_iff assms by blast
	+ from d(1) have "conductor \<le> d"
	+ by (rule conductor_leI)
	+ also have "\<dots> < n" by fact
	+ finally show ?thesis .
	+qed
	+
	+lemma (in nonprimitive_dchar) conductor_less_modulus: "conductor < n"
	+ using nonprimitive_imp_conductor_less nonprimitive by metis
	+
	+
	+text \<open>Theorem 8.18\<close>
	+theorem primitive_principal_form:
	+ defines "\<chi>\<^sub>1 \<equiv> principal_dchar n"
	+ assumes "\<chi> \<noteq> principal_dchar n"
	+ shows "\<exists>\<Phi>. primitive_dchar conductor \<Phi> \<and> (\<forall>n. \<chi>(n) = \<Phi>(n) * \<chi>\<^sub>1(n))"
	+proof -
	+ (*
	+ TODO: perhaps residues_nat should be relaxed to allow n = 1.
	+ Then we could remove the unnecessary precondition here.
	+ It makes no real difference though.
	+ *)
	+ from n have n_pos: "n > 0" by simp
	+ define d where "d = conductor"
	+ have induced: "induced_modulus d"
	+ unfolding d_def using conductor_induced by blast
	+ then have d_not_1: "d \<noteq> 1"
	+ using one_induced_iff_principal assms by auto
	+ hence d_gt_1: "d > 1" using conductor_gr_0 by (auto simp: d_def)
	+
	+ from induced obtain \<Phi> where \<Phi>_def: "dcharacter d \<Phi> \<and> (\<forall>n. \<chi> n = \<Phi> n * \<chi>\<^sub>1 n)"
	+ using d_not_1
	+ by (subst (asm) induced_modulus_altdef2) (auto simp: d_def conductor_dvd \<chi>\<^sub>1_def)
	+ have phi_dchars: "\<Phi> \<in> dcharacters d" using \<Phi>_def dcharacters_def by auto
	+
	+ interpret \<Phi>: dcharacter d "residue_mult_group d" \<Phi>
	+ using \<Phi>_def by auto
	+
	+ have \<Phi>_prim: "primitive_dchar d \<Phi>"
	+ proof (rule ccontr)
	+ assume "\<not> primitive_dchar d \<Phi>"
	+ then obtain q where
	+ 1: "q dvd d \<and> q < d \<and> \<Phi>.induced_modulus q"
	+ unfolding \<Phi>.induced_modulus_def \<Phi>.primitive_dchar_iff by blast
	+ then have 2: "induced_modulus q"
	+ proof -
	+ {fix k
	+ assume mod_1: "[k = 1] (mod q)"
	+ assume cop: "coprime k n"
	+ have "\<chi>(k) = \<Phi>(k)*\<chi>\<^sub>1(k)" using \<Phi>_def by auto
	+ also have "\<dots> = \<Phi>(k)"
	+ using cop by (simp add: assms principal_dchar_def)
	+ also have "\<dots> = 1"
	+ using 1 mod_1 \<Phi>.induced_modulus_def
	+ \<open>induced_modulus d\<close> cop induced_modulus_def by auto
	+ finally have "\<chi>(k) = 1" by blast}
	+
	+ then show ?thesis
	+ using induced_modulus_def "1" \<open>induced_modulus d\<close> by auto
	+ qed
	+
	+ from 1 have "q < d" by simp
	+ moreover have "d \<le> q" unfolding d_def
	+ by (intro conductor_leI) fact
	+ ultimately show False by linarith
	+ qed
	+
	+ from \<Phi>_def \<Phi>_prim d_def phi_dchars show ?thesis by blast
	+qed
	+
	+definition primitive_extension :: "nat \<Rightarrow> complex" where
	+ "primitive_extension =
	+ (SOME \<Phi>. primitive_dchar conductor \<Phi> \<and> (\<forall>k. \<chi> k = \<Phi> k * principal_dchar n k))"
	+
	+lemma
	+ assumes nonprincipal: "\<chi> \<noteq> principal_dchar n"
	+ shows primitive_primitive_extension: "primitive_dchar conductor primitive_extension"
	+ and principal_decomposition: "\<chi> k = primitive_extension k * principal_dchar n k"
	+proof -
	+ note * = someI_ex[OF primitive_principal_form[OF nonprincipal], folded primitive_extension_def]
	+ from * show "primitive_dchar conductor primitive_extension" by blast
	+ from * show "\<chi> k = primitive_extension k * principal_dchar n k" by blast
	+qed
	+
	+end
	+
	+
	+subsection \<open>The connection between primitivity and separability\<close>
	+
	+lemma residue_mult_group_coset:
	+ fixes m n m1 m2 :: nat and f :: "nat \<Rightarrow> nat" and G H
	+ defines "G \<equiv> residue_mult_group n"
	+ defines "H \<equiv> residue_mult_group m"
	+ defines "f \<equiv> (\<lambda>k. k mod m)"
	+ assumes "b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f)"
	+ assumes "m1 \<in> b" "m2 \<in> b"
	+ assumes "n > 1" "m dvd n"
	+ shows "m1 mod m = m2 mod m"
	+proof -
	+ have h_1: "\<one>\<^bsub>H\<^esub> = 1"
	+ using assms(2) unfolding residue_mult_group_def totatives_def by simp
	+
	+ from assms(4)
	+ obtain a :: nat where cos_expr: "b = (kernel G H f) #>\<^bsub>G\<^esub> a \<and> a \<in> carrier G"
	+ using RCOSETS_def[of G "kernel G H f"] by blast
	+ then have cop: "coprime a n"
	+ using assms(1) unfolding residue_mult_group_def totatives_def by auto
	+
	+ obtain a' where "[a * a' = 1] (mod n)"
	+ using cong_solve_coprime_nat[OF cop] by auto
	+ then have a_inv: "(a*a') mod n = 1"
	+ using cong_def[of "a*a'" 1 n] assms(7) by simp
	+
	+ have "m1 \<in> (\<Union>h\<in>kernel G H f. {h \<otimes>\<^bsub>G\<^esub> a})"
	+ "m2 \<in> (\<Union>h\<in>kernel G H f. {h \<otimes>\<^bsub>G\<^esub> a})"
	+ using r_coset_def[of G "kernel G H f" a] cos_expr assms(5,6) by blast+
	+ then have "m1 \<in> (\<Union>h\<in>kernel G H f. {(h * a) mod n})"
	+ "m2 \<in> (\<Union>h\<in>kernel G H f. {(h * a) mod n})"
	+ using assms(1) unfolding residue_mult_group_def[of n] by auto
	+ then obtain m1' m2' where
	+ m_expr: "m1 = (m1'* a) mod n \<and> m1' \<in> kernel G H f"
	+ "m2 = (m2'* a) mod n \<and> m2' \<in> kernel G H f"
	+ by blast
	+
	+ have eq_1: "m1 mod m = a mod m"
	+ proof -
	+ have "m1 mod m = ((m1'* a) mod n) mod m" using m_expr by blast
	+ also have "\<dots> = (m1' * a) mod m"
	+ using euclidean_semiring_cancel_class.mod_mod_cancel assms(8) by blast
	+ also have "\<dots> = (m1' mod m) * (a mod m) mod m"
	+ by (simp add: mod_mult_eq)
	+ also have "\<dots> = (a mod m) mod m"
	+ using m_expr(1) h_1 unfolding kernel_def assms(3) by simp
	+ also have "\<dots> = a mod m" by auto
	+ finally show ?thesis by simp
	+ qed
	+
	+ have eq_2: "m2 mod m = a mod m"
	+ proof -
	+ have "m2 mod m = ((m2'* a) mod n) mod m" using m_expr by blast
	+ also have "\<dots> = (m2' * a) mod m"
	+ using euclidean_semiring_cancel_class.mod_mod_cancel assms(8) by blast
	+ also have "\<dots> = (m2' mod m) * (a mod m) mod m"
	+ by (simp add: mod_mult_eq)
	+ also have "\<dots> = (a mod m) mod m"
	+ using m_expr(2) h_1 unfolding kernel_def assms(3) by simp
	+ also have "\<dots> = a mod m" by auto
	+ finally show ?thesis by simp
	+ qed
	+
	+ from eq_1 eq_2 show ?thesis by argo
	+qed
	+
	+lemma residue_mult_group_kernel_partition:
	+ fixes m n :: nat and f :: "nat \<Rightarrow> nat" and G H
	+ defines "G \<equiv> residue_mult_group n"
	+ defines "H \<equiv> residue_mult_group m"
	+ defines "f \<equiv> (\<lambda>k. k mod m)"
	+ assumes "m > 1" "n > 0" "m dvd n"
	+ shows "partition (carrier G) (rcosets\<^bsub>G\<^esub> kernel G H f)"
	+ and "card (rcosets\<^bsub>G\<^esub> kernel G H f) = totient m"
	+ and "card (kernel G H f) = totient n div totient m"
	+ and "b \<in>(rcosets\<^bsub>G\<^esub> kernel G H f) \<Longrightarrow> b \<noteq> {}"
	+ and "b \<in>(rcosets\<^bsub>G\<^esub> kernel G H f) \<Longrightarrow> card (kernel G H f) = card b"
	+ and "bij_betw (\<lambda>b. (the_elem (f ` b))) (rcosets\<^bsub>G\<^esub> kernel G H f) (carrier H)"
	+proof -
	+ have "1 < m" by fact
	+ also have "m \<le> n" using \<open>n > 0\<close> \<open>m dvd n\<close> by (intro dvd_imp_le) auto
	+ finally have "n > 1" .
	+ note mn = \<open>m > 1\<close> \<open>n > 1\<close> \<open>m dvd n\<close> \<open>m \<le> n\<close>
	+
	+ interpret n: residues_nat n G
	+ using mn by unfold_locales (auto simp: assms)
	+ interpret m: residues_nat m H
	+ using mn by unfold_locales (auto simp: assms)
	+
	+ from mn have subset: "f ` carrier G \<subseteq> carrier H"
	+ by (auto simp: assms(1-3) residue_mult_group_def totatives_def
	+ dest: coprime_common_divisor_nat intro!: Nat.gr0I)
	+ moreover have super_set: "carrier H \<subseteq> f ` carrier G"
	+ proof safe
	+ fix k assume "k \<in> carrier H"
	+ hence k: "k > 0" "k \<le> m" "coprime k m"
	+ by (auto simp: assms(2) residue_mult_group_def totatives_def)
	+ from mn \<open>k \<in> carrier H\<close> have "k < m"
	+ by (simp add: totatives_less assms(2) residue_mult_group_def)
	+ define P where "P = {p \<in> prime_factors n. \<not>(p dvd m)}"
	+ define a where "a = \<Prod>P"
	+ have [simp]: "a \<noteq> 0" by (auto simp: P_def a_def intro!: Nat.gr0I)
	+ have [simp]: "prime_factors a = P"
	+ proof -
	+ have "prime_factors a = set_mset (sum prime_factorization P)"
	+ unfolding a_def using mn
	+ by (subst prime_factorization_prod)
	+ (auto simp: P_def prime_factors_dvd prime_gt_0_nat)
	+ also have "sum prime_factorization P = (\<Sum>p\<in>P. {#p#})"
	+ using mn by (intro sum.cong) (auto simp: P_def prime_factorization_prime prime_factors_dvd)
	+ finally show ?thesis by (simp add: P_def)
	+ qed
	+
	+ from mn have "coprime m a"
	+ by (subst coprime_iff_prime_factors_disjoint) (auto simp: P_def)
	+ hence "\<exists>x. [x = k] (mod m) \<and> [x = 1] (mod a)"
	+ by (intro binary_chinese_remainder_nat)
	+ then obtain x where x: "[x = k] (mod m)" "[x = 1] (mod a)"
	+ by auto
	+ from x(1) mn k have [simp]: "x \<noteq> 0"
	+ using coprime_common_divisor[of k m] by (auto intro!: Nat.gr0I simp: cong_def)
	+
	+ from x(2) have "coprime x a"
	+ using cong_imp_coprime cong_sym by force
	+ hence "coprime x (a * m)"
	+ using k cong_imp_coprime[OF cong_sym[OF x(1)]] by auto
	+ also have "?this \<longleftrightarrow> coprime x n" using mn
	+ by (intro coprime_cong_prime_factors)
	+ (auto simp: prime_factors_product P_def in_prime_factors_iff)
	+ finally have "x mod n \<in> totatives n"
	+ using mn by (auto simp: totatives_def intro!: Nat.gr0I)
	+
	+ moreover have "f (x mod n) = k"
	+ using x(1) k mn \<open>k < m\<close> by (auto simp: assms(3) cong_def mod_mod_cancel)
	+ ultimately show "k \<in> f ` carrier G"
	+ by (auto simp: assms(1) residue_mult_group_def)
	+ qed
	+
	+ ultimately have image_eq: "f ` carrier G = carrier H" by blast
	+
	+ have [simp]: "f (k \<otimes>\<^bsub>G\<^esub> l) = f k \<otimes>\<^bsub>H\<^esub> f l" if "k \<in> carrier G" "l \<in> carrier G" for k l
	+ using that mn by (auto simp: assms(1-3) residue_mult_group_def totatives_def
	+ mod_mod_cancel mod_mult_eq)
	+ interpret f: group_hom G H f
	+ using subset by unfold_locales (auto simp: hom_def)
	+
	+ show "bij_betw (\<lambda>b. (the_elem (f ` b))) (rcosets\<^bsub>G\<^esub> kernel G H f) (carrier H)"
	+ unfolding bij_betw_def
	+ proof
	+ show "inj_on (\<lambda>b. (the_elem (f ` b))) (rcosets\<^bsub>G\<^esub> kernel G H f)"
	+ using f.FactGroup_inj_on unfolding FactGroup_def by auto
	+ have eq: "f ` carrier G = carrier H"
	+ using subset super_set by blast
	+ show "(\<lambda>b. the_elem (f ` b)) ` (rcosets\<^bsub>G\<^esub> kernel G H f) = carrier H"
	+ using f.FactGroup_onto[OF eq] unfolding FactGroup_def by simp
	+ qed
	+
	+ show "partition (carrier G) (rcosets\<^bsub>G\<^esub> kernel G H f)"
	+ proof
	+ show "\<And>a. a \<in> carrier G \<Longrightarrow>
	+ \<exists>!b. b \<in> rcosets\<^bsub>G\<^esub> kernel G H f \<and> a \<in> b"
	+ proof -
	+ fix a
	+ assume a_in: "a \<in> carrier G"
	+ show "\<exists>!b. b \<in> rcosets\<^bsub>G\<^esub> kernel G H f \<and> a \<in> b"
	+ proof -
	+ (exists)
	+ have "\<exists>b. b \<in> rcosets\<^bsub>G\<^esub> kernel G H f \<and> a \<in> b"
	+ using a_in n.rcosets_part_G[OF f.subgroup_kernel]
	+ by blast
	+ then show ?thesis
	+ using group.rcos_disjoint[OF n.is_group f.subgroup_kernel]
	+ by (auto simp: disjoint_def)
	+ qed
	+ qed
	+ next
	+ show "\<And>b. b \<in> rcosets\<^bsub>G\<^esub> kernel G H f \<Longrightarrow> b \<subseteq> carrier G"
	+ using n.rcosets_part_G f.subgroup_kernel by auto
	+ qed
	+
	+ (* sizes *)
	+ have lagr: "card (carrier G) = card (rcosets\<^bsub>G\<^esub> kernel G H f) * card (kernel G H f)"
	+ using group.lagrange_finite[OF n.is_group n.fin f.subgroup_kernel] Coset.order_def[of G] by argo
	+ have k_size: "card (kernel G H f) > 0"
	+ using f.subgroup_kernel finite_subset n.subgroupE(1) n.subgroupE(2) by fastforce
	+ have G_size: "card (carrier G) = totient n"
	+ using n.order Coset.order_def[of G] by simp
	+ have H_size: " totient m = card (carrier H)"
	+ using n.order Coset.order_def[of H] by simp
	+ also have "\<dots> = card (carrier (G Mod kernel G H f))"
	+ using f.FactGroup_iso[OF image_eq] card_image f.FactGroup_inj_on f.FactGroup_onto image_eq by fastforce
	+ also have "\<dots> = card (carrier G) div card (kernel G H f)"
	+ proof -
	+ have "card (carrier (G Mod kernel G H f)) =
	+ card (rcosets\<^bsub>G\<^esub> kernel G H f)"
	+ unfolding FactGroup_def by simp
	+ also have "\<dots> = card (carrier G) div card (kernel G H f)"
	+ by (simp add: lagr k_size)
	+ finally show ?thesis by blast
	+ qed
	+ also have "\<dots> = totient n div card (kernel G H f)"
	+ using G_size by argo
	+ finally have eq: "totient m = totient n div card (kernel G H f)" by simp
	+ show "card (kernel G H f) = totient n div totient m"
	+ proof -
	+ have "totient m \<noteq> 0"
	+ using totient_0_iff[of m] assms(4) by blast
	+ have "card (kernel G H f) dvd totient n"
	+ using lagr \<open>card (carrier G) = totient n\<close> by auto
	+ have "totient m * card (kernel G H f) = totient n"
	+ unfolding eq using \<open>card (kernel G H f) dvd totient n\<close> by auto
	+ have "totient n div totient m = totient m * card (kernel G H f) div totient m"
	+ using \<open>totient m * card (kernel G H f) = totient n\<close> by auto
	+ also have "\<dots> = card (kernel G H f)"
	+ using nonzero_mult_div_cancel_left[OF \<open>totient m \<noteq> 0\<close>] by blast
	+ finally show ?thesis by auto
	+ qed
	+
	+ show "card (rcosets\<^bsub>G\<^esub> kernel G H f) = totient m"
	+ proof -
	+ have H_size: " totient m = card (carrier H)"
	+ using n.order Coset.order_def[of H] by simp
	+ also have "\<dots> = card (carrier (G Mod kernel G H f))"
	+ using f.FactGroup_iso[OF image_eq] card_image f.FactGroup_inj_on f.FactGroup_onto image_eq by fastforce
	+ also have "card (carrier (G Mod kernel G H f)) =
	+ card (rcosets\<^bsub>G\<^esub> kernel G H f)"
	+ unfolding FactGroup_def by simp
	+ finally show "card (rcosets\<^bsub>G\<^esub> kernel G H f) = totient m"
	+ by argo
	+ qed
	+
	+ assume "b \<in> rcosets\<^bsub>G\<^esub> kernel G H f"
	+ then show "b \<noteq> {}"
	+ proof -
	+ have "card b = card (kernel G H f)"
	+ using \<open>b \<in> rcosets\<^bsub>G\<^esub> kernel G H f\<close> f.subgroup_kernel n.card_rcosets_equal n.subgroupE(1) by auto
	+ then have "card b > 0"
	+ by (simp add: k_size)
	+ then show ?thesis by auto
	+ qed
	+
	+ assume b_cos: "b \<in> rcosets\<^bsub>G\<^esub> kernel G H f"
	+ show "card (kernel G H f) = card b"
	+ using group.card_rcosets_equal[OF n.is_group b_cos]
	+ f.subgroup_kernel subgroup.subset by blast
	+qed
	+
	+
	+lemma primitive_iff_separable_lemma:
	+ assumes prod: "(\<forall>n. \<chi> n = \<Phi> n * \<chi>\<^sub>1 n) \<and> primitive_dchar d \<Phi>"
	+ assumes \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close> \<open>k > 1\<close>
	+ shows "(\<Sum>m \| m \<in> {1..k} \<and> coprime m k. \<Phi>(m) * unity_root d m) =
	+ (totient k div totient d) * (\<Sum>m \| m \<in> {1..d} \<and> coprime m d. \<Phi>(m) * unity_root d m)"
	+proof -
	+ from assms interpret \<Phi>: primitive_dchar d "residue_mult_group d" \<Phi>
	+ by auto
	+ define G where "G = residue_mult_group k"
	+ define H where "H = residue_mult_group d"
	+ define f where "f = (\<lambda>t. t mod d)"
	+
	+ from residue_mult_group_kernel_partition(2)[OF \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close>]
	+ have fin_cosets: "finite (rcosets\<^bsub>G\<^esub> kernel G H f)"
	+ using \<open>1 < d\<close> card_infinite by (fastforce simp: G_def H_def f_def)
	+
	+ have fin_G: "finite (carrier G)"
	+ unfolding G_def residue_mult_group_def by simp
	+
	+ have eq: "(\<Sum>m \| m \<in> {1..k} \<and> coprime m k. \<Phi>(m) * unity_root d m) =
	+ (\<Sum>m \| m \<in> carrier G . \<Phi>(m) * unity_root d m)"
	+ unfolding residue_mult_group_def totatives_def G_def
	+ by (rule sum.cong,auto)
	+ also have "\<dots> = sum (\<lambda>m. \<Phi>(m) * unity_root d m) (carrier G)" by simp
	+ also have eq': "\<dots> = sum (sum (\<lambda>m. \<Phi> m * unity_root d (int m))) (rcosets\<^bsub>G\<^esub> kernel G H f)"
	+ by (rule disjoint_sum [symmetric])
	+ (use fin_G fin_cosets residue_mult_group_kernel_partition(1)[OF \<open>d > 1\<close> \<open>k > 0\<close> \<open>d dvd k\<close>] in
	+ \<open>auto simp: G_def H_def f_def\<close>)
	+ also have "\<dots> =
	+ (\<Sum>b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f) . (\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)))" by simp
	+ finally have 1: "(\<Sum>m \| m \<in> {1..k} \<and> coprime m k. \<Phi>(m) * unity_root d m) =
	+ (\<Sum>b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f) . (\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)))"
	+ using eq eq' by auto
	+ have eq''': "\<dots> =
	+ (\<Sum>b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f) . (totient k div totient d) * (\<Phi> (the_elem (f ` b)) * unity_root d (int (the_elem (f ` b)))))"
	+ proof (rule sum.cong,simp)
	+ fix b
	+ assume b_in: "b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f)"
	+ note b_not_empty = residue_mult_group_kernel_partition(4)
	+ [OF \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close> b_in[unfolded G_def H_def f_def]]
	+
	+ {
	+ fix m1 m2
	+ assume m_in: "m1 \<in> b" "m2 \<in> b"
	+ have m_mod: "m1 mod d = m2 mod d"
	+ using residue_mult_group_coset[OF b_in[unfolded G_def H_def f_def] m_in \<open>k > 1\<close> \<open>d dvd k\<close>]
	+ by blast
	+ } note m_mod = this
	+ {
	+ fix m1 m2
	+ assume m_in: "m1 \<in> b" "m2 \<in> b"
	+ have "\<Phi> m1 * unity_root d (int m1) = \<Phi> m2 * unity_root d (int m2)"
	+ proof -
	+ have \<Phi>_periodic: "periodic_arithmetic \<Phi> d" using \<Phi>.dir_periodic_arithmetic by blast
	+ have 1: "\<Phi> m1 = \<Phi> m2"
	+ using mod_periodic_arithmetic[OF \<open>periodic_arithmetic \<Phi> d\<close> m_mod[OF m_in]] by simp
	+ have 2: "unity_root d m1 = unity_root d m2"
	+ using m_mod[OF m_in] by (intro unity_root_cong) (auto simp: cong_def simp flip: zmod_int)
	+ from 1 2 show ?thesis by simp
	+ qed
	+ } note all_eq_in_coset = this
	+
	+ from all_eq_in_coset b_not_empty
	+ obtain l where l_prop: "l \<in> b \<and> (\<forall>y \<in> b. \<Phi> y * unity_root d (int y) =
	+ \<Phi> l * unity_root d (int l))" by blast
	+
	+ have "(\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)) =
	+ ((totient k div totient d) * (\<Phi> l * unity_root d (int l)))"
	+ proof -
	+ have "(\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)) =
	+ (\<Sum>m \<in> b. \<Phi> l * unity_root d (int l))"
	+ by (rule sum.cong,simp) (use all_eq_in_coset l_prop in blast)
	+ also have "\<dots> = card b * \<Phi> l * unity_root d (int l)"
	+ by simp
	+ also have "\<dots> = (totient k div totient d) * \<Phi> l * unity_root d (int l)"
	+ using residue_mult_group_kernel_partition(3)[OF \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close>]
	+ residue_mult_group_kernel_partition(5)
	+ [OF \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close> b_in [unfolded G_def H_def f_def]]
	+ by argo
	+ finally have 2:
	+ "(\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)) =
	+ (totient k div totient d) * \<Phi> l * unity_root d (int l)"
	+ by blast
	+ from b_not_empty 2 show ?thesis by auto
	+ qed
	+ also have "\<dots> = ((totient k div totient d) * (\<Phi> (the_elem (f ` b)) * unity_root d (int (the_elem (f ` b)))))"
	+ proof -
	+ have foral: "(\<And>y. y \<in> b \<Longrightarrow> f y = f l)"
	+ using m_mod l_prop unfolding f_def by blast
	+ have eq: "the_elem (f ` b) = f l"
	+ using the_elem_image_unique[of _ f l, OF b_not_empty foral] by simp
	+ have per: "periodic_arithmetic \<Phi> d" using prod \<Phi>.dir_periodic_arithmetic by blast
	+ show ?thesis
	+ unfolding eq using mod_periodic_arithmetic[OF per, of "l mod d" l]
	+ by (auto simp: f_def unity_root_mod zmod_int)
	+ qed
	+ finally show "(\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)) =
	+ ((totient k div totient d) * (\<Phi> (the_elem (f ` b)) * unity_root d (int (the_elem (f ` b)))))"
	+ by blast
	+ qed
	+ have "\<dots> =
	+ (\<Sum>b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f) . (totient k div totient d) * (\<Phi> (the_elem (f ` b)) * unity_root d (int (the_elem (f ` b)))))"
	+ by blast
	+ also have eq'': "
	+ \<dots> = (\<Sum>h \<in> carrier H . (totient k div totient d) * (\<Phi> (h) * unity_root d (int (h))))"
	+ unfolding H_def G_def f_def
	+ by (rule sum.reindex_bij_betw[OF residue_mult_group_kernel_partition(6)[OF \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close>]])
	+ finally have 2: "(\<Sum>m \| m \<in> {1..k} \<and> coprime m k. \<Phi>(m) * unity_root d m) =
	+ (totient k div totient d)(\<Sum>h \<in> carrier H . (\<Phi> (h) unity_root d (int (h))))"
	+ using 1 by (simp add: eq'' eq''' sum_distrib_left)
	+ also have "\<dots> = (totient k div totient d)(\<Sum>m \| m \<in> {1..d} \<and> coprime m d . (\<Phi> (m) unity_root d (int (m))))"
	+ unfolding H_def residue_mult_group_def by (simp add: totatives_def Suc_le_eq)
	+ finally show ?thesis by simp
	+qed
	+
	+
	+text \<open>Theorem 8.19\<close>
	+theorem (in dcharacter) primitive_iff_separable:
	+ "primitive_dchar n \<chi> \<longleftrightarrow> (\<forall>k>0. separable k)"
	+proof (cases "\<chi> = principal_dchar n")
	+ case True
	+ thus ?thesis
	+ using principal_not_primitive principal_not_totally_separable by auto
	+next
	+ case False
	+ note nonprincipal = this
	+ show ?thesis
	+ proof
	+ assume "primitive_dchar n \<chi>"
	+ then interpret A: primitive_dchar n "residue_mult_group n" \<chi> by auto
	+ show "(\<forall>k. k > 0 \<longrightarrow> separable k)"
	+ using n A.primitive_encoding(2) by blast
	+ next
	+ assume tot_separable: "\<forall>k>0. separable k"
	+ {
	+ assume as: "\<not> primitive_dchar n \<chi>"
	+ have "\<exists>r. r \<noteq> 0 \<and> \<not> coprime r n \<and> gauss_sum r \<noteq> 0"
	+ proof -
	+ from n have "n > 0" by simp
	+ define d where "d = conductor"
	+ have "d > 0" unfolding d_def using conductor_gr_0 .
	+ then have "d > 1" using nonprincipal d_def conductor_eq_1_iff_principal by auto
	+ have "d < n" unfolding d_def using nonprimitive_imp_conductor_less[OF as] .
	+ have "d dvd n" unfolding d_def using conductor_dvd by blast
	+ define r where "r = n div d"
	+ have 0: "r \<noteq> 0" unfolding r_def
	+ using \<open>0 < n\<close> \<open>d dvd n\<close> dvd_div_gt0 by auto
	+ have "gcd r n > 1"
	+ unfolding r_def
	+ proof -
	+ have "n div d > 1" using \<open>1 < n\<close> \<open>d < n\<close> \<open>d dvd n\<close> by auto
	+ have "n div d dvd n" using \<open>d dvd n\<close> by force
	+ have "gcd (n div d) n = n div d" using gcd_nat.absorb1[OF \<open>n div d dvd n\<close>] by blast
	+ then show "1 < gcd (n div d) n" using \<open>n div d > 1\<close> by argo
	+ qed
	+ then have 1: "\<not> coprime r n" by auto
	+ define \<chi>\<^sub>1 where "\<chi>\<^sub>1 = principal_dchar n"
	+ from primitive_principal_form[OF nonprincipal]
	+ obtain \<Phi> where
	+ prod: "(\<forall>k. \<chi>(k) = \<Phi>(k)*\<chi>\<^sub>1(k)) \<and> primitive_dchar d \<Phi>"
	+ using d_def unfolding \<chi>\<^sub>1_def by blast
	+ then have prod1: "(\<forall>k. \<chi>(k) = \<Phi>(k)*\<chi>\<^sub>1(k))" "primitive_dchar d \<Phi>" by blast+
	+ then interpret \<Phi>: primitive_dchar d "residue_mult_group d" \<Phi>
	+ by auto
	+
	+ have "gauss_sum r = (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*r))"
	+ unfolding gauss_sum_def by blast
	+ also have "\<dots> = (\<Sum>m = 1..n . \<Phi>(m)\<chi>\<^sub>1(m) unity_root n (m*r))"
	+ by (rule sum.cong,auto simp add: prod)
	+ also have "\<dots> = (\<Sum>m \| m \<in> {1..n} \<and> coprime m n. \<Phi>(m)\<chi>\<^sub>1(m) unity_root n (m*r))"
	+ by (intro sum.mono_neutral_right) (auto simp: \<chi>\<^sub>1_def principal_dchar_def)
	+ also have "\<dots> = (\<Sum>m \| m \<in> {1..n} \<and> coprime m n. \<Phi>(m)\<chi>\<^sub>1(m) unity_root d m)"
	+ proof (rule sum.cong,simp)
	+ fix x
	+ assume "x \<in> {m \<in> {1..n}. coprime m n}"
	+ have "unity_root n (int (x * r)) = unity_root d (int x)"
	+ using unity_div_num[OF \<open>n > 0\<close> \<open>d > 0\<close> \<open>d dvd n\<close>]
	+ by (simp add: algebra_simps r_def)
	+ then show "\<Phi> x * \<chi>\<^sub>1 x * unity_root n (int (x * r)) =
	+ \<Phi> x * \<chi>\<^sub>1 x * unity_root d (int x)" by auto
	+ qed
	+ also have "\<dots> = (\<Sum>m \| m \<in> {1..n} \<and> coprime m n. \<Phi>(m) * unity_root d m)"
	+ by (rule sum.cong,auto simp add: \<chi>\<^sub>1_def principal_dchar_def)
	+ also have "\<dots> = (totient n div totient d) * (\<Sum>m \| m \<in> {1..d} \<and> coprime m d. \<Phi>(m) * unity_root d m)"
	+ using primitive_iff_separable_lemma[OF prod \<open>d > 1\<close> \<open>n > 0\<close> \<open>d dvd n\<close> \<open>n > 1\<close>] by blast
	+ also have "\<dots> = (totient n div totient d) * \<Phi>.gauss_sum 1"
	+ proof -
	+ have "\<Phi>.gauss_sum 1 = (\<Sum>m = 1..d . \<Phi> m * unity_root d (int (m )))"
	+ by (simp add: \<Phi>.gauss_sum_def)
	+ also have "\<dots> = (\<Sum>m \| m \<in> {1..d} . \<Phi> m * unity_root d (int m))"
	+ by (rule sum.cong,auto)
	+ also have "\<dots> = (\<Sum>m \| m \<in> {1..d} \<and> coprime m d. \<Phi>(m) * unity_root d m)"
	+ by (rule sum.mono_neutral_right) (use \<Phi>.eq_zero in auto)
	+ finally have "\<Phi>.gauss_sum 1 = (\<Sum>m \| m \<in> {1..d} \<and> coprime m d. \<Phi>(m) * unity_root d m)"
	+ by blast
	+ then show ?thesis by metis
	+ qed
	+ finally have g_expr: "gauss_sum r = (totient n div totient d) * \<Phi>.gauss_sum 1"
	+ by blast
	+ have t_non_0: "totient n div totient d \<noteq> 0"
	+ by (simp add: \<open>0 < n\<close> \<open>d dvd n\<close> dvd_div_gt0 totient_dvd)
	+ have "(norm (\<Phi>.gauss_sum 1))\<^sup>2 = d"
	+ using \<Phi>.primitive_encoding(3) by simp
	+ then have "\<Phi>.gauss_sum 1 \<noteq> 0"
	+ using \<open>0 < d\<close> by auto
	+ then have 2: "gauss_sum r \<noteq> 0"
	+ using g_expr t_non_0 by auto
	+ from 0 1 2 show "\<exists>r. r \<noteq> 0 \<and> \<not> coprime r n \<and> gauss_sum r \<noteq> 0"
	+ by blast
	+ qed
	+ }
	+ note contr = this
	+
	+ show "primitive_dchar n \<chi>"
	+ proof (rule ccontr)
	+ assume "\<not> primitive_dchar n \<chi>"
	+ then obtain r where 1: "r \<noteq> 0 \<and> \<not> coprime r n \<and> gauss_sum r \<noteq> 0"
	+ using contr by blast
	+ from global_separability_condition tot_separable
	+ have 2: "(\<forall>k>0. \<not> coprime k n \<longrightarrow> gauss_sum k = 0)"
	+ by blast
	+ from 1 2 show "False" by blast
	+ qed
	+ qed
	+qed
	+
	+
	+text\<open>Theorem 8.20\<close>
	+theorem (in primitive_dchar) fourier_primitive:
	+ includes no_vec_lambda_notation
	+ fixes \<tau> :: complex
	+ defines "\<tau> \<equiv> gauss_sum 1 / sqrt n"
	+ shows "\<chi> m = \<tau> / sqrt n * (\<Sum>k=1..n. cnj (\<chi> k) * unity_root n (-m*k))"
	+ and "norm \<tau> = 1"
	+proof -
	+ have chi_not_principal: "\<chi> \<noteq> principal_dchar n"
	+ using principal_not_totally_separable primitive_encoding(2) by blast
	+
	+ then have case_0: "(\<Sum>k=1..n. \<chi> k) = 0"
	+ proof -
	+ have "sum \<chi> {0..n-1} = sum \<chi> {1..n}"
	+ using periodic_arithmetic_sum_periodic_arithmetic_shift[OF dir_periodic_arithmetic, of 1] n
	+ by auto
	+ also have "{0..n-1} = {..<n}"
	+ using n by auto
	+ finally show "(\<Sum>n = 1..n . \<chi> n) = 0"
	+ using sum_dcharacter_block chi_not_principal by simp
	+ qed
	+
	+ have "\<chi> m =
	+ (\<Sum>k = 1..n. 1 / of_nat n * gauss_sum_int (- int k) *
	+ unity_root n (int (m * k)))"
	+ using dcharacter_fourier_expansion[of m] by auto
	+ also have "\<dots> = (\<Sum>k = 1..n. 1 / of_nat n * gauss_sum (nat ((- k) mod n)) *
	+ unity_root n (int (m * k)))"
	+ by (auto simp: gauss_sum_int_conv_gauss_sum)
	+ also have "\<dots> = (\<Sum>k = 1..n. 1 / of_nat n * cnj (\<chi> (nat ((- k) mod n))) * gauss_sum 1 * unity_root n (int (m * k)))"
	+ proof (rule sum.cong,simp)
	+ fix k
	+ assume "k \<in> {1..n}"
	+ have "gauss_sum (nat (- int k mod int n)) =
	+ cnj (\<chi> (nat (- int k mod int n))) * gauss_sum 1"
	+ proof (cases "nat ((- k) mod n) > 0")
	+ case True
	+ then show ?thesis
	+ using mp[OF spec[OF primitive_encoding(2)] True]
	+ unfolding separable_def by auto
	+ next
	+ case False
	+ then have nat_0: "nat ((- k) mod n) = 0" by blast
	+ show ?thesis
	+ proof -
	+ have "gauss_sum (nat (- int k mod int n)) = gauss_sum 0"
	+ using nat_0 by argo
	+ also have "\<dots> = (\<Sum>m = 1..n. \<chi> m)"
	+ unfolding gauss_sum_def by (rule sum.cong) auto
	+ also have "\<dots> = 0" using case_0 by blast
	+ finally have 1: "gauss_sum (nat (- int k mod int n)) = 0"
	+ by blast
	+
	+ have 2: "cnj (\<chi> (nat (- int k mod int n))) = 0"
	+ using nat_0 zero_eq_0 by simp
	+ show ?thesis using 1 2 by simp
	+ qed
	+ qed
	+ then show "1 / of_nat n * gauss_sum (nat (- int k mod int n)) * unity_root n (int (m * k)) =
	+ 1 / of_nat n * cnj (\<chi> (nat (- int k mod int n))) * gauss_sum 1 * unity_root n (int (m * k))"
	+ by auto
	+ qed
	+ also have "\<dots> = (\<Sum>k = 1..n. 1 / of_nat n * cnj (\<chi> (nat (- int k mod int n))) *
	+ gauss_sum 1 * unity_root n (int (m * (nat (int k mod int n)))))"
	+ proof (rule sum.cong,simp)
	+ fix x
	+ assume "x \<in> {1..n}"
	+ have "unity_root n (m * x) = unity_root n (m * x mod n)"
	+ using unity_root_mod_nat[of n "m*x"] by (simp add: nat_mod_as_int)
	+ also have "\<dots> = unity_root n (m * (x mod n))"
	+ by (rule unity_root_cong)
	+ (auto simp: cong_def mod_mult_right_eq simp flip: zmod_int of_nat_mult)
	+ finally have "unity_root n (m * x) = unity_root n (m * (x mod n))" by blast
	+ then show "1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) *
	+ gauss_sum 1 * unity_root n (int (m * x)) =
	+ 1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) * gauss_sum 1 *
	+ unity_root n (int (m * nat (int x mod int n)))"
	+ by (simp add: nat_mod_as_int)
	+ qed
	+ also have "\<dots> = (\<Sum>k = 0..n-1. 1 / of_nat n * cnj (\<chi> k) * gauss_sum 1 * unity_root n (- int (m * k)))"
	+ proof -
	+ have b: "bij_betw (\<lambda>k. nat((-k) mod n)) {1..n} {0..n-1}"
	+ unfolding bij_betw_def
	+ proof
	+ show "inj_on (\<lambda>k. nat (- int k mod int n)) {1..n}"
	+ unfolding inj_on_def
	+ proof (safe)
	+ fix x y
	+ assume a1: "x \<in> {1..n}" "y \<in> {1..n}"
	+ assume a2: "nat (- x mod n) = nat (- y mod n)"
	+ then have "(- x) mod n = - y mod n"
	+ using n eq_nat_nat_iff by auto
	+ then have "[-int x = - int y] (mod n)"
	+ using cong_def by blast
	+ then have "[x = y] (mod n)"
	+ by (simp add: cong_int_iff cong_minus_minus_iff)
	+ then have cong: "x mod n = y mod n" using cong_def by blast
	+ then show "x = y"
	+ proof (cases "x = n")
	+ case True then show ?thesis using cong a1(2) by auto
	+ next
	+ case False
	+ then have "x mod n = x" using a1(1) by auto
	+ then have "y \<noteq> n" using a1(1) local.cong by fastforce
	+ then have "y mod n = y" using a1(2) by auto
	+ then show ?thesis using \<open>x mod n = x\<close> cong by linarith
	+ qed
	+ qed
	+ show "(\<lambda>k. nat (- int k mod int n)) ` {1..n} = {0..n - 1}"
	+ unfolding image_def
	+ proof
	+ let ?A = "{y. \<exists>x\<in>{1..n}. y = nat (- int x mod int n)}"
	+ let ?B = "{0..n - 1}"
	+ show "?A \<subseteq> ?B"
	+ proof
	+ fix y
	+ assume "y \<in> {y. \<exists>x\<in>{1..n}. y = nat (- int x mod int n)}"
	+ then obtain x where "x\<in>{1..n} \<and> y = nat (- int x mod int n)" by blast
	+ then show "y \<in> {0..n - 1}" by (simp add: nat_le_iff of_nat_diff)
	+ qed
	+ show "?A \<supseteq> ?B"
	+ proof
	+ fix x
	+ assume 1: "x \<in> {0..n-1}"
	+ then have "n - x \<in> {1..n}"
	+ using n by auto
	+ have "x = nat (- int (n-x) mod int n)"
	+ proof -
	+ have "nat (- int (n-x) mod int n) = nat (int x) mod int n"
	+ apply(simp add: int_ops(6),rule conjI)
	+ using \<open>n - x \<in> {1..n}\<close> by force+
	+ also have "\<dots> = x"
	+ using 1 n by auto
	+ finally show ?thesis by presburger
	+ qed
	+ then show "x \<in> {y. \<exists>x\<in>{1..n}. y = nat (- int x mod int n)}"
	+ using \<open>n - x \<in> {1..n}\<close> by blast
	+ qed
	+ qed
	+ qed
	+ show ?thesis
	+ proof -
	+ have 1: "(\<Sum>k = 1..n. 1 / of_nat n * cnj (\<chi> (nat (- int k mod int n))) *
	+ gauss_sum 1 * unity_root n (int (m * nat (int k mod int n)))) =
	+ (\<Sum>x = 1..n. 1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) *
	+ gauss_sum 1 * unity_root n (- int (m * nat (- int x mod int n))))"
	+ proof (rule sum.cong,simp)
	+ fix x
	+ have "(int m * (int x mod int n)) mod n = (m*x) mod n"
	+ by (simp add: mod_mult_right_eq zmod_int)
	+ also have "\<dots> = (- ((- int (m*x) mod n))) mod n"
	+ by (simp add: mod_minus_eq of_nat_mod)
	+ have "(int m * (int x mod int n)) mod n = (- (int m * (- int x mod int n))) mod n"
	+ apply(subst mod_mult_right_eq,subst add.inverse_inverse[symmetric],subst (5) add.inverse_inverse[symmetric])
	+ by (subst minus_mult_minus,subst mod_mult_right_eq[symmetric],auto)
	+ then have "unity_root n (int m * (int x mod int n)) =
	+ unity_root n (- (int m * (- int x mod int n)))"
	+ using unity_root_mod[of n "int m * (int x mod int n)"]
	+ unity_root_mod[of n " - (int m * (- int x mod int n))"] by argo
	+ then show "1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) *
	+ gauss_sum 1 *
	+ unity_root n (int (m * nat (int x mod int n))) =
	+ 1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) *
	+ gauss_sum 1 *
	+ unity_root n (- int (m * nat (- int x mod int n)))" by auto
	+ qed
	+ also have 2: "(\<Sum>x = 1..n. 1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) *
	+ gauss_sum 1 * unity_root n (- int (m * nat (- int x mod int n)))) =
	+ (\<Sum>md = 0..n - 1. 1 / of_nat n * cnj (\<chi> md) * gauss_sum 1 *
	+ unity_root n (- int (m * md)))"
	+ using sum.reindex_bij_betw[OF b, of "\<lambda>md. 1 / of_nat n * cnj (\<chi> md) * gauss_sum 1 * unity_root n (- int (m * md))"]
	+ by blast
	+ also have 3: "\<dots> = (\<Sum>k = 0..n - 1.
	+ 1 / of_nat n * cnj (\<chi> k) * gauss_sum 1 *
	+ unity_root n (- int (m * k)))" by blast
	+ finally have "(\<Sum>k = 1..n. 1 / of_nat n * cnj (\<chi> (nat (- int k mod int n))) *
	+ gauss_sum 1 * unity_root n (int (m * nat (int k mod int n)))) =
	+ (\<Sum>k = 0..n - 1.
	+ 1 / of_nat n * cnj (\<chi> k) * gauss_sum 1 *
	+ unity_root n (- int (m * k)))" using 1 2 3 by argo
	+ then show ?thesis by blast
	+ qed
	+ qed
	+ also have "\<dots> = (\<Sum>k = 1..n.
	+ 1 / of_nat n * cnj (\<chi> k) * gauss_sum 1 *
	+ unity_root n (- int (m * k)))"
	+ proof -
	+ let ?f = "(\<lambda>k. 1 / of_nat n * cnj (\<chi> k) * gauss_sum 1 * unity_root n (- int (m * k)))"
	+ have "?f 0 = 0"
	+ using zero_eq_0 by auto
	+ have "?f n = 0"
	+ using zero_eq_0 mod_periodic_arithmetic[OF dir_periodic_arithmetic, of n 0]
	+ by simp
	+ have "(\<Sum>n = 0..n - 1. ?f n) = (\<Sum>n = 1..n - 1. ?f n)"
	+ using sum_shift_lb_Suc0_0[of ?f, OF \<open>?f 0 = 0\<close>]
	+ by auto
	+ also have "\<dots> = (\<Sum>n = 1..n. ?f n)"
	+ proof (rule sum.mono_neutral_left,simp,simp,safe)
	+ fix i
	+ assume "i \<in> {1..n}" "i \<notin> {1..n - 1}"
	+ then have "i = n" using n by auto
	+ then show "1 / of_nat n * cnj (\<chi> i) * gauss_sum 1 * unity_root n (- int (m * i)) = 0"
	+ using \<open>?f n = 0\<close> by blast
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+ also have "\<dots> = (\<Sum>k = 1..n. (\<tau> / sqrt n) * cnj (\<chi> k) * unity_root n (- int (m * k)))"
	+ proof (rule sum.cong,simp)
	+ fix x
	+ assume "x \<in> {1..n}"
	+ have "\<tau> / sqrt (real n) = 1 / of_nat n * gauss_sum 1"
	+ proof -
	+ have "\<tau> / sqrt (real n) = gauss_sum 1 / sqrt n / sqrt n"
	+ using assms by auto
	+ also have "\<dots> = gauss_sum 1 / (sqrt n * sqrt n)"
	+ by (subst divide_divide_eq_left,subst of_real_mult,blast)
	+ also have "\<dots> = gauss_sum 1 / n"
	+ using real_sqrt_mult_self by simp
	+ finally show ?thesis by simp
	+ qed
	+ then show
	+ "1 / of_nat n * cnj (\<chi> x) * gauss_sum 1 * unity_root n (- int (m * x)) =
	+ (\<tau> / sqrt n) * cnj (\<chi> x) * unity_root n (- int (m * x))" by simp
	+ qed
	+ also have "\<dots> = \<tau> / sqrt (real n) *
	+ (\<Sum>k = 1..n. cnj (\<chi> k) * unity_root n (- int (m * k)))"
	+ proof -
	+ have "(\<Sum>k = 1..n. \<tau> / sqrt (real n) * cnj (\<chi> k) * unity_root n (- int (m * k))) =
	+ (\<Sum>k = 1..n. \<tau> / sqrt (real n) * (cnj (\<chi> k) * unity_root n (- int (m * k))))"
	+ by (rule sum.cong,simp, simp add: algebra_simps)
	+ also have "\<dots> = \<tau> / sqrt (real n) * (\<Sum>k = 1..n. cnj (\<chi> k) * unity_root n (- int (m * k)))"
	+ by (rule sum_distrib_left[symmetric])
	+ finally show ?thesis by blast
	+ qed
	+
	+ finally show "\<chi> m = (\<tau> / sqrt (real n)) *
	+ (\<Sum>k=1..n. cnj (\<chi> k) * unity_root n (- int m * int k))" by simp
	+
	+ have 1: "norm (gauss_sum 1) = sqrt n"
	+ using gauss_sum_1_mod_square_eq_k[OF primitive_encoding(2)]
	+ by (simp add: cmod_def)
	+ from assms have 2: "norm \<tau> = norm (gauss_sum 1) / \<bar>sqrt n\<bar>"
	+ by (simp add: norm_divide)
	+ show "norm \<tau> = 1" using 1 2 n by simp
	+qed
	+
	+unbundle vec_lambda_notation
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Gauss_Sums/Gauss_Sums_Auxiliary.thy b/thys/Gauss_Sums/Gauss_Sums_Auxiliary.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Gauss_Sums/Gauss_Sums_Auxiliary.thy
	@@ -0,0 +1,437 @@
	+(*
	+ File: Gauss_Sums_Auxiliary.thy
	+ Authors: Rodrigo Raya, EPFL; Manuel Eberl, TUM
	+*)
	+section \<open>Auxiliary material\<close>
	+theory Gauss_Sums_Auxiliary
	+imports
	+ Dirichlet_L.Dirichlet_Characters
	+ Dirichlet_Series.Moebius_Mu
	+ Dirichlet_Series.More_Totient
	+begin
	+
	+subsection \<open>Various facts\<close>
	+
	+lemma sum_div_reduce:
	+ fixes d :: nat and f :: "nat \<Rightarrow> complex"
	+ assumes "d dvd k" "d > 0"
	+ shows "(\<Sum>n \| n \<in> {1..k} \<and> d dvd n. f n) = (\<Sum>c \<in> {1..k div d}. f (c*d))"
	+ by (rule sum.reindex_bij_witness[of _ "\<lambda>k. k * d" "\<lambda>k. k div d"])
	+ (use assms in \<open>fastforce simp: div_le_mono\<close>)+
	+
	+lemma prod_div_sub:
	+ fixes f :: "nat \<Rightarrow> complex"
	+ assumes "finite A" "B \<subseteq> A" "\<forall>b \<in> B. f b \<noteq> 0"
	+ shows "(\<Prod> i \<in> A - B. f i) = ((\<Prod> i \<in> A. f i) div (\<Prod> i \<in> B. f i))"
	+ using assms
	+proof (induction "card B" arbitrary: B)
	+case 0
	+ then show ?case
	+ using infinite_super by fastforce
	+next
	+ case (Suc n)
	+ then show ?case
	+ proof -
	+ obtain B' x where decomp: "B = B' \<union> {x} \<and> x \<notin> B'"
	+ using card_eq_SucD[OF Suc(2)[symmetric]] insert_is_Un by auto
	+ then have B'card: "card B' = n" using Suc(2)
	+ using Suc.prems(2) assms(1) finite_subset by fastforce
	+ have "prod f (A - B) = prod f ((A-B') - {x})"
	+ by (simp add: decomp,subst Diff_insert,simp)
	+ also have "\<dots> = (prod f (A-B')) div f x"
	+ using prod_diff1[of "A-B'" f x] Suc decomp by auto
	+ also have "\<dots> = (prod f A div prod f B') div f x"
	+ using Suc(1)[of B'] Suc(3) B'card decomp
	+ Suc.prems(2) Suc.prems(3) by force
	+ also have "\<dots> = prod f A div (prod f B' * f x)" by auto
	+ also have "\<dots> = prod f A div prod f B"
	+ using decomp Suc.prems(2) assms(1) finite_subset by fastforce
	+ finally show ?thesis by blast
	+ qed
	+qed
	+
	+lemma linear_gcd:
	+ fixes a b c d :: nat
	+ assumes "a > 0" "b > 0" "c > 0" "d > 0"
	+ assumes "coprime a c" "coprime b d"
	+ shows "gcd (ab) (cd) = (gcd a d) * (gcd b c)"
	+ using assms
	+proof -
	+ define q1 :: nat where "q1 = a div gcd a d"
	+ define q2 :: nat where "q2 = c div gcd b c"
	+ define q3 :: nat where "q3 = b div gcd b c"
	+ define q4 :: nat where "q4 = d div gcd a d"
	+
	+ have "coprime q1 q2" "coprime q3 q4"
	+ unfolding q1_def q2_def q3_def q4_def
	+ proof -
	+ have "coprime (a div gcd a d) c"
	+ using \<open>coprime a c\<close> coprime_mult_left_iff[of "a div gcd a d" "gcd a d" c]
	+ dvd_mult_div_cancel[OF gcd_dvd1, of a b] by simp
	+ then show "coprime (a div gcd a d) (c div gcd b c)"
	+ using coprime_mult_right_iff[of "a div gcd a d" "gcd b c" "c div gcd b c"]
	+ dvd_div_mult_self[OF gcd_dvd2[of b c]] by auto
	+ have "coprime (b div gcd b c) d"
	+ using \<open>coprime b d\<close> coprime_mult_left_iff[of "b div gcd b c" "gcd b c" d]
	+ dvd_mult_div_cancel[OF gcd_dvd1, of a b] by simp
	+ then show "coprime (b div gcd b c) (d div gcd a d)"
	+ using coprime_mult_right_iff[of "b div gcd b c" "gcd a d" "d div gcd a d"]
	+ dvd_div_mult_self[OF gcd_dvd2[of b c]] by auto
	+ qed
	+ moreover have "coprime q1 q4" "coprime q3 q2"
	+ unfolding q1_def q2_def q3_def q4_def
	+ using assms div_gcd_coprime by blast+
	+ ultimately have 1: "coprime (q1q3) (q2q4)"
	+ by simp
	+ have "gcd (ab) (cd) = (gcd a d) * (gcd b c) * gcd (q1q3) (q2q4)"
	+ unfolding q1_def q2_def q3_def q4_def
	+ by (subst gcd_mult_distrib_nat[of "gcd a d * gcd b c"],
	+ simp add: field_simps,
	+ simp add: mult.left_commute semiring_normalization_rules(18))
	+ from this 1 show "gcd (ab) (cd) = (gcd a d) * (gcd b c)" by auto
	+qed
	+
	+lemma reindex_product_bij:
	+ fixes a b m k :: nat
	+ defines "S \<equiv> {(d1,d2). d1 dvd gcd a m \<and> d2 dvd gcd k b}"
	+ defines "T \<equiv> {d. d dvd (gcd a m) * (gcd k b)}"
	+ defines "f \<equiv> (\<lambda>(d1,d2). d1 * d2)"
	+ assumes "coprime a k"
	+ shows "bij_betw f S T"
	+ unfolding bij_betw_def
	+proof
	+ show inj: "inj_on f S"
	+ unfolding f_def
	+ proof -
	+ {fix d1 d2 d1' d2'
	+ assume "(d1,d2) \<in> S" "(d1',d2') \<in> S"
	+ then have dvd: "d1 dvd gcd a m" "d2 dvd gcd k b"
	+ "d1' dvd gcd a m" "d2' dvd gcd k b"
	+ unfolding S_def by simp+
	+ assume "f (d1,d2) = f (d1',d2')"
	+ then have eq: "d1 * d2 = d1' * d2'"
	+ unfolding f_def by simp
	+ from eq dvd have eq1: "d1 = d1'"
	+ by (simp,meson assms coprime_crossproduct_nat coprime_divisors)
	+ from eq dvd have eq2: "d2 = d2'"
	+ using assms(4) eq1 by auto
	+ from eq1 eq2 have "d1 = d1' \<and> d2 = d2'" by simp}
	+ then show "inj_on (\<lambda>(d1, d2). d1 * d2) S"
	+ using S_def f_def by (intro inj_onI,blast)
	+ qed
	+ show surj: "f ` S = T"
	+ proof -
	+ {fix d
	+ have "d dvd (gcd a m) * (gcd k b)
	+ \<longleftrightarrow> (\<exists>d1 d2. d = d1*d2 \<and> d1 dvd gcd a m \<and> d2 dvd gcd k b)"
	+ using division_decomp mult_dvd_mono by blast}
	+ then show ?thesis
	+ unfolding f_def S_def T_def image_def
	+ by auto
	+ qed
	+qed
	+
	+lemma p_div_set:
	+ shows "{p. p \<in>prime_factors a \<and> \<not> p dvd N} =
	+ ({p. p \<in>prime_factors (a*N)} - {p. p \<in>prime_factors N})"
	+ (is "?A = ?B")
	+proof
	+ show "?A \<subseteq> ?B"
	+ proof (simp)
	+ { fix p
	+ assume as: "p \<in># prime_factorization a" "\<not> p dvd N"
	+ then have 1: "p \<in> prime_factors (a * N)"
	+ proof -
	+ from in_prime_factors_iff[of p a] as
	+ have "a \<noteq> 0" "p dvd a" "prime p" by simp+
	+ have "N \<noteq> 0" using \<open>\<not> p dvd N\<close> by blast
	+ have "a * N \<noteq> 0" using \<open>a \<noteq> 0\<close> \<open>N \<noteq> 0\<close> by auto
	+ have "p dvd a*N" using \<open>p dvd a\<close> by simp
	+ show ?thesis
	+ using \<open>aN \<noteq> 0\<close> \<open>p dvd aN\<close> \<open>prime p\<close> in_prime_factors_iff by blast
	+ qed
	+ from as have 2: "p \<notin> prime_factors N" by blast
	+ from 1 2 have "p \<in> prime_factors (a * N) - prime_factors N"
	+ by blast
	+ }
	+ then show "{p. p \<in># prime_factorization a \<and> \<not> p dvd N}
	+ \<subseteq> prime_factors (a * N) - prime_factors N" by blast
	+ qed
	+
	+ show "?B \<subseteq> ?A"
	+ proof (simp)
	+ { fix p
	+ assume as: "p \<in> prime_factors (a * N) - prime_factors N"
	+ then have 1: "\<not> p dvd N"
	+ proof -
	+ from as have "p \<in> prime_factors (a * N)" "p \<notin> prime_factors N"
	+ using DiffD1 DiffD2 by blast+
	+ then show ?thesis by (simp add: in_prime_factors_iff)
	+ qed
	+ have 2: "p \<in># prime_factorization a"
	+ proof -
	+ have "p dvd (aN)" "prime p" "aN \<noteq> 0" using in_prime_factors_iff as by blast+
	+ have "p dvd a" using \<open>\<not> p dvd N\<close> prime_dvd_multD[OF \<open>prime p\<close> \<open>p dvd (a*N)\<close>] by blast
	+ have "a \<noteq> 0" using \<open>a*N \<noteq> 0\<close> by simp
	+ show ?thesis using in_prime_factors_iff \<open>a \<noteq> 0\<close> \<open>p dvd a\<close> \<open>prime p\<close> by blast
	+ qed
	+ from 1 2 have "p \<in> {p. p \<in># prime_factorization a \<and> \<not> p dvd N}" by blast
	+ }
	+ then show "prime_factors (a * N) - prime_factors N
	+ \<subseteq> {p. p \<in># prime_factorization a \<and> \<not> p dvd N}" by blast
	+ qed
	+qed
	+
	+lemma coprime_iff_prime_factors_disjoint:
	+ fixes x y :: "'a :: factorial_semiring"
	+ assumes "x \<noteq> 0" "y \<noteq> 0"
	+ shows "coprime x y \<longleftrightarrow> prime_factors x \<inter> prime_factors y = {}"
	+proof
	+ assume "coprime x y"
	+ have False if "p \<in> prime_factors x" "p \<in> prime_factors y" for p
	+ proof -
	+ from that assms have "p dvd x" "p dvd y"
	+ by (auto simp: prime_factors_dvd)
	+ with \<open>coprime x y\<close> have "p dvd 1"
	+ using coprime_common_divisor by auto
	+ with that assms show False by (auto simp: prime_factors_dvd)
	+ qed
	+ thus "prime_factors x \<inter> prime_factors y = {}" by auto
	+next
	+ assume disjoint: "prime_factors x \<inter> prime_factors y = {}"
	+ show "coprime x y"
	+ proof (rule coprimeI)
	+ fix d assume d: "d dvd x" "d dvd y"
	+ show "is_unit d"
	+ proof (rule ccontr)
	+ assume "\<not>is_unit d"
	+ moreover from this and d assms have "d \<noteq> 0" by auto
	+ ultimately obtain p where p: "prime p" "p dvd d"
	+ using prime_divisor_exists by auto
	+ with d and assms have "p \<in> prime_factors x \<inter> prime_factors y"
	+ by (auto simp: prime_factors_dvd)
	+ with disjoint show False by auto
	+ qed
	+ qed
	+qed
	+
	+lemma coprime_cong_prime_factors:
	+ fixes x y :: "'a :: factorial_semiring_gcd"
	+ assumes "x \<noteq> 0" "y \<noteq> 0" "x' \<noteq> 0" "y' \<noteq> 0"
	+ assumes "prime_factors x = prime_factors x'"
	+ assumes "prime_factors y = prime_factors y'"
	+ shows "coprime x y \<longleftrightarrow> coprime x' y'"
	+ using assms by (simp add: coprime_iff_prime_factors_disjoint)
	+
	+lemma moebius_prod_not_coprime:
	+ assumes "\<not> coprime N d"
	+ shows "moebius_mu (N*d) = 0"
	+proof -
	+ from assms obtain l where l_form: "l dvd N \<and> l dvd d \<and> \<not> is_unit l"
	+ unfolding coprime_def by blast
	+ then have "l * l dvd N * d" using mult_dvd_mono by auto
	+ then have "l\<^sup>2 dvd N*d" by (subst power2_eq_square,blast)
	+ then have "\<not> squarefree (N*d)"
	+ unfolding squarefree_def coprime_def using l_form by blast
	+ then show "moebius_mu (N*d) = 0"
	+ using moebius_mu_def by auto
	+qed
	+
	+text\<open>Theorem 2.18\<close>
	+
	+(* TODO Place in corresponding theory *)
	+lemma sum_divisors_moebius_mu_times_multiplicative:
	+ fixes f :: "nat \<Rightarrow> 'a :: {comm_ring_1}"
	+ assumes "multiplicative_function f" and "n > 0"
	+ shows "(\<Sum>d \| d dvd n. moebius_mu d * f d) = (\<Prod>p\<in>prime_factors n. 1 - f p)"
	+proof -
	+ define g where "g = (\<lambda>n. \<Sum>d \| d dvd n. moebius_mu d * f d)"
	+ define g' where "g' = dirichlet_prod (\<lambda>n. moebius_mu n * f n) (\<lambda>n. if n = 0 then 0 else 1)"
	+ interpret f: multiplicative_function f by fact
	+ have "multiplicative_function (\<lambda>n. if n = 0 then 0 else 1 :: 'a)"
	+ by standard auto
	+ interpret multiplicative_function g' unfolding g'_def
	+ by (intro multiplicative_dirichlet_prod multiplicative_function_mult
	+ moebius_mu.multiplicative_function_axioms assms) fact+
	+
	+ have g'_primepow: "g' (p ^ k) = 1 - f p" if "prime p" "k > 0" for p k
	+ proof -
	+ have "g' (p ^ k) = (\<Sum>i\<le>k. moebius_mu (p ^ i) * f (p ^ i))"
	+ using that by (simp add: g'_def dirichlet_prod_prime_power)
	+ also have "\<dots> = (\<Sum>i\<in>{0, 1}. moebius_mu (p ^ i) * f (p ^ i))"
	+ using that by (intro sum.mono_neutral_right) (auto simp: moebius_mu_power')
	+ also have "\<dots> = 1 - f p"
	+ using that by (simp add: moebius_mu.prime)
	+ finally show ?thesis .
	+ qed
	+
	+ have "g' n = g n"
	+ by (simp add: g_def g'_def dirichlet_prod_def)
	+ also from assms have "g' n = (\<Prod>p\<in>prime_factors n. g' (p ^ multiplicity p n))"
	+ by (intro prod_prime_factors) auto
	+ also have "\<dots> = (\<Prod>p\<in>prime_factors n. 1 - f p)"
	+ by (intro prod.cong) (auto simp: g'_primepow prime_factors_multiplicity)
	+ finally show ?thesis by (simp add: g_def)
	+qed
	+
	+lemma multiplicative_ind_coprime [intro]: "multiplicative_function (ind (coprime N))"
	+ by (intro multiplicative_function_ind) auto
	+
	+lemma sum_divisors_moebius_mu_times_multiplicative_revisited:
	+ fixes f :: "nat \<Rightarrow> 'a :: {comm_ring_1}"
	+ assumes "multiplicative_function f" "n > 0" "N > 0"
	+ shows "(\<Sum>d \| d dvd n \<and> coprime N d. moebius_mu d * f d) =
	+ (\<Prod>p\<in>{p. p \<in> prime_factors n \<and> \<not> (p dvd N)}. 1 - f p)"
	+proof -
	+ have "(\<Sum>d \| d dvd n \<and> coprime N d. moebius_mu d * f d) =
	+ (\<Sum>d \| d dvd n. moebius_mu d * (ind (coprime N) d * f d))"
	+ using assms by (intro sum.mono_neutral_cong_left) (auto simp: ind_def)
	+ also have "\<dots> = (\<Prod>p\<in>prime_factors n. 1 - ind (coprime N) p * f p)"
	+ using assms by (intro sum_divisors_moebius_mu_times_multiplicative)
	+ (auto intro: multiplicative_function_mult)
	+ also from assms have "\<dots> = (\<Prod>p \| p \<in> prime_factors n \<and> \<not>(p dvd N). 1 - f p)"
	+ by (intro prod.mono_neutral_cong_right)
	+ (auto simp: ind_def prime_factors_dvd coprime_commute dest: prime_imp_coprime)
	+ finally show ?thesis .
	+qed
	+
	+subsection \<open>Neutral element of the Dirichlet product\<close>
	+
	+definition "dirichlet_prod_neutral n = (if n = 1 then 1 else 0)" for n :: nat
	+
	+lemma dirichlet_prod_neutral_intro:
	+ fixes S :: "nat \<Rightarrow> complex" and f :: "nat \<Rightarrow> nat \<Rightarrow> complex"
	+ defines "S \<equiv> (\<lambda>(n::nat). (\<Sum>k \| k \<in> {1..n} \<and> coprime k n. (f k n)))"
	+ shows "S(n) = (\<Sum>k \<in> {1..n}. f k n * dirichlet_prod_neutral (gcd k n))"
	+proof -
	+ let ?g = "\<lambda>k. (f k n)* (dirichlet_prod_neutral (gcd k n))"
	+ have zeros: "\<forall>k \<in> {1..n} - {k. k \<in> {1..n} \<and> coprime k n}. ?g k = 0"
	+ proof
	+ fix k
	+ assume "k \<in> {1..n} - {k \<in> {1..n}. coprime k n}"
	+ then show "(f k n) * dirichlet_prod_neutral (gcd k n) = 0"
	+ by (simp add: dirichlet_prod_neutral_def[of "gcd k n"] split: if_splits,presburger)
	+ qed
	+
	+ have "S n = (\<Sum>k \| k \<in> {1..n} \<and> coprime k n. (f k n))"
	+ by (simp add: S_def)
	+ also have "\<dots> = sum ?g {k. k \<in> {1..n} \<and> coprime k n}"
	+ by (simp add: dirichlet_prod_neutral_def split: if_splits)
	+ also have "\<dots> = sum ?g {1..n}"
	+ by (intro sum.mono_neutral_left, auto simp add: zeros)
	+ finally show ?thesis by blast
	+qed
	+
	+lemma dirichlet_prod_neutral_right_neutral:
	+ "dirichlet_prod f dirichlet_prod_neutral n = f n " if "n > 0" for f :: "nat \<Rightarrow> complex" and n
	+proof -
	+ {fix d :: nat
	+ assume "d dvd n"
	+ then have eq: "n = d \<longleftrightarrow> n div d = 1"
	+ using div_self that dvd_mult_div_cancel by force
	+ have "f(d)*dirichlet_prod_neutral(n div d) = (if n = d then f(d) else 0)"
	+ by (simp add: dirichlet_prod_neutral_def eq)}
	+ note summand = this
	+
	+ have "dirichlet_prod f dirichlet_prod_neutral n =
	+ (\<Sum>d \| d dvd n. f(d)*dirichlet_prod_neutral(n div d))"
	+ unfolding dirichlet_prod_def by blast
	+ also have "\<dots> = (\<Sum>d \| d dvd n. (if n = d then f(d) else 0))"
	+ using summand by simp
	+ also have "\<dots> = (\<Sum>d \| d = n. (if n = d then f(d) else 0))"
	+ using that by (intro sum.mono_neutral_right, auto)
	+ also have "\<dots> = f(n)" by simp
	+ finally show ?thesis by simp
	+qed
	+
	+lemma dirichlet_prod_neutral_left_neutral:
	+ "dirichlet_prod dirichlet_prod_neutral f n = f n "
	+ if "n > 0" for f :: "nat \<Rightarrow> complex" and n
	+ using dirichlet_prod_neutral_right_neutral[OF that, of f]
	+ dirichlet_prod_commutes[of f dirichlet_prod_neutral]
	+ by argo
	+
	+corollary I_right_neutral_0:
	+ fixes f :: "nat \<Rightarrow> complex"
	+ assumes "f 0 = 0"
	+ shows "dirichlet_prod f dirichlet_prod_neutral n = f n"
	+ using assms dirichlet_prod_neutral_right_neutral by (cases n, simp, blast)
	+
	+subsection \<open>Multiplicative functions\<close>
	+
	+lemma mult_id: "multiplicative_function id"
	+ by (simp add: multiplicative_function_def)
	+
	+lemma mult_moebius: "multiplicative_function moebius_mu"
	+ using Moebius_Mu.moebius_mu.multiplicative_function_axioms
	+ by simp
	+
	+lemma mult_of_nat: "multiplicative_function of_nat"
	+ using multiplicative_function_def of_nat_0 of_nat_1 of_nat_mult by blast
	+
	+lemma mult_of_nat_c: "completely_multiplicative_function of_nat"
	+ by (simp add: completely_multiplicative_function_def)
	+
	+lemma completely_multiplicative_nonzero:
	+ fixes f :: "nat \<Rightarrow> complex"
	+ assumes "completely_multiplicative_function f"
	+ "d \<noteq> 0"
	+ "\<And>p. prime p \<Longrightarrow> f(p) \<noteq> 0"
	+ shows "f(d) \<noteq> 0"
	+ using assms(2)
	+proof (induction d rule: nat_less_induct)
	+ case (1 n)
	+ then show ?case
	+ proof (cases "n = 1")
	+ case True
	+ then show ?thesis
	+ using assms(1)
	+ unfolding completely_multiplicative_function_def by simp
	+ next
	+ case False
	+ then obtain p where 2:"prime p \<and> p dvd n"
	+ using prime_factor_nat by blast
	+ then obtain a where 3: "n = p * a" "a \<noteq> 0"
	+ using 1 by auto
	+ then have 4: "f(a) \<noteq> 0" using 1
	+ using 2 prime_nat_iff by fastforce
	+ have 5: "f(p) \<noteq> 0" using assms(3) 2 by simp
	+ from 3 4 5 show ?thesis
	+ by (simp add: assms(1) completely_multiplicative_function.mult)
	+ qed
	+qed
	+
	+lemma multipl_div:
	+ fixes m k d1 d2 :: nat and f :: "nat \<Rightarrow> complex"
	+ assumes "multiplicative_function f" "d1 dvd m" "d2 dvd k" "coprime m k"
	+ shows "f ((mk) div (d1d2)) = f(m div d1) * f(k div d2)"
	+ using assms
	+ unfolding multiplicative_function_def
	+ using assms(1) multiplicative_function.mult_coprime by fastforce
	+
	+lemma multipl_div_mono:
	+ fixes m k d :: nat and f :: "nat \<Rightarrow> complex"
	+ assumes "completely_multiplicative_function f"
	+ "d dvd k" "d > 0"
	+ "\<And>p. prime p \<Longrightarrow> f(p) \<noteq> 0"
	+ shows "f (k div d) = f(k) div f(d)"
	+proof -
	+ have "d \<noteq> 0" using assms(2,3) by auto
	+ then have nz: "f(d) \<noteq> 0" using assms(1,4) completely_multiplicative_nonzero by simp
	+
	+ from assms(2,3) obtain a where div: "k = a * d " by fastforce
	+ have "f (k div d) = f ((a*d) div d)" using div by simp
	+ also have "\<dots> = f(a)" using assms(3) div by simp
	+ also have "\<dots> = f(a)*f(d) div f(d)" using nz by auto
	+ also have "\<dots> = f(a*d) div f(d)"
	+ by (simp add: div assms(1) completely_multiplicative_function.mult)
	+ also have "\<dots> = f (k) div f(d)" using div by simp
	+ finally show ?thesis by simp
	+qed
	+
	+lemma comp_to_mult: "completely_multiplicative_function f \<Longrightarrow>
	+ multiplicative_function f"
	+ unfolding completely_multiplicative_function_def
	+ multiplicative_function_def by auto
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Gauss_Sums/Periodic_Arithmetic.thy b/thys/Gauss_Sums/Periodic_Arithmetic.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Gauss_Sums/Periodic_Arithmetic.thy
	@@ -0,0 +1,294 @@
	+(*
	+ File: Periodic_Arithmetic.thy
	+ Authors: Rodrigo Raya, EPFL; Manuel Eberl, TUM
	+
	+ Periodic arithmetic functions
	+*)
	+section \<open>Periodic arithmetic functions\<close>
	+theory Periodic_Arithmetic
	+imports
	+ Complex_Main
	+ "HOL-Number_Theory.Cong"
	+begin
	+
	+definition
	+ "periodic_arithmetic f k = (\<forall>n. f (n+k) = f n)"
	+ for n :: int and k :: nat and f :: "nat \<Rightarrow> complex"
	+
	+lemma const_periodic_arithmetic: "periodic_arithmetic (\<lambda>x. y) k"
	+ unfolding periodic_arithmetic_def by blast
	+
	+lemma add_periodic_arithmetic:
	+ fixes f g :: "nat \<Rightarrow> complex"
	+ assumes "periodic_arithmetic f k"
	+ assumes "periodic_arithmetic g k"
	+ shows "periodic_arithmetic (\<lambda>n. f n + g n) k"
	+ using assms unfolding periodic_arithmetic_def by simp
	+
	+lemma mult_periodic_arithmetic:
	+ fixes f g :: "nat \<Rightarrow> complex"
	+ assumes "periodic_arithmetic f k"
	+ assumes "periodic_arithmetic g k"
	+ shows "periodic_arithmetic (\<lambda>n. f n * g n) k"
	+ using assms unfolding periodic_arithmetic_def by simp
	+
	+lemma scalar_mult_periodic_arithmetic:
	+ fixes f :: "nat \<Rightarrow> complex" and a :: complex
	+ assumes "periodic_arithmetic f k"
	+ shows "periodic_arithmetic (\<lambda>n. a * f n) k"
	+ using mult_periodic_arithmetic[OF const_periodic_arithmetic[of a k] assms(1)] by simp
	+
	+lemma fin_sum_periodic_arithmetic_set:
	+ fixes f g :: "nat \<Rightarrow> complex"
	+ assumes "\<forall>i\<in>A. periodic_arithmetic (h i) k"
	+ shows "periodic_arithmetic (\<lambda>n. \<Sum>i \<in> A. h i n) k"
	+ using assms by (simp add: periodic_arithmetic_def)
	+
	+lemma mult_period:
	+ assumes "periodic_arithmetic g k"
	+ shows "periodic_arithmetic g (k*q)"
	+ using assms
	+proof (induction q)
	+ case 0 then show ?case unfolding periodic_arithmetic_def by simp
	+next
	+ case (Suc m)
	+ then show ?case
	+ unfolding periodic_arithmetic_def
	+ proof -
	+ { fix n
	+ have "g (n + k * Suc m) = g (n + k + k * m)"
	+ by (simp add: algebra_simps)
	+ also have "\<dots> = g(n)"
	+ using Suc.IH[OF Suc.prems] assms
	+ unfolding periodic_arithmetic_def by simp
	+ finally have "g (n + k * Suc m) = g(n)" by blast
	+ }
	+ then show "\<forall>n. g (n + k * Suc m) = g n" by auto
	+ qed
	+qed
	+
	+lemma unique_periodic_arithmetic_extension:
	+ assumes "k > 0"
	+ assumes "\<forall>j<k. g j = h j"
	+ assumes "periodic_arithmetic g k" and "periodic_arithmetic h k"
	+ shows "g i = h i"
	+proof (cases "i < k")
	+ case True then show ?thesis using assms by simp
	+next
	+ case False then show ?thesis
	+ proof -
	+ have "k * (i div k) + (i mod k) = i \<and> (i mod k) < k"
	+ by (simp add: assms(1) algebra_simps)
	+ then obtain q r where euclid_div: "k*q + r = i \<and> r < k"
	+ using mult.commute by blast
	+ from assms(3) assms(4)
	+ have "periodic_arithmetic g (kq)" "periodic_arithmetic h (kq)"
	+ using mult_period by simp+
	+ have "g(k*q+r) = g(r)"
	+ using \<open>periodic_arithmetic g (k*q)\<close> unfolding periodic_arithmetic_def
	+ using add.commute[of "k*q" r] by presburger
	+ also have "\<dots> = h(r)"
	+ using euclid_div assms(2) by simp
	+ also have "\<dots> = h(k*q+r)"
	+ using \<open>periodic_arithmetic h (kq)\<close> add.commute[of "kq" r]
	+ unfolding periodic_arithmetic_def by presburger
	+ also have "\<dots> = h(i)" using euclid_div by simp
	+ finally show "g(i) = h(i)" using euclid_div by simp
	+ qed
	+qed
	+
	+lemma periodic_arithmetic_sum_periodic_arithmetic:
	+ assumes "periodic_arithmetic f k"
	+ shows "(\<Sum>l \<in> {m..n}. f l) = (\<Sum>l \<in> {m+k..n+k}. f l)"
	+ using periodic_arithmetic_def assms
	+ by (intro sum.reindex_bij_witness
	+ [of "{m..n}" "\<lambda>l. l-k" "\<lambda>l. l+k" "{m+k..n+k}" f f])
	+ auto
	+
	+lemma mod_periodic_arithmetic:
	+ fixes n m :: nat
	+ assumes "periodic_arithmetic f k"
	+ assumes "n mod k = m mod k"
	+ shows "f n = f m"
	+proof -
	+ obtain q where 1: "n = q*k+(n mod k)"
	+ using div_mult_mod_eq[of n k,symmetric] by blast
	+ obtain q' where 2: "m = q'*k+(m mod k)"
	+ using div_mult_mod_eq[of m k,symmetric] by blast
	+ from 1 have "f n = f (q*k+(n mod k))" by auto
	+ also have "\<dots> = f (n mod k)"
	+ using mult_period[of f k q] assms(1) periodic_arithmetic_def[of f "k*q"]
	+ by (simp add: algebra_simps,subst add.commute,blast)
	+ also have "\<dots> = f (m mod k)" using assms(2) by auto
	+ also have "\<dots> = f (q'*k+(m mod k))"
	+ using mult_period[of f k q'] assms(1) periodic_arithmetic_def[of f "k*q'"]
	+ by (simp add: algebra_simps,subst add.commute,presburger)
	+ also have "\<dots> = f m" using 2 by auto
	+ finally show "f n = f m" by simp
	+qed
	+
	+lemma cong_periodic_arithmetic:
	+ assumes "periodic_arithmetic f k" "[a = b] (mod k)"
	+ shows "f a = f b"
	+ using assms mod_periodic_arithmetic[of f k a b] by (auto simp: cong_def)
	+
	+lemma cong_nat_imp_eq:
	+ fixes m :: nat
	+ assumes "m > 0" "x \<in> {a..<a+m}" "y \<in> {a..<a+m}" "[x = y] (mod m)"
	+ shows "x = y"
	+ using assms
	+proof (induction x y rule: linorder_wlog)
	+ case (le x y)
	+ have "[y - x = 0] (mod m)"
	+ using cong_diff_iff_cong_0_nat cong_sym le by blast
	+ thus "x = y"
	+ using le by (auto simp: cong_def)
	+qed (auto simp: cong_sym)
	+
	+lemma inj_on_mod_nat:
	+ fixes m :: nat
	+ assumes "m > 0"
	+ shows "inj_on (\<lambda>x. x mod m) {a..<a+m}"
	+proof
	+ fix x y assume xy: "x \<in> {a..<a+m}" "y \<in> {a..<a+m}" and eq: "x mod m = y mod m"
	+ from \<open>m > 0\<close> and xy show "x = y"
	+ by (rule cong_nat_imp_eq) (use eq in \<open>simp_all add: cong_def\<close>)
	+qed
	+
	+lemma bij_betw_mod_nat_atLeastLessThan:
	+ fixes k d :: nat
	+ assumes "k > 0"
	+ defines "g \<equiv> (\<lambda>i. nat ((int i - int d) mod int k) + d)"
	+ shows "bij_betw (\<lambda>i. i mod k) {d..<d+k} {..<k}"
	+ unfolding bij_betw_def
	+proof
	+ show inj: "inj_on (\<lambda>i. i mod k) {d..<d + k}"
	+ by (rule inj_on_mod_nat) fact+
	+ have "(\<lambda>i. i mod k) ` {d..<d + k} \<subseteq> {..<k}"
	+ by auto
	+ moreover have "card ((\<lambda>i. i mod k) ` {d..<d + k}) = card {..<k}"
	+ using inj by (subst card_image) auto
	+ ultimately show "(\<lambda>i. i mod k) ` {d..<d + k} = {..<k}"
	+ by (intro card_subset_eq) auto
	+qed
	+
	+lemma periodic_arithmetic_sum_periodic_arithmetic_shift:
	+ fixes k d :: nat
	+ assumes "periodic_arithmetic f k" "k > 0" "d > 0"
	+ shows "(\<Sum>l \<in> {0..k-1}. f l) = (\<Sum>l \<in> {d..d+k-1}. f l)"
	+proof -
	+ have "(\<Sum>l \<in> {0..k-1}. f l) = (\<Sum>l \<in> {0..<k}. f l)"
	+ using assms(2) by (intro sum.cong) auto
	+ also have "\<dots> = (\<Sum>l \<in> {d..<d+k}. f (l mod k))"
	+ using assms(2)
	+ by (simp add: sum.reindex_bij_betw[OF bij_betw_mod_nat_atLeastLessThan[of k d]]
	+ lessThan_atLeast0)
	+ also have "\<dots> = (\<Sum>l \<in> {d..<d+k}. f l)"
	+ using mod_periodic_arithmetic[of f k] assms(1) sum.cong
	+ by (meson mod_mod_trivial)
	+ also have "\<dots> = (\<Sum>l \<in> {d..d+k-1}. f l)"
	+ using assms(2,3) by (intro sum.cong) auto
	+ finally show ?thesis by auto
	+qed
	+
	+lemma self_bij_0_k:
	+ fixes a k :: nat
	+ assumes "coprime a k" "[a*i = 1] (mod k)" "k > 0"
	+ shows "bij_betw (\<lambda>r. r*a mod k) {0..k-1} {0..k-1}"
	+ unfolding bij_betw_def
	+proof
	+ show "inj_on (\<lambda>r. r*a mod k) {0..k-1}"
	+ proof -
	+ {fix r1 r2
	+ assume in_k: "r1 \<in> {0..k-1}" "r2 \<in> {0..k-1}"
	+ assume as: "[r1a = r2a] (mod k)"
	+ then have "[r1ai = r2ai] (mod k)"
	+ using cong_scalar_right by blast
	+ then have "[r1 = r2] (mod k)"
	+ using cong_mult_rcancel_nat as assms(1) by simp
	+ then have "r1 = r2" using in_k
	+ using assms(3) cong_less_modulus_unique_nat by auto}
	+ note eq = this
	+ show ?thesis unfolding inj_on_def
	+ by (safe, simp add: eq cong_def)
	+ qed
	+ define f where "f = (\<lambda>r. r * a mod k)"
	+ show "f ` {0..k - 1} = {0..k - 1} "
	+ unfolding image_def
	+ proof (standard)
	+ show "{y. \<exists>x\<in>{0..k - 1}. y = f x} \<subseteq> {0..k - 1}"
	+ proof -
	+ {fix y
	+ assume "y \<in> {y. \<exists>x\<in>{0..k - 1}. y = f x}"
	+ then obtain x where "y = f x" by blast
	+ then have "y \<in> {0..k-1}"
	+ unfolding f_def
	+ using Suc_pred assms(3) lessThan_Suc_atMost by fastforce}
	+ then show ?thesis by blast
	+ qed
	+ show "{0..k - 1} \<subseteq> {y. \<exists>x\<in>{0..k - 1}. y = f x}"
	+ proof -
	+ { fix x
	+ assume ass: "x \<in> {0..k-1}"
	+ then have "x * i mod k \<in> {0..k-1}"
	+ proof -
	+ have "x * i mod k \<in> {0..<k}" by (simp add: assms(3))
	+ have "{0..<k} = {0..k-1}" using Suc_diff_1 assms(3) by auto
	+ show ?thesis using \<open>x * i mod k \<in> {0..<k}\<close> \<open>{0..<k} = {0..k-1}\<close> by blast
	+ qed
	+ then have "f (x * i mod k) = x"
	+ proof -
	+ have "f (x * i mod k) = (x * i mod k) * a mod k"
	+ unfolding f_def by blast
	+ also have "\<dots> = (xia) mod k"
	+ by (simp add: mod_mult_left_eq)
	+ also have "\<dots> = (x*1) mod k"
	+ using assms(2)
	+ unfolding cong_def
	+ by (subst mult.assoc, subst (2) mult.commute,
	+ subst mod_mult_right_eq[symmetric],simp)
	+ also have "\<dots> = x" using ass assms(3) by auto
	+ finally show ?thesis .
	+ qed
	+ then have "x \<in> {y. \<exists>x\<in>{0..k - 1}. y = f x}"
	+ using \<open>x * i mod k \<in> {0..k-1}\<close> by force
	+ }
	+ then show ?thesis by blast
	+ qed
	+ qed
	+qed
	+
	+lemma periodic_arithmetic_homothecy:
	+ assumes "periodic_arithmetic f k"
	+ shows "periodic_arithmetic (\<lambda>l. f (l*a)) k"
	+ unfolding periodic_arithmetic_def
	+proof
	+ fix n
	+ have "f ((n + k) * a) = f(na+ka)" by (simp add: algebra_simps)
	+ also have "\<dots> = f(n*a)"
	+ using mult_period[OF assms] unfolding periodic_arithmetic_def by simp
	+ finally show "f ((n + k) * a) = f (n * a)" by simp
	+qed
	+
	+theorem periodic_arithmetic_remove_homothecy:
	+ assumes "coprime a k" "periodic_arithmetic f k" "k > 0"
	+ shows "(\<Sum>l=1..k. f l) = (\<Sum>l=1..k. f (l*a))"
	+proof -
	+ obtain i where inv: "[a*i = 1] (mod k)"
	+ using assms(1) coprime_iff_invertible_nat[of a k] by auto
	+ from this self_bij_0_k assms
	+ have bij: "bij_betw (\<lambda>r. r * a mod k) {0..k - 1} {0..k - 1}" by blast
	+
	+ have "(\<Sum>l = 1..k. f(l)) = (\<Sum>l = 0..k-1. f(l))"
	+ using periodic_arithmetic_sum_periodic_arithmetic_shift[of f k 1] assms by simp
	+ also have "\<dots> = (\<Sum>l = 0..k-1. f(l*a mod k))"
	+ using sum.reindex_bij_betw[OF bij,symmetric] by blast
	+ also have "\<dots> = (\<Sum>l = 0..k-1. f(l*a))"
	+ by (intro sum.cong refl) (use mod_periodic_arithmetic[OF assms(2)] mod_mod_trivial in blast)
	+ also have "\<dots> = (\<Sum>l = 1..k. f(l*a))"
	+ using periodic_arithmetic_sum_periodic_arithmetic_shift[of "(\<lambda>l. f(l*a))" k 1]
	+ periodic_arithmetic_homothecy[OF assms(2)] assms(3) by fastforce
	+ finally show ?thesis by blast
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Gauss_Sums/Polya_Vinogradov.thy b/thys/Gauss_Sums/Polya_Vinogradov.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Gauss_Sums/Polya_Vinogradov.thy
	@@ -0,0 +1,873 @@
	+(*
	+ File: Polya_Vinogradov.thy
	+ Authors: Rodrigo Raya, EPFL; Manuel Eberl, TUM
	+
	+ The Pólya–Vinogradov inequality, both the general case and the stronger variant for
	+ primitive characters.
	+*)
	+section \<open>The Pólya--Vinogradov Inequality\<close>
	+theory Polya_Vinogradov
	+imports
	+ Gauss_Sums
	+ "Dirichlet_Series.Divisor_Count"
	+begin
	+
	+unbundle no_vec_lambda_notation
	+
	+subsection \<open>The case of primitive characters\<close>
	+
	+text \<open>
	+ We first prove a stronger variant of the Pólya--Vinogradov inequality for primitive characters.
	+ The fully general variant will then simply be a corollary of this. First, we need some bounds on
	+ logarithms, exponentials, and the harmonic numbers:
	+\<close>
	+
	+(* TODO: Move? *)
	+lemma ln_add_one_self_less_self:
	+ fixes x :: real
	+ assumes "x > 0"
	+ shows "ln (1 + x) < x"
	+proof -
	+ have "0 \<le> x" "0 < x" "exp x > 0" "1+x > 0" using assms by simp+
	+ have "1 + x < 1 + x + x\<^sup>2 / 2"
	+ using \<open>0 < x\<close> by auto
	+ also have "\<dots> \<le> exp x"
	+ using exp_lower_Taylor_quadratic[OF \<open>0 \<le> x\<close>] by blast
	+ finally have "1 + x < exp (x)" by blast
	+ then have "ln (1 + x) < ln (exp (x))"
	+ using ln_less_cancel_iff[OF \<open>1+x > 0\<close> \<open>exp(x) > 0\<close>] by auto
	+ also have "\<dots> = x" using ln_exp by blast
	+ finally show ?thesis by auto
	+qed
	+
	+lemma exp_1_bounds:
	+ assumes "x > (0::real)"
	+ shows "exp 1 > (1 + 1 / x) powr x" and "exp 1 < (1 + 1 / x) powr (x+1)"
	+proof -
	+ have "ln (1 + 1 / x) < 1 / x"
	+ using ln_add_one_self_less_self assms by simp
	+ thus "exp 1 > (1 + 1 / x) powr x" using assms
	+ by (simp add: field_simps powr_def)
	+next
	+ have "1 < (x + 1) * ln ((x + 1) / x)" (is "_ < ?f x")
	+ proof (rule DERIV_neg_imp_decreasing_at_top[where ?f = ?f])
	+ fix t assume t: "x \<le> t"
	+ have "(?f has_field_derivative (ln (1 + 1 / t) - 1 / t)) (at t)"
	+ using t assms by (auto intro!: derivative_eq_intros simp:divide_simps)
	+ moreover have "ln (1 + 1 / t) - 1 / t < 0"
	+ using ln_add_one_self_less_self[of "1 / t"] t assms by auto
	+ ultimately show "\<exists>y. ((\<lambda>t. (t + 1) * ln ((t + 1) / t)) has_real_derivative y) (at t) \<and> y < 0"
	+ by blast
	+ qed real_asymp
	+ thus "exp 1 < (1 + 1 / x) powr (x + 1)"
	+ using assms by (simp add: powr_def field_simps)
	+qed
	+
	+lemma harm_aux_ineq_1:
	+ fixes k :: real
	+ assumes "k > 1"
	+ shows "1 / k < ln (1 + 1 / (k - 1))"
	+proof -
	+ have "k-1 > 0" \<open>k > 0\<close> using assms by simp+
	+ from exp_1_bounds(2)[OF \<open>k-1 > 0\<close>]
	+ have "exp 1 < (1 + 1 / (k - 1)) powr k" by simp
	+ then have n_z: "(1 + 1 / (k - 1)) powr k > 0"
	+ using assms not_exp_less_zero by auto
	+
	+ have "(1::real) = ln (exp(1))" using ln_exp by auto
	+ also have "\<dots> < ln ((1 + 1 / (k - 1)) powr k)"
	+ using ln_less_cancel_iff[of "exp(1)",simplified,OF \<open>(1 + 1 / (k - 1)) powr k > 0\<close>]
	+ exp_1_bounds[OF \<open>k - 1 > 0\<close>] by simp
	+ also have "\<dots> = k * ln (1 + 1 / (k - 1))"
	+ using ln_powr n_z by simp
	+ finally have "1 < k * ln (1 + 1 / (k - 1))"
	+ by blast
	+ then show ?thesis using assms by (simp add: field_simps)
	+qed
	+
	+lemma harm_aux_ineq_2_lemma:
	+ assumes "x \<ge> (0::real)"
	+ shows "1 < (x + 1) * ln (1 + 2 / (2 * x + 1))"
	+proof -
	+ have "0 < ln (1+2/(2*x+1)) - 1 / (x + 1)" (is "_ < ?f x")
	+ proof (rule DERIV_neg_imp_decreasing_at_top[where ?f = ?f])
	+ fix t assume t: "x \<le> t"
	+ from assms t have "3 + 8 * t + 4 * t^2 > 0"
	+ by (intro add_pos_nonneg) auto
	+ hence : "3 + 8 t + 4 * t^2 \<noteq> 0"
	+ by auto
	+ have "(?f has_field_derivative (-1 / ((1 + t)^2 * (3 + 8 * t + 4 * t ^ 2)))) (at t)"
	+ apply (insert assms t *, (rule derivative_eq_intros refl \| simp add: add_pos_pos)+)
	+ apply (auto simp: divide_simps)
	+ apply (auto simp: algebra_simps power2_eq_square)
	+ done
	+ moreover have "-1 / ((1 + t)^2 * (3 + 8 * t + 4 * t^2)) < 0"
	+ using t assms by (intro divide_neg_pos mult_pos_pos add_pos_nonneg) auto
	+ ultimately show "\<exists>y. (?f has_real_derivative y) (at t) \<and> y < 0"
	+ by blast
	+ qed real_asymp
	+ thus "1 < (x + 1) * ln (1+2/(2*x+1))"
	+ using assms by (simp add: field_simps)
	+qed
	+
	+lemma harm_aux_ineq_2:
	+ fixes k :: real
	+ assumes "k \<ge> 1"
	+ shows "1 / (k + 1) < ln (1 + 2 / (2 * k + 1))"
	+proof -
	+ have "k > 0" using assms by auto
	+ have "1 < (k + 1) * ln (1 + 2 / (2 * k + 1))"
	+ using harm_aux_ineq_2_lemma assms by simp
	+ then show ?thesis
	+ by (simp add: \<open>0 < k\<close> add_pos_pos mult.commute mult_imp_div_pos_less)
	+qed
	+
	+lemma nat_0_1_induct [case_names 0 1 step]:
	+ assumes "P 0" "P 1" "\<And>n. n \<ge> 1 \<Longrightarrow> P n \<Longrightarrow> P (Suc n)"
	+ shows "P n"
	+proof (induction n rule: less_induct)
	+ case (less n)
	+ show ?case
	+ using assms(3)[OF _ less.IH[of "n - 1"]]
	+ by (cases "n \<le> 1")
	+ (insert assms(1-2),auto simp: eval_nat_numeral le_Suc_eq)
	+qed
	+
	+lemma harm_less_ln:
	+ fixes m :: nat
	+ assumes "m > 0"
	+ shows "harm m < ln (2 * m + 1)"
	+ using assms
	+proof (induct m rule: nat_0_1_induct)
	+ case 0
	+ then show ?case by blast
	+next
	+ case 1
	+ have "harm 1 = (1::real)" unfolding harm_def by simp
	+ have "harm 1 < ln (3::real)"
	+ by (subst \<open>harm 1 = 1\<close>,subst ln3_gt_1,simp)
	+ then show ?case by simp
	+next
	+ case (step n)
	+ have "harm (n+1) = harm n + 1/(n+1)"
	+ by ((subst Suc_eq_plus1[symmetric])+,subst harm_Suc,subst inverse_eq_divide,blast)
	+ also have "\<dots> < ln (real (2 * n + 1)) + 1/(n+1)"
	+ using step(1-2) by auto
	+ also have "\<dots> < ln (real (2 * n + 1)) + ln (1+2/(2*n+1))"
	+ proof -
	+ from step(1) have "real n \<ge> 1" by simp
	+ have "1 / real (n + 1) < ln (1 + 2 / real (2 * n + 1))"
	+ using harm_aux_ineq_2[OF \<open>1 \<le> (real n)\<close>] by (simp add: add.commute)
	+ then show ?thesis by auto
	+ qed
	+ also have "\<dots> = ln ((2 * n + 1) * (1+2/(2*n+1)))"
	+ by (rule ln_mult[symmetric],simp,simp add: field_simps)
	+ also have "\<dots> = ln (2*(n+1)+1)"
	+ proof -
	+ have "(2 * n + 1) * (1+2/(2n+1)) = 2(n+1)+1"
	+ by (simp add: field_simps)
	+ then show ?thesis by presburger
	+ qed
	+ finally show ?case by simp
	+qed
	+(* END TODO *)
	+
	+
	+text\<open>Theorem 8.21\<close>
	+theorem (in primitive_dchar) polya_vinogradov_inequality_primitive:
	+ fixes x :: nat
	+ shows "norm (\<Sum>m=1..x. \<chi> m) < sqrt n * ln n"
	+proof -
	+ define \<tau> :: complex where "\<tau> = gauss_sum 1 div sqrt n"
	+ have \<tau>_mod: "norm \<tau> = 1" using fourier_primitive(2)
	+ by (simp add: \<tau>_def)
	+ {
	+ fix m
	+ have "\<chi> m = (\<tau> div sqrt n) * (\<Sum>k = 1..n. (cnj (\<chi> k)) * unity_root n (-m*k))"
	+ using fourier_primitive(1)[of m] \<tau>_def by blast}
	+ note chi_expr = this
	+ have "(\<Sum>m = 1..x. \<chi>(m)) = (\<Sum>m = 1..x. (\<tau> div sqrt n) * (\<Sum>k = 1..n. (cnj (\<chi> k)) * unity_root n (-m*k)))"
	+ by(rule sum.cong[OF refl]) (use chi_expr in blast)
	+ also have "\<dots> = (\<Sum>m = 1..x. (\<Sum>k = 1..n. (\<tau> div sqrt n) * ((cnj (\<chi> k)) * unity_root n (-m*k))))"
	+ by (rule sum.cong,simp,simp add: sum_distrib_left)
	+ also have "\<dots> = (\<Sum>k = 1..n. (\<Sum>m = 1..x. (\<tau> div sqrt n) * ((cnj (\<chi> k)) * unity_root n (-m*k))))"
	+ by (rule sum.swap)
	+ also have "\<dots> = (\<Sum>k = 1..n. (\<tau> div sqrt n) * (cnj (\<chi> k) * (\<Sum>m = 1..x. unity_root n (-m*k))))"
	+ by (rule sum.cong,simp,simp add: sum_distrib_left)
	+ also have "\<dots> = (\<Sum>k = 1..<n. (\<tau> div sqrt n) * (cnj (\<chi> k) * (\<Sum>m = 1..x. unity_root n (-m*k))))"
	+ using n by (intro sum.mono_neutral_right) (auto intro: eq_zero)
	+ also have "\<dots> = (\<tau> div sqrt n) * (\<Sum>k = 1..<n. (cnj (\<chi> k) * (\<Sum>m = 1..x. unity_root n (-m*k))))"
	+ by (simp add: sum_distrib_left)
	+ finally have "(\<Sum>m = 1..x. \<chi>(m)) = (\<tau> div sqrt n) * (\<Sum>k = 1..<n. (cnj (\<chi> k) * (\<Sum>m = 1..x. unity_root n (-m*k))))"
	+ by blast
	+ hence eq: "sqrt n * (\<Sum>m=1..x. \<chi>(m)) = \<tau> * (\<Sum>k=1..<n. (cnj (\<chi> k) * (\<Sum>m=1..x. unity_root n (-m*k))))"
	+ by auto
	+ define f where "f = (\<lambda>k. (\<Sum>m = 1..x. unity_root n (-m*k)))"
	+
	+ hence "(sqrt n) * norm(\<Sum>m = 1..x. \<chi>(m)) = norm(\<tau> * (\<Sum>k=1..<n. (cnj (\<chi> k) * (\<Sum>m = 1..x. unity_root n (-m*k)))))"
	+ proof -
	+ have "norm(sqrt n * (\<Sum>m=1..x. \<chi>(m))) = norm (sqrt n) * norm((\<Sum>m = 1..x. \<chi>(m)))"
	+ by (simp add: norm_mult)
	+ also have "\<dots> = (sqrt n) * norm((\<Sum>m = 1..x. \<chi>(m)))"
	+ by simp
	+ finally have 1: "norm((sqrt n) * (\<Sum>m = 1..x. \<chi>(m))) = (sqrt n) * norm((\<Sum>m = 1..x. \<chi>(m)))"
	+ by blast
	+ then show ?thesis using eq by algebra
	+ qed
	+ also have "\<dots> = norm (\<Sum>k = 1..<n. (cnj (\<chi> k) * (\<Sum>m = 1..x. unity_root n (-m*k))))"
	+ by (simp add: norm_mult \<tau>_mod)
	+ also have "\<dots> \<le> (\<Sum>k = 1..<n. norm (cnj (\<chi> k) * (\<Sum> m = 1..x. unity_root n (-m*k))))"
	+ using norm_sum by blast
	+ also have "\<dots> = (\<Sum>k = 1..<n. norm (cnj (\<chi> k)) * norm((\<Sum> m = 1..x. unity_root n (-m*k))))"
	+ by (rule sum.cong,simp, simp add: norm_mult)
	+ also have "\<dots> \<le> (\<Sum>k = 1..<n. norm((\<Sum>m = 1..x. unity_root n (-m*k))))"
	+ proof -
	+ show ?thesis
	+ proof (rule sum_mono)
	+ fix k
	+ assume "k \<in> {1..<n}"
	+ define sum_aux :: real where "sum_aux = norm (\<Sum>m=1..x. unity_root n (- int m * int k))"
	+ have "sum_aux \<ge> 0" unfolding sum_aux_def by auto
	+ have "norm (cnj (\<chi> k)) \<le> 1" using norm_le_1[of k] by simp
	+ then have "norm (cnj (\<chi> k)) * sum_aux \<le> 1 * sum_aux"
	+ using \<open>sum_aux \<ge> 0\<close> by (simp add: mult_left_le_one_le)
	+ then show " norm (cnj (\<chi> k)) *
	+ norm (\<Sum>m = 1..x. unity_root n (- int m * int k))
	+ \<le> norm (\<Sum>m = 1..x. unity_root n (- int m * int k))"
	+ unfolding sum_aux_def by argo
	+ qed
	+ qed
	+ also have "\<dots> = (\<Sum>k = 1..<n. norm(f k))"
	+ using f_def by blast
	+ finally have 24: "(sqrt n) * norm(\<Sum>m = 1..x. \<chi>(m)) \<le> (\<Sum>k = 1..<n. norm(f k))"
	+ by blast
	+
	+ {
	+ fix k :: int
	+ have "f(n-k) = cnj(f(k))"
	+ proof -
	+ have "f(n-k) = (\<Sum>m = 1..x. unity_root n (-m*(n-k)))"
	+ unfolding f_def by blast
	+ also have "\<dots> = (\<Sum>m = 1..x. unity_root n (m*k))"
	+ proof (rule sum.cong,simp)
	+ fix xa
	+ assume "xa \<in> {1..x}"
	+ have "(k * int xa - int n * int xa) mod int n = (k * int xa - 0) mod int n"
	+ by (intro mod_diff_cong) auto
	+ thus "unity_root n (-int xa * (int n - k)) = unity_root n (int xa * k)"
	+ unfolding ring_distribs by (intro unity_root_cong) (auto simp: cong_def algebra_simps)
	+ qed
	+ also have "\<dots> = cnj(f(k))"
	+ proof -
	+ have "cnj(f(k)) = cnj (\<Sum>m = 1..x. unity_root n (- int m * k))"
	+ unfolding f_def by blast
	+ also have "cnj (\<Sum>m = 1..x. unity_root n (- int m * k)) =
	+ (\<Sum>m = 1..x. cnj(unity_root n (- int m * k)))"
	+ by (rule cnj_sum)
	+ also have "\<dots> = (\<Sum>m = 1..x. unity_root n (int m * k))"
	+ by (intro sum.cong) (auto simp: unity_root_uminus)
	+ finally show ?thesis by auto
	+ qed
	+ finally show "f(n-k) = cnj(f(k))" by blast
	+ qed
	+ hence "norm(f(n-k)) = norm(cnj(f(k)))" by simp
	+ hence "norm(f(n-k)) = norm(f(k))" by auto
	+ }
	+ note eq = this
	+ have 25:
	+ "odd n \<Longrightarrow> (\<Sum>k = 1..n - 1. norm (f (int k))) \<le>
	+ 2 * (\<Sum>k = 1..(n-1) div 2. norm (f (int k)))"
	+ "even n \<Longrightarrow> (\<Sum>k = 1..n - 1. norm (f (int k))) \<le>
	+ 2 * (\<Sum>k = 1..(n-2) div 2. norm (f (int k))) + norm(f(n div 2))"
	+ proof -
	+ assume "odd n"
	+ define g where "g = (\<lambda>k. norm (f k))"
	+ have "(n-1) div 2 = n div 2" using \<open>odd n\<close> n
	+ using div_mult_self1_is_m[OF pos2,of "n-1"]
	+ odd_two_times_div_two_nat[OF \<open>odd n\<close>] by linarith
	+ have "(\<Sum>i=1..n-1. g i) = (\<Sum>i\<in>{1..n div 2}\<union>{n div 2<..n-1}. g i)"
	+ using n by (intro sum.cong,auto)
	+ also have "\<dots> = (\<Sum>i\<in>{1..n div 2}. g i) + (\<Sum>i\<in>{n div 2<..n-1}. g i)"
	+ by (subst sum.union_disjoint,auto)
	+ also have "(\<Sum>i\<in>{n div 2<..n-1}. g i) = (\<Sum>i\<in>{1..n - (n div 2 + 1)}. g (n - i))"
	+ by (rule sum.reindex_bij_witness[of _ "\<lambda>i. n - i" "\<lambda>i. n - i"],auto)
	+ also have "\<dots> \<le> (\<Sum>i\<in>{1..n div 2}. g (n - i))"
	+ by (intro sum_mono2,simp,auto simp add: g_def)
	+ finally have 1: "(\<Sum>i=1..n-1. g i) \<le> (\<Sum>i=1..n div 2. g i + g (n - i))"
	+ by (simp add: sum.distrib)
	+ have "(\<Sum>i=1..n div 2. g i + g (n - i)) = (\<Sum>i=1..n div 2. 2 * g i)"
	+ unfolding g_def
	+ apply(rule sum.cong,simp)
	+ using eq int_ops(6) by force
	+ also have "\<dots> = 2 * (\<Sum>i=1..n div 2. g i)"
	+ by (rule sum_distrib_left[symmetric])
	+ finally have 2: "(\<Sum>i=1..n div 2. g i + g (n - i)) = 2 * (\<Sum>i=1..n div 2. g i)"
	+ by blast
	+ from 1 2 have "(\<Sum>i=1..n-1. g i) \<le> 2 * (\<Sum>i=1..n div 2. g i)" by algebra
	+ then show "(\<Sum>n = 1..n - 1. norm (f (int n))) \<le> 2 * (\<Sum>n = 1..(n-1) div 2. norm (f (int n)))"
	+ unfolding g_def \<open>(n-1) div 2 = n div 2\<close> by blast
	+ next
	+ assume "even n"
	+ define g where "g = (\<lambda>n. norm (f (n)))"
	+ have "(n-2) div 2 = n div 2 - 1" using \<open>even n\<close> n by simp
	+ have "(\<Sum>i=1..n-1. g i) = (\<Sum>i\<in>{1..<n div 2}\<union> {n div 2} \<union> {n div 2<..n-1}. g i)"
	+ using n by (intro sum.cong,auto)
	+ also have "\<dots> = (\<Sum>i\<in>{1..<n div 2}. g i) + (\<Sum>i\<in>{n div 2<..n-1}. g i) + g(n div 2)"
	+ by (subst sum.union_disjoint,auto)
	+ also have "(\<Sum>i\<in>{n div 2<..n-1}. g i) = (\<Sum>i\<in>{1..n - (n div 2+1)}. g (n - i))"
	+ by (rule sum.reindex_bij_witness[of _ "\<lambda>i. n - i" "\<lambda>i. n - i"],auto)
	+ also have "\<dots> \<le> (\<Sum>i\<in>{1..<n div 2}. g (n - i))"
	+ proof (intro sum_mono2,simp)
	+ have "n - n div 2 = n div 2" using \<open>even n\<close> n by auto
	+ then have "n - (n div 2 + 1) < n div 2"
	+ using n by (simp add: divide_simps)
	+ then show "{1..n - (n div 2 + 1)} \<subseteq> {1..<n div 2}" by fastforce
	+ qed auto
	+ finally have 1: "(\<Sum>i=1..n-1. g i) \<le> (\<Sum>i=1..<n div 2. g i + g (n - i)) + g(n div 2)"
	+ by (simp add: sum.distrib)
	+ have "(\<Sum>i=1..<n div 2. g i + g (n - i)) = (\<Sum>i=1..<n div 2. 2 * g i)"
	+ unfolding g_def
	+ apply(rule sum.cong,simp)
	+ using eq int_ops(6) by force
	+ also have "\<dots> = 2 * (\<Sum>i=1..<n div 2. g i)"
	+ by (rule sum_distrib_left[symmetric])
	+ finally have 2: "(\<Sum>i=1..<n div 2. g i + g (n - i)) = 2 * (\<Sum>i=1..<n div 2. g i)"
	+ by blast
	+ from 1 2 have 3: "(\<Sum>i=1..n-1. g i) \<le> 2 * (\<Sum>i=1..<n div 2. g i) + g(n div 2)" by algebra
	+ then have "(\<Sum>i=1..n-1. g i) \<le> 2 * (\<Sum>i=1..(n-2) div 2. g i) + g(n div 2)"
	+ proof -
	+ have "{1..<n div 2} = {1..(n-2) div 2}" by auto
	+ then have "(\<Sum>i=1..<n div 2. g i) = (\<Sum>i=1..(n-2) div 2. g i)"
	+ by (rule sum.cong,simp)
	+ then show ?thesis using 3 by presburger
	+ qed
	+ then show "(\<Sum>k = 1..n - 1. norm (f (int k))) \<le> 2 * (\<Sum>n = 1..(n-2) div 2. norm (f (int n))) + g(n div 2)"
	+ unfolding g_def by blast
	+ qed
	+
	+ (* expression for each f(n) *)
	+ {fix k :: int
	+ assume "1 \<le> k" "k \<le> n div 2"
	+ have "k \<le> n - 1"
	+ using \<open>k \<le> n div 2\<close> n by linarith
	+ define y where "y = unity_root n (-k)"
	+ define z where "z = exp (-(pik/n) \<i>)"
	+ have "z^2 = exp (2(-(pik/n)* \<i>))"
	+ unfolding z_def using exp_double[symmetric] by blast
	+ also have "\<dots> = y"
	+ unfolding y_def unity_root_conv_exp by (simp add: algebra_simps)
	+ finally have z_eq: "y = z^2" by blast
	+ have z_not_0: "z \<noteq> 0"
	+ using z_eq by (simp add: z_def)
	+
	+ then have "y \<noteq> 1"
	+ using unity_root_eq_1_iff_int \<open>1 \<le> k\<close> \<open>k \<le> n - 1\<close> not_less
	+ unity_root_eq_1_iff_int y_def zdvd_not_zless by auto
	+
	+ have "f(k) = (\<Sum>m = 1..x . y^m)"
	+ unfolding f_def y_def
	+ by (subst unity_root_pow,rule sum.cong,simp,simp add: algebra_simps)
	+ also have sum: "\<dots> = (\<Sum>m = 1..<x+1 . y^m)"
	+ by (rule sum.cong,fastforce,simp)
	+ also have "\<dots> = (\<Sum>m = 0..<x+1 . y^m) - 1"
	+ by (subst (2) sum.atLeast_Suc_lessThan) auto
	+ also have "\<dots> = (y^(x+1) - 1) div (y - 1) - 1"
	+ using geometric_sum[OF \<open>y \<noteq> 1\<close>, of "x+1"] by (simp add: atLeast0LessThan)
	+ also have "\<dots> = (y^(x+1) - 1 - (y-1)) div (y - 1)"
	+ proof -
	+ have "y - 1 \<noteq> 0" using \<open>y \<noteq> 1\<close> by simp
	+ show ?thesis
	+ using divide_diff_eq_iff[OF \<open>y - 1 \<noteq> 0\<close>, of "(y^(x+1) - 1)" 1] by auto
	+ qed
	+ also have "\<dots> = (y^(x+1) - y) div (y - 1)"
	+ by (simp add: algebra_simps)
	+ also have "\<dots> = y * (y^x - 1) div (y - 1)"
	+ by (simp add: algebra_simps)
	+ also have "\<dots> = z^2 * ((z^2)^x - 1) div (z^2 - 1)"
	+ unfolding z_eq by blast
	+ also have "\<dots> = z^2 * (z^(2*x) - 1) div (z^2 - 1)"
	+ by (subst power_mult[symmetric, of z 2 x],blast)
	+ also have "\<dots> = z^(x+1)*((z ^x -inverse(z^x))) / (z - inverse(z))"
	+ proof -
	+ have "z^x \<noteq> 0" using z_not_0 by auto
	+ have 1: "z ^ (2 * x) - 1 = z^x*(z ^x -inverse(z^x))"
	+ by (simp add: semiring_normalization_rules(36) right_inverse[OF \<open>z^x \<noteq> 0\<close>] right_diff_distrib')
	+ have 2: "z\<^sup>2 - 1 = z*(z - inverse(z))"
	+ by (simp add: right_diff_distrib' semiring_normalization_rules(29) right_inverse[OF \<open>z \<noteq> 0\<close>])
	+
	+ have 3: "z\<^sup>2 * (z^x / z) = z^(x+1)"
	+ proof -
	+ have "z\<^sup>2 * (z^x / z) = z\<^sup>2 * (z^x * inverse z)"
	+ by (simp add: inverse_eq_divide)
	+ also have "\<dots> = z^(x+1)"
	+ by (simp add: algebra_simps power2_eq_square right_inverse[OF \<open>z \<noteq> 0\<close>])
	+ finally show ?thesis by blast
	+ qed
	+ have "z\<^sup>2 * (z ^ (2 * x) - 1) / (z\<^sup>2 - 1) =
	+ z\<^sup>2 * (z^x(z ^x -inverse(z^x))) / (z(z - inverse(z)))"
	+ by (subst 1, subst 2,blast)
	+ also have "\<dots> = (z\<^sup>2 * (z^x / z)) * ((z ^x -inverse(z^x))) / (z - inverse(z))"
	+ by simp
	+ also have "\<dots> = z^(x+1) *((z ^x -inverse(z^x))) / (z - inverse(z))"
	+ by (subst 3,simp)
	+ finally show ?thesis by simp
	+ qed
	+ finally have "f(k) = z^(x+1) *((z ^x -inverse(z^x))) / (z - inverse(z))" by blast
	+
	+ (* inequality for each f(k) *)
	+ then have "norm(f(k)) = norm(z^(x+1) * (((z ^x -inverse(z^x))) / (z - inverse(z))))" by auto
	+ also have "\<dots> = norm(z^(x+1)) * norm(((z ^x -inverse(z^x))) / (z - inverse(z)))"
	+ using norm_mult by blast
	+ also have "\<dots> = norm(((z ^x -inverse(z^x))) / (z - inverse(z)))"
	+ proof -
	+ have "norm(z) = 1"
	+ unfolding z_def by auto
	+ have "norm(z^(x+1)) = 1"
	+ by (subst norm_power,simp add: \<open>norm(z) = 1\<close>)
	+ then show ?thesis by simp
	+ qed
	+ also have "\<dots> = norm((exp (-(xpik/n)* \<i>) - exp ((xpik/n)* \<i>)) div
	+ (exp (-(pik/n) \<i>) - exp ((pik/n) \<i>)))"
	+ proof -
	+ have 1: "z ^ x = exp (-(xpik/n)* \<i>)"
	+ unfolding z_def
	+ by (subst exp_of_nat_mult[symmetric],simp add: algebra_simps)
	+ have "inverse (z ^ x) = inverse (exp (-(xpik/n)* \<i>))"
	+ using \<open>z ^ x = exp (-(xpik/n)* \<i>)\<close> by auto
	+ also have "\<dots> = (exp ((xpik/n)* \<i>))"
	+ by (simp add: exp_minus)
	+ finally have 2: "inverse(z^x) = exp ((xpik/n)* \<i>)" by simp
	+ have 3: "inverse z = exp ((pik/n) \<i>)"
	+ by (simp add: exp_minus z_def)
	+ show ?thesis using 1 2 3 z_def by simp
	+ qed
	+ also have "\<dots> = norm((sin (xpik/n)) div (sin (pi*k/n)))"
	+ proof -
	+ have num: "(exp (-(xpik/n)* \<i>) - exp ((xpik/n)* \<i>)) = (-2\<i> sin((xpik/n)))"
	+ proof -
	+ have 1: "exp (-(xpik/n)* \<i>) = cos(-(xpik/n)) + \<i> * sin(-(xpik/n))"
	+ "exp ((xpik/n)* \<i>) = cos((xpik/n)) + \<i> * sin((xpik/n))"
	+ using Euler Im_complex_of_real Im_divide_of_nat Im_i_times Re_complex_of_real
	+ complex_Re_of_int complex_i_mult_minus exp_zero mult.assoc mult.commute by force+
	+ have "(exp (-(xpik/n)* \<i>) - exp ((xpik/n)* \<i>)) =
	+ (cos(-(xpik/n)) + \<i> * sin(-(xpik/n))) -
	+ (cos((xpik/n)) + \<i> * sin((xpik/n)))"
	+ using 1 by argo
	+ also have "\<dots> = -2\<i> sin((xpik/n))" by simp
	+ finally show ?thesis by blast
	+ qed
	+
	+ have den: "(exp (-(pik/n) \<i>) - exp ((pik/n) \<i>)) = -2\<i> sin((pi*k/n))"
	+ proof -
	+ have 1: "exp (-(pik/n) \<i>) = cos(-(pik/n)) + \<i> sin(-(pi*k/n))"
	+ "exp ((pik/n) \<i>) = cos((pik/n)) + \<i> sin((pi*k/n))"
	+ using Euler Im_complex_of_real Im_divide_of_nat Im_i_times Re_complex_of_real
	+ complex_Re_of_int complex_i_mult_minus exp_zero mult.assoc mult.commute by force+
	+ have "(exp (-(pik/n) \<i>) - exp ((pik/n) \<i>)) =
	+ (cos(-(pik/n)) + \<i> sin(-(pi*k/n))) -
	+ (cos((pik/n)) + \<i> sin((pi*k/n)))"
	+ using 1 by argo
	+ also have "\<dots> = -2\<i> sin((pi*k/n))" by simp
	+ finally show ?thesis by blast
	+ qed
	+
	+ have "norm((exp (-(xpik/n)* \<i>) - exp ((xpik/n)* \<i>)) div
	+ (exp (-(pik/n) \<i>) - exp ((pik/n) \<i>))) =
	+ norm((-2\<i> sin((xpik/n))) div (-2\<i> sin((pi*k/n))))"
	+ using num den by presburger
	+ also have "\<dots> = norm(sin((xpik/n)) div sin((pi*k/n)))"
	+ by (simp add: norm_divide)
	+ finally show ?thesis by blast
	+ qed
	+ also have "\<dots> = norm((sin (xpik/n))) div norm((sin (pi*k/n)))"
	+ by (simp add: norm_divide)
	+ also have "\<dots> \<le> 1 div norm((sin (pi*k/n)))"
	+ proof -
	+ have "norm((sin (pi*k/n))) \<ge> 0" by simp
	+ have "norm (sin (xpik/n)) \<le> 1" by simp
	+ then show ?thesis
	+ using divide_right_mono[OF \<open>norm (sin (xpik/n)) \<le> 1\<close> \<open>norm((sin (pi*k/n))) \<ge> 0\<close>]
	+ by blast
	+ qed
	+ finally have 26: "norm(f(k)) \<le> 1 div norm((sin (pi*k/n)))"
	+ by blast
	+
	+ (* inequality with sin *)
	+ {
	+ fix t
	+ assume "t \<ge> 0" "t \<le> pi div 2"
	+ then have "t \<in> {0..pi div 2}" by auto
	+ have "convex_on {0..pi/2} (\<lambda>x. -sin x)"
	+ by (rule convex_on_realI[where f' = "\<lambda>x. - cos x"])
	+ (auto intro!: derivative_eq_intros simp: cos_monotone_0_pi_le)
	+ from convex_onD_Icc'[OF this \<open>t \<in> {0..pi div 2}\<close>] have "sin(t) \<ge> (2 div pi)*t" by simp
	+ }
	+ note sin_ineq = this
	+
	+ have sin_ineq_inst: "sin ((pik) / n) \<ge> (2 k) / n"
	+ proof -
	+ have "pi / n \<ge> 0" by simp
	+ have 1: "(pi*k) / n \<ge> 0" using \<open>1 \<le> k\<close> by auto
	+ have "(pik)/n = (pi / n) k" by simp
	+ also have "\<dots> \<le> (pi / n) * (n / 2)"
	+ using mult_left_mono[of "k" "n / 2" "pi / n"]
	+ \<open>k \<le> n div 2\<close> \<open>0 \<le> pi / real n\<close> by linarith
	+ also have "\<dots> \<le> pi / 2"
	+ by (simp add: divide_simps)
	+ finally have 2: "(pi*k)/n \<le> pi / 2" by auto
	+
	+ have "(2 / pi) * (pi * k / n) \<le> sin((pi * k) / n)"
	+ using sin_ineq[OF 1 2] by blast
	+ then show "sin((pi * k) / n) \<ge> (2*k) / n"
	+ by auto
	+ qed
	+
	+ from 26 have "norm(f(k)) \<le> 1 div abs((sin (pi*k/n)))" by simp
	+ also have "\<dots> \<le> 1 / abs((2*k) / n)"
	+ proof -
	+ have "sin (pik/n) \<ge> (2k) / n" using sin_ineq_inst by simp
	+ moreover have "(2*k) / n > 0" using n \<open>1 \<le> k\<close> by auto
	+ ultimately have "abs((sin (pik/n))) \<ge> abs((2k)/n)" by auto
	+ have "abs((2k)/n) > 0" using \<open>(2k)/n > 0\<close> by linarith
	+ then show "1 div abs((sin (pik/n))) \<le> 1 / abs(((2k)/n))"
	+ using \<open>abs((2k)/n) > 0\<close> \<open>abs((sin (pik/n))) \<ge> abs(((2*k)/n))\<close>
	+ by (intro frac_le) auto
	+ qed
	+ also have "\<dots> = n / (2*k)" using \<open>k \<ge> 1\<close> by simp
	+ finally have "norm(f(k)) \<le> n / (2*k)" by blast
	+ }
	+ note ineq = this
	+
	+ (* inequality for the odd and even case*)
	+ have "sqrt n * norm (sum \<chi> {1..x}) < n * ln n"
	+ proof (cases "even n")
	+ case True
	+ have "norm (f(n div 2)) \<le> 1"
	+ proof -
	+ have "int (n div 2) \<ge> 1" using n \<open>even n\<close> by auto
	+ show ?thesis
	+ using ineq[OF \<open>int (n div 2) \<ge> 1\<close>] True n by force
	+ qed
	+ from 24 have "sqrt n * norm (sum \<chi> {1..x})
	+ \<le> (\<Sum>k = 1..<n. norm (f (int k)))" by blast
	+ also have "\<dots> = (\<Sum>k = 1..n-1. norm (f (int k)))"
	+ by (intro sum.cong) auto
	+ also have "\<dots> \<le> 2 * (\<Sum>k = 1..(n - 2) div 2. norm (f (int k))) + norm(f(n div 2))"
	+ using 25(2)[OF True] by blast
	+ also have "\<dots> \<le> real n * (\<Sum>k = 1..(n - 2) div 2. 1 / k) + norm(f(n div 2))"
	+ proof -
	+ have "(\<Sum>k = 1..(n - 2) div 2. norm (f (int k))) \<le> (\<Sum>k = 1..(n - 2) div 2. real n div (2*k))"
	+ proof (rule sum_mono)
	+ fix k
	+ assume "k \<in> {1..(n - 2) div 2}"
	+ then have "1 \<le> int k" "int k \<le> n div 2" by auto
	+ show "norm (f (int k)) \<le> real n / (2*k)"
	+ using ineq[OF \<open>1 \<le> int k\<close> \<open>int k \<le> n div 2\<close>] by auto
	+ qed
	+ also have "\<dots> = (\<Sum>k = 1..(n - 2) div 2. (real n div 2) * (1 / k))"
	+ by (rule sum.cong,auto)
	+ also have "\<dots> = (real n div 2) * (\<Sum>k = 1..(n - 2) div 2. 1 / k)"
	+ using sum_distrib_left[symmetric] by fast
	+ finally have "(\<Sum>k = 1..(n - 2) div 2. norm (f (int k))) \<le>
	+ (real n div 2) * (\<Sum>k = 1..(n - 2) div 2. 1 / k)"
	+ by blast
	+ then show ?thesis by argo
	+ qed
	+ also have "\<dots> = real n * harm ((n - 2) div 2) + norm(f(n div 2))"
	+ unfolding harm_def inverse_eq_divide by simp
	+ also have "\<dots> < n * ln n"
	+ proof (cases "n = 2")
	+ case True
	+ have "real n * harm ((n - 2) div 2) + norm (f (int (n div 2))) \<le> 1"
	+ using \<open>n = 2\<close> \<open>norm (f (int (n div 2))) \<le> 1\<close>
	+ unfolding harm_def by simp
	+ moreover have "real n * ln (real n) \<ge> 4 / 3"
	+ using \<open>n = 2\<close> ln2_ge_two_thirds by auto
	+ ultimately show ?thesis by argo
	+ next
	+ case False
	+ have "n > 3" using n \<open>n \<noteq> 2\<close> \<open>even n\<close> by auto
	+ then have "(n-2) div 2 > 0" by simp
	+ then have "harm ((n - 2) div 2) < ln (real (2 * ((n - 2) div 2) + 1))"
	+ using harm_less_ln by blast
	+ also have "\<dots> = ln (real (n - 1))"
	+ using \<open>even n\<close> \<open>n > 3\<close> by simp
	+ finally have 1: "harm ((n - 2) div 2) < ln (real (n - 1))"
	+ by blast
	+ then have "real n * harm ((n - 2) div 2) < real n * ln (real (n - 1))"
	+ using n by simp
	+ then have "real n * harm ((n - 2) div 2) + norm (f (int (n div 2)))
	+ < real n * ln (real (n - 1)) + 1"
	+ using \<open>norm (f (int (n div 2))) \<le> 1\<close> by argo
	+ also have "\<dots> = real n * ln (real (n - 1)) + real n * 1 / real n"
	+ using n by auto
	+ also have "\<dots> < real n * ln (real (n - 1)) + real n * ln (1 + 1 / (real n - 1))"
	+ proof -
	+ have "real n > 1" "real n > 0" using n by simp+
	+ then have "real n * (1 / real n) < real n * ln (1 + 1 / (real n - 1))"
	+ by (intro mult_strict_left_mono harm_aux_ineq_1) auto
	+ then show ?thesis by auto
	+ qed
	+ also have "\<dots> = real n * ( ln (real (n - 1)) + ln (1 + 1 / (real n - 1)))"
	+ by argo
	+ also have "\<dots> = real n * ( ln (real (n - 1) * (1 + 1 / (real n - 1))))"
	+ proof -
	+ have "real (n - 1) > 0" "1 + 1 / (real n - 1) > 0"
	+ using n by (auto simp add: add_pos_nonneg)
	+ show ?thesis
	+ by (subst ln_mult [OF \<open>real (n - 1) > 0\<close> \<open>1 + 1 / (real n - 1) > 0\<close>,symmetric],blast)
	+ qed
	+ also have "\<dots> = real n * ln n"
	+ using n by (auto simp add: divide_simps)
	+ finally show ?thesis by blast
	+ qed
	+ finally show ?thesis by blast
	+ next
	+ case False
	+ from 24 have "sqrt n * norm (sum \<chi> {1..x}) \<le> (\<Sum>k= 1..<n. norm (f (int k)))"
	+ by blast
	+ also have "\<dots> = (\<Sum>k= 1..n-1. norm (f (int k)))"
	+ by (intro sum.cong) auto
	+ also have "\<dots> \<le> 2 * (\<Sum>k = 1..(n - 1) div 2. norm (f (int k)))"
	+ using 25(1)[OF False] by blast
	+ also have "\<dots> \<le> real n * (\<Sum>k = 1..(n - 1) div 2. 1 / k)"
	+ proof -
	+ have "(\<Sum>k = 1..(n - 1) div 2. norm (f (int k))) \<le> (\<Sum>k = 1..(n - 1) div 2. real n div (2*k))"
	+ proof (rule sum_mono)
	+ fix k
	+ assume "k \<in> {1..(n - 1) div 2}"
	+ then have "1 \<le> int k" "int k \<le> n div 2" by auto
	+ show "norm (f (int k)) \<le> real n / (2*k)"
	+ using ineq[OF \<open>1 \<le> int k\<close> \<open>int k \<le> n div 2\<close>] by auto
	+ qed
	+ also have "\<dots> = (\<Sum>k = 1..(n - 1) div 2. (n / 2) * (1 / k))"
	+ by (rule sum.cong,auto)
	+ also have "\<dots> = (n / 2) * (\<Sum>k = 1..(n - 1) div 2. 1 / k)"
	+ using sum_distrib_left[symmetric] by fast
	+ finally have "(\<Sum>k = 1..(n - 1) div 2. norm (f (int k))) \<le>
	+ (real n div 2) * (\<Sum>k = 1..(n - 1) div 2. 1 / k)"
	+ by blast
	+ then show ?thesis by argo
	+ qed
	+ also have "\<dots> = real n * harm ((n - 1) div 2)"
	+ unfolding harm_def inverse_eq_divide by simp
	+ also have "\<dots> < n * ln n"
	+ proof -
	+ have "n > 2" using n \<open>odd n\<close> by presburger
	+ then have "(n-1) div 2 > 0" by auto
	+ then have "harm ((n - 1) div 2) < ln (real (2 * ((n - 1) div 2) + 1))"
	+ using harm_less_ln by blast
	+ also have "\<dots> = ln (real n)" using \<open>odd n\<close> by simp
	+ finally show ?thesis using n by simp
	+ qed
	+ finally show ?thesis by blast
	+ qed
	+
	+ then have 1: "sqrt n * norm (sum \<chi> {1..x}) < n * ln n"
	+ by blast
	+ show "norm (sum \<chi> {1..x}) < sqrt n * ln n"
	+ proof -
	+ have 2: "norm (sum \<chi> {1..x}) * sqrt n < n * ln n"
	+ using 1 by argo
	+ have "sqrt n > 0" using n by simp
	+ have 3: "(n * ln n) / sqrt n = sqrt n * ln n"
	+ using n by (simp add: field_simps)
	+ show "norm (sum \<chi> {1..x}) < sqrt n * ln n"
	+ using mult_imp_less_div_pos[OF \<open>sqrt n > 0\<close> 2] 3 by argo
	+ qed
	+qed
	+
	+
	+subsection \<open>General case\<close>
	+
	+text \<open>
	+ We now first prove the inequality for the general case in terms of the divisor function:
	+\<close>
	+theorem (in dcharacter) polya_vinogradov_inequality_explicit:
	+ assumes nonprincipal: "\<chi> \<noteq> principal_dchar n"
	+ shows "norm (sum \<chi> {1..x}) < sqrt conductor * ln conductor * divisor_count (n div conductor)"
	+proof -
	+ write primitive_extension ("\<Phi>")
	+ write conductor ("c")
	+ interpret \<Phi>: primitive_dchar c "residue_mult_group c" primitive_extension
	+ using primitive_primitive_extension nonprincipal by metis
	+
	+ have : "k \<le> x div b \<longleftrightarrow> b k \<le> x" if "b > 0" for b k
	+ by (metis that antisym_conv div_le_mono div_mult_self1_is_m
	+ less_imp_le not_less times_div_less_eq_dividend)
	+ have **: "a > 0" if "a dvd n" for a
	+ using n that by (auto intro!: Nat.gr0I)
	+
	+ from nonprincipal have "(\<Sum>m=1..x. \<chi> m) = (\<Sum>m \| m \<in> {1..x} \<and> coprime m n. \<Phi> m)"
	+ by (intro sum.mono_neutral_cong_right) (auto simp: eq_zero_iff principal_decomposition)
	+ also have "\<dots> = (\<Sum>m=1..x. \<Phi> m * (\<Sum>d \| d dvd gcd m n. moebius_mu d))"
	+ by (subst sum_moebius_mu_divisors', intro sum.mono_neutral_cong_left)
	+ (auto simp: coprime_iff_gcd_eq_1 simp del: coprime_imp_gcd_eq_1)
	+ also have "\<dots> = (\<Sum>m=1..x. \<Sum>d \| d dvd gcd m n. \<Phi> m * moebius_mu d)"
	+ by (simp add: sum_distrib_left)
	+ also have "\<dots> = (\<Sum>m=1..x. \<Sum>d \| d dvd m \<and> d dvd n. \<Phi> m * moebius_mu d)"
	+ by (intro sum.cong) auto
	+ also have "\<dots> = (\<Sum>(m, d)\<in>(SIGMA m:{1..x}. {d. d dvd m \<and> d dvd n}). \<Phi> m * moebius_mu d)"
	+ using n by (subst sum.Sigma) auto
	+ also have "\<dots> = (\<Sum>(d, q)\<in>(SIGMA d:{d. d dvd n}. {1..x div d}). moebius_mu d * \<Phi> (d * q))"
	+ by (intro sum.reindex_bij_witness[of _ "\<lambda>(d,q). (d * q, d)" "\<lambda>(m,d). (d, m div d)"])
	+ (auto simp: * ** Suc_le_eq)
	+ also have "\<dots> = (\<Sum>d \| d dvd n. moebius_mu d * \<Phi> d * (\<Sum>q=1..x div d. \<Phi> q))"
	+ using n by (subst sum.Sigma [symmetric]) (auto simp: sum_distrib_left mult.assoc)
	+ finally have eq: "(\<Sum>m=1..x. \<chi> m) = \<dots>" .
	+
	+ have "norm (\<Sum>m=1..x. \<chi> m) \<le>
	+ (\<Sum>d \| d dvd n. norm (moebius_mu d * \<Phi> d) * norm (\<Sum>q=1..x div d. \<Phi> q))"
	+ unfolding eq by (intro sum_norm_le) (simp add: norm_mult)
	+ also have "\<dots> < (\<Sum>d \| d dvd n. norm (moebius_mu d * \<Phi> d) * (sqrt c * ln c))"
	+ (is "sum ?lhs _ < sum ?rhs _")
	+ proof (rule sum_strict_mono_ex1)
	+ show "\<forall>d\<in>{d. d dvd n}. ?lhs d \<le> ?rhs d"
	+ by (intro ballI mult_left_mono less_imp_le[OF \<Phi>.polya_vinogradov_inequality_primitive]) auto
	+ show "\<exists>d\<in>{d. d dvd n}. ?lhs d < ?rhs d"
	+ by (intro bexI[of _ 1] mult_strict_left_mono \<Phi>.polya_vinogradov_inequality_primitive) auto
	+ qed (use n in auto)
	+ also have "\<dots> = sqrt c * ln c * (\<Sum>d \| d dvd n. norm (moebius_mu d * \<Phi> d))"
	+ by (simp add: sum_distrib_left sum_distrib_right mult_ac)
	+ also have "(\<Sum>d \| d dvd n. norm (moebius_mu d * \<Phi> d)) =
	+ (\<Sum>d \| d dvd n \<and> squarefree d \<and> coprime d c. 1)"
	+ using n by (intro sum.mono_neutral_cong_right)
	+ (auto simp: moebius_mu_def \<Phi>.eq_zero_iff norm_mult norm_power \<Phi>.norm)
	+ also have "\<dots> = card {d. d dvd n \<and> squarefree d \<and> coprime d c}"
	+ by simp
	+ also have "card {d. d dvd n \<and> squarefree d \<and> coprime d c} \<le> card {d. d dvd (n div c)}"
	+ proof (intro card_mono; safe?)
	+ show "finite {d. d dvd (n div c)}"
	+ using dvd_div_eq_0_iff[of c n] n conductor_dvd by (intro finite_divisors_nat) auto
	+ next
	+ fix d assume d: "d dvd n" "squarefree d" "coprime d c"
	+ hence "d > 0" by (intro Nat.gr0I) auto
	+ show "d dvd (n div c)"
	+ proof (rule multiplicity_le_imp_dvd)
	+ fix p :: nat assume p: "prime p"
	+ show "multiplicity p d \<le> multiplicity p (n div c)"
	+ proof (cases "p dvd d")
	+ assume "p dvd d"
	+ with d \<open>d > 0\<close> p have "multiplicity p d = 1"
	+ by (auto simp: squarefree_factorial_semiring' in_prime_factors_iff)
	+ moreover have "p dvd (n div c)"
	+ proof -
	+ have "p dvd c * (n div c)"
	+ using \<open>p dvd d\<close> \<open>d dvd n\<close> conductor_dvd by auto
	+ moreover have "\<not>(p dvd c)"
	+ using d p \<open>p dvd d\<close> coprime_common_divisor not_prime_unit by blast
	+ ultimately show "p dvd (n div c)"
	+ using p prime_dvd_mult_iff by blast
	+ qed
	+ hence "multiplicity p (n div c) \<ge> 1"
	+ using n p conductor_dvd dvd_div_eq_0_iff[of c n]
	+ by (intro multiplicity_geI) (auto intro: Nat.gr0I)
	+ ultimately show ?thesis by simp
	+ qed (auto simp: not_dvd_imp_multiplicity_0)
	+ qed (use \<open>d > 0\<close> in simp_all)
	+ qed
	+ also have "card {d. d dvd (n div c)} = divisor_count (n div c)"
	+ by (simp add: divisor_count_def)
	+ finally show "norm (sum \<chi> {1..x}) < sqrt c * ln c * divisor_count (n div c)"
	+ using conductor_gr_0 by (simp add: mult_left_mono)
	+qed
	+
	+(* TODO: Move? *)
	+text \<open>
	+ Next, we obtain a suitable upper bound on the number of divisors of \<open>n\<close>:
	+\<close>
	+lemma divisor_count_upper_bound_aux:
	+ fixes n :: nat
	+ shows "divisor_count n \<le> 2 * card {d. d dvd n \<and> d \<le> sqrt n}"
	+proof (cases "n = 0")
	+ case False
	+ hence n: "n > 0" by simp
	+ have *: "x > 0" if "x dvd n" for x
	+ using that n by (auto intro!: Nat.gr0I)
	+ have *: "real n = sqrt (real n) sqrt (real n)"
	+ by simp
	+ have **: "n < x sqrt n \<longleftrightarrow> sqrt n < x" "x * sqrt n < n \<longleftrightarrow> x < sqrt n" for x
	+ by (metis ** n of_nat_0_less_iff real_mult_less_iff1 real_sqrt_gt_0_iff)+
	+
	+ have "divisor_count n = card {d. d dvd n}"
	+ by (simp add: divisor_count_def)
	+ also have "{d. d dvd n} = {d. d dvd n \<and> d \<le> sqrt n} \<union> {d. d dvd n \<and> d > sqrt n}"
	+ by auto
	+ also have "card \<dots> = card {d. d dvd n \<and> d \<le> sqrt n} + card {d. d dvd n \<and> d > sqrt n}"
	+ using n by (subst card_Un_disjoint) auto
	+ also have "bij_betw (\<lambda>d. n div d) {d. d dvd n \<and> d > sqrt n} {d. d dvd n \<and> d < sqrt n}"
	+ using n by (intro bij_betwI[of _ _ _ "\<lambda>d. n div d"])
	+ (auto simp: Real.real_of_nat_div real_sqrt_divide field_simps * ***)
	+ hence "card {d. d dvd n \<and> d > sqrt n} = card {d. d dvd n \<and> d < sqrt n}"
	+ by (rule bij_betw_same_card)
	+ also have "\<dots> \<le> card {d. d dvd n \<and> d \<le> sqrt n}"
	+ using n by (intro card_mono) auto
	+ finally show "divisor_count n \<le> 2 * \<dots>" by simp
	+qed auto
	+
	+lemma divisor_count_upper_bound:
	+ fixes n :: nat
	+ shows "divisor_count n \<le> 2 * nat \<lfloor>sqrt n\<rfloor>"
	+proof (cases "n = 0")
	+ case False
	+ have "divisor_count n \<le> 2 * card {d. d dvd n \<and> d \<le> sqrt n}"
	+ by (rule divisor_count_upper_bound_aux)
	+ also have "card {d. d dvd n \<and> d \<le> sqrt n} \<le> card {1..nat \<lfloor>sqrt n\<rfloor>}"
	+ using False by (intro card_mono) (auto simp: le_nat_iff le_floor_iff Suc_le_eq intro!: Nat.gr0I)
	+ also have "\<dots> = nat \<lfloor>sqrt n\<rfloor>" by simp
	+ finally show ?thesis by simp
	+qed auto
	+
	+lemma divisor_count_upper_bound':
	+ fixes n :: nat
	+ shows "real (divisor_count n) \<le> 2 * sqrt n"
	+proof -
	+ have "real (divisor_count n) \<le> 2 * real (nat \<lfloor>sqrt n\<rfloor>)"
	+ using divisor_count_upper_bound[of n] by linarith
	+ also have "\<dots> \<le> 2 * sqrt n"
	+ by simp
	+ finally show ?thesis .
	+qed
	+(* END TODO *)
	+
	+
	+text \<open>
	+ We are now ready to prove the `regular' Pólya--Vinogradov inequality.
	+
	+ Apostol formulates it in the following way (Theorem 13.15, notation adapted):
	+ `If \<open>\<chi>\<close> is any nonprincipal character mod \<open>n\<close>, then for all \<open>x \<ge> 2\<close> we have
	+ $\sum_{m\leq x} \chi(m) = O(\sqrt{n}\log n)$.'
	+
	+ The precondition \<open>x \<ge> 2\<close> here is completely unnecessary. The `Big-O' notation is somewhat
	+ problematic since it does not make explicit in what way the variables are quantified
	+ (in particular the \<open>x\<close> and the \<open>\<chi>\<close>). The statement of the theorem in this way (for a fixed
	+ character \<open>\<chi>\<close>) seems to suggest that \<open>n\<close> is fixed here, which would make the use of `Big-O'
	+ completely vacuous, since it is an asymptotic statement about \<open>n\<close>.
	+
	+ We therefore decided to formulate the inequality in the following more explicit way,
	+ even giving an explicit constant factor:
	+\<close>
	+theorem (in dcharacter) polya_vinogradov_inequality:
	+ assumes nonprincipal: "\<chi> \<noteq> principal_dchar n"
	+ shows "norm (\<Sum>m=1..x. \<chi> m) < 2 * sqrt n * ln n"
	+proof -
	+ have "n div conductor > 0"
	+ using n conductor_dvd dvd_div_eq_0_iff[of conductor n] by auto
	+ have "norm (\<Sum>m=1..x. \<chi> m) < sqrt conductor * ln conductor * divisor_count (n div conductor)"
	+ using nonprincipal by (rule polya_vinogradov_inequality_explicit)
	+ also have "\<dots> \<le> sqrt conductor * ln conductor * (2 * sqrt (n div conductor))"
	+ using conductor_gr_0 \<open>n div conductor > 0\<close>
	+ by (intro mult_left_mono divisor_count_upper_bound') (auto simp: Suc_le_eq)
	+ also have "sqrt (n div conductor) = sqrt n / sqrt conductor"
	+ using conductor_dvd by (simp add: Real.real_of_nat_div real_sqrt_divide)
	+ also have "sqrt conductor * ln conductor * (2 * (sqrt n / sqrt conductor)) =
	+ 2 * sqrt n * ln conductor"
	+ using conductor_gr_0 n by (simp add: algebra_simps)
	+ also have "\<dots> \<le> 2 * sqrt n * ln n"
	+ using conductor_le_modulus conductor_gr_0 by (intro mult_left_mono) auto
	+ finally show ?thesis .
	+qed
	+
	+unbundle vec_lambda_notation
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Gauss_Sums/ROOT b/thys/Gauss_Sums/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Gauss_Sums/ROOT
	@@ -0,0 +1,15 @@
	+chapter AFP
	+
	+session Gauss_Sums (AFP) = Dirichlet_Series +
	+ options [timeout = 600]
	+ sessions
	+ "HOL-Algebra"
	+ "HOL-Real_Asymp"
	+ Polynomial_Interpolation
	+ Dirichlet_Series
	+ Dirichlet_L
	+ theories
	+ Polya_Vinogradov
	+ document_files
	+ "root.tex"
	+ "root.bib"
	diff --git a/thys/Gauss_Sums/Ramanujan_Sums.thy b/thys/Gauss_Sums/Ramanujan_Sums.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Gauss_Sums/Ramanujan_Sums.thy
	@@ -0,0 +1,803 @@
	+(*
	+ File: Ramanujan_Sums.thy
	+ Authors: Rodrigo Raya, EPFL; Manuel Eberl, TUM
	+
	+ Ramanujan sums and generalised Ramanujan sums
	+*)
	+section \<open>Ramanujan sums\<close>
	+theory Ramanujan_Sums
	+imports
	+ Dirichlet_Series.Moebius_Mu
	+ Gauss_Sums_Auxiliary
	+ Finite_Fourier_Series
	+begin
	+
	+subsection \<open>Basic sums\<close>
	+
	+definition ramanujan_sum :: "nat \<Rightarrow> nat \<Rightarrow> complex"
	+ where "ramanujan_sum k n = (\<Sum>m \| m \<in> {1..k} \<and> coprime m k. unity_root k (m*n))"
	+
	+notation ramanujan_sum ("c")
	+
	+lemma ramanujan_sum_0_n [simp]: "c 0 n = 0"
	+ unfolding ramanujan_sum_def by simp
	+
	+lemma sum_coprime_conv_dirichlet_prod_moebius_mu:
	+ fixes F S :: "nat \<Rightarrow> complex" and f :: "nat \<Rightarrow> nat \<Rightarrow> complex"
	+ defines "F \<equiv> (\<lambda>n. (\<Sum>k \<in> {1..n}. f k n))"
	+ defines "S \<equiv> (\<lambda>n. (\<Sum>k \| k \<in> {1..n} \<and> coprime k n . f k n))"
	+ assumes "\<And>a b d. d dvd a \<Longrightarrow> d dvd b \<Longrightarrow> f (a div d) (b div d) = f a b"
	+ shows "S n = dirichlet_prod moebius_mu F n"
	+proof (cases "n = 0")
	+ case True
	+ then show ?thesis
	+ using assms(2) unfolding dirichlet_prod_def by fastforce
	+next
	+ case False
	+ have "S(n) = (\<Sum>k \| k \<in> {1..n} \<and> coprime k n . (f k n))"
	+ using assms by blast
	+ also have "\<dots> = (\<Sum>k \<in> {1..n}. (f k n)* dirichlet_prod_neutral (gcd k n))"
	+ using dirichlet_prod_neutral_intro by blast
	+ also have "\<dots> = (\<Sum>k \<in> {1..n}. (f k n)* (\<Sum>d \| d dvd (gcd k n). moebius_mu d))"
	+ proof -
	+ {
	+ fix k
	+ have "dirichlet_prod_neutral (gcd k n) = (if gcd k n = 1 then 1 else 0)"
	+ using dirichlet_prod_neutral_def[of "gcd k n"] by blast
	+ also have "\<dots> = (\<Sum>d \| d dvd gcd k n. moebius_mu d)"
	+ using sum_moebius_mu_divisors'[of "gcd k n"] by auto
	+ finally have "dirichlet_prod_neutral (gcd k n) = (\<Sum>d \| d dvd gcd k n. moebius_mu d)"
	+ by auto
	+ } note summand = this
	+ then show ?thesis by (simp add: summand)
	+ qed
	+ also have "\<dots> = (\<Sum>k = 1..n. (\<Sum>d \| d dvd gcd k n. (f k n) * moebius_mu d))"
	+ by (simp add: sum_distrib_left)
	+ also have "\<dots> = (\<Sum>k = 1..n. (\<Sum>d \| d dvd gcd n k. (f k n) * moebius_mu d))"
	+ using gcd.commute[of _ n] by simp
	+ also have "\<dots> = (\<Sum>d \| d dvd n. \<Sum>k \| k \<in> {1..n} \<and> d dvd k. (f k n) * moebius_mu d)"
	+ using sum.swap_restrict[of "{1..n}" "{d. d dvd n}"
	+ "\<lambda>k d. (f k n)*moebius_mu d" "\<lambda>k d. d dvd k"] False by auto
	+ also have "\<dots> = (\<Sum>d \| d dvd n. moebius_mu d * (\<Sum>k \| k \<in> {1..n} \<and> d dvd k. (f k n)))"
	+ by (simp add: sum_distrib_left mult.commute)
	+ also have "\<dots> = (\<Sum>d \| d dvd n. moebius_mu d * (\<Sum>q \<in> {1..n div d}. (f q (n div d))))"
	+ proof -
	+ have st: "
	+ (\<Sum>k \| k \<in> {1..n} \<and> d dvd k. (f k n)) =
	+ (\<Sum>q \<in> {1..n div d}. (f q (n div d)))"
	+ if "d dvd n" "d > 0" for d :: nat
	+ by (rule sum.reindex_bij_witness[of _ "\<lambda>k. k * d" "\<lambda>k. k div d"])
	+ (use assms(3) that in \<open>fastforce simp: div_le_mono\<close>)+
	+ show ?thesis
	+ by (intro sum.cong) (use st False in fastforce)+
	+ qed
	+ also have "\<dots> = (\<Sum>d \| d dvd n. moebius_mu d * F(n div d))"
	+ proof -
	+ have "F (n div d) = (\<Sum>q \<in> {1..n div d}. (f q (n div d)))"
	+ if "d dvd n" for d
	+ by (simp add: F_def real_of_nat_div that)
	+ then show ?thesis by auto
	+ qed
	+ also have "\<dots> = dirichlet_prod moebius_mu F n"
	+ by (simp add: dirichlet_prod_def)
	+ finally show ?thesis by simp
	+qed
	+
	+lemma dirichlet_prod_neutral_sum:
	+ "dirichlet_prod_neutral n = (\<Sum>k = 1..n. unity_root n k)" for n :: nat
	+proof (cases "n = 0")
	+ case True then show ?thesis unfolding dirichlet_prod_neutral_def by simp
	+next
	+ case False
	+ have 1: "unity_root n 0 = 1" by simp
	+ have 2: "unity_root n n = 1"
	+ using unity_periodic_arithmetic[of n] add.left_neutral
	+ proof -
	+ have "1 = unity_root n (int 0)"
	+ using 1 by auto
	+ also have "unity_root n (int 0) = unity_root n (int (0 + n))"
	+ using unity_periodic_arithmetic[of n] periodic_arithmetic_def by algebra
	+ also have "\<dots> = unity_root n (int n)" by simp
	+ finally show ?thesis by auto
	+ qed
	+ have "(\<Sum>k = 1..n. unity_root n k) = (\<Sum>k = 0..n. unity_root n k) - 1"
	+ by (simp add: sum.atLeast_Suc_atMost sum.atLeast0_atMost_Suc_shift 1)
	+ also have "\<dots> = ((\<Sum>k = 0..n-1. unity_root n k)+1) - 1"
	+ using sum.atLeast0_atMost_Suc[of "(\<lambda>k. unity_root n k)" "n-1"] False
	+ by (simp add: 2)
	+ also have "\<dots> = (\<Sum>k = 0..n-1. unity_root n k)"
	+ by simp
	+ also have "\<dots> = unity_root_sum n 1"
	+ unfolding unity_root_sum_def using \<open>n \<noteq> 0\<close> by (intro sum.cong) auto
	+ also have "\<dots> = dirichlet_prod_neutral n"
	+ using unity_root_sum[of n 1] False
	+ by (cases "n = 1",auto simp add: False dirichlet_prod_neutral_def)
	+ finally have 3: "dirichlet_prod_neutral n = (\<Sum>k = 1..n. unity_root n k)" by auto
	+ then show ?thesis by blast
	+qed
	+
	+lemma moebius_coprime_sum:
	+ "moebius_mu n = (\<Sum>k \| k \<in> {1..n} \<and> coprime k n . unity_root n (int k))"
	+proof -
	+ let ?f = "(\<lambda>k n. unity_root n k)"
	+ from div_dvd_div have "
	+ d dvd a \<Longrightarrow> d dvd b \<Longrightarrow>
	+ unity_root (a div d) (b div d) =
	+ unity_root a b" for a b d :: nat
	+ using unity_root_def real_of_nat_div by fastforce
	+ then have "(\<Sum>k \| k \<in> {1..n} \<and> coprime k n. ?f k n) =
	+ dirichlet_prod moebius_mu (\<lambda>n. \<Sum>k = 1..n. ?f k n) n"
	+ using sum_coprime_conv_dirichlet_prod_moebius_mu[of ?f n] by blast
	+ also have "\<dots> = dirichlet_prod moebius_mu dirichlet_prod_neutral n"
	+ by (simp add: dirichlet_prod_neutral_sum)
	+ also have "\<dots> = moebius_mu n"
	+ by (cases "n = 0") (simp_all add: dirichlet_prod_neutral_right_neutral)
	+ finally have "moebius_mu n = (\<Sum>k \| k \<in> {1..n} \<and> coprime k n. ?f k n)"
	+ by argo
	+ then show ?thesis by blast
	+qed
	+
	+corollary ramanujan_sum_1_right [simp]: "c k (Suc 0) = moebius_mu k"
	+ unfolding ramanujan_sum_def using moebius_coprime_sum[of k] by simp
	+
	+lemma ramanujan_sum_dvd_eq_totient:
	+ assumes "k dvd n"
	+ shows "c k n = totient k"
	+ unfolding ramanujan_sum_def
	+proof -
	+ have "unity_root k (m*n) = 1" for m
	+ using assms by (cases "k = 0") (auto simp: unity_root_eq_1_iff_int)
	+ then have "(\<Sum>m \| m \<in> {1..k} \<and> coprime m k. unity_root k (m * n)) =
	+ (\<Sum>m \| m \<in> {1..k} \<and> coprime m k. 1)" by simp
	+ also have "\<dots> = card {m. m \<in> {1..k} \<and> coprime m k}" by simp
	+ also have "\<dots> = totient k"
	+ unfolding totient_def totatives_def
	+ proof -
	+ have "{1..k} = {0<..k}" by auto
	+ then show " of_nat (card {m \<in> {1..k}. coprime m k}) =
	+ of_nat (card {ka \<in> {0<..k}. coprime ka k})" by auto
	+ qed
	+ finally show "(\<Sum>m \| m \<in> {1..k} \<and> coprime m k. unity_root k (m * n)) = totient k"
	+ by auto
	+qed
	+
	+subsection \<open>Generalised sums\<close>
	+
	+definition gen_ramanujan_sum :: "(nat \<Rightarrow> complex) \<Rightarrow> (nat \<Rightarrow> complex) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> complex" where
	+ "gen_ramanujan_sum f g = (\<lambda>k n. \<Sum>d \| d dvd gcd n k. f d * g (k div d))"
	+
	+notation gen_ramanujan_sum ("s")
	+
	+lemma gen_ramanujan_sum_k_1: "s f g k 1 = f 1 * g k"
	+ unfolding gen_ramanujan_sum_def by auto
	+
	+lemma gen_ramanujan_sum_1_n: "s f g 1 n = f 1 * g 1"
	+ unfolding gen_ramanujan_sum_def by simp
	+
	+lemma gen_ramanujan_sum_periodic: "periodic_arithmetic (s f g k) k"
	+ unfolding gen_ramanujan_sum_def periodic_arithmetic_def by simp
	+
	+text \<open>Theorem 8.5\<close>
	+theorem gen_ramanujan_sum_fourier_expansion:
	+ fixes f g :: "nat \<Rightarrow> complex" and a :: "nat \<Rightarrow> nat \<Rightarrow> complex"
	+ assumes "k > 0"
	+ defines "a \<equiv> (\<lambda>k m. (1/k) * (\<Sum>d\| d dvd (gcd m k). g d * f (k div d) * d))"
	+ shows "s f g k n = (\<Sum>m\<le>k-1. a k m * unity_root k (m*n))"
	+proof -
	+ let ?g = "(\<lambda>x. 1 / of_nat k * (\<Sum>m<k. s f g k m * unity_root k (-x*m)))"
	+ {fix m :: nat
	+ let ?h = "\<lambda>n d. f d * g (k div d) * unity_root k (- m * int n)"
	+ have "(\<Sum>l<k. s f g k l * unity_root k (-m*l)) =
	+ (\<Sum>l \<in> {0..k-1}. s f g k l * unity_root k (-m*l))"
	+ using \<open>k > 0\<close> by (intro sum.cong) auto
	+ also have "\<dots> = (\<Sum>l \<in> {1..k}. s f g k l * unity_root k (-m*l))"
	+ proof -
	+ have "periodic_arithmetic (\<lambda>l. unity_root k (-m*l)) k"
	+ using unity_periodic_arithmetic_mult by blast
	+ then have "periodic_arithmetic (\<lambda>l. s f g k l * unity_root k (-m*l)) k"
	+ using gen_ramanujan_sum_periodic mult_periodic_arithmetic by blast
	+ from this periodic_arithmetic_sum_periodic_arithmetic_shift[of _ k 1 ]
	+ have "sum (\<lambda>l. s f g k l * unity_root k (-m*l)) {0..k - 1} =
	+ sum (\<lambda>l. s f g k l * unity_root k (-m*l)) {1..k}"
	+ using assms(1) zero_less_one by simp
	+ then show ?thesis by argo
	+ qed
	+ also have "\<dots> = (\<Sum>n\<in>{1..k}. (\<Sum>d \| d dvd (gcd n k). f(d) * g(k div d)) * unity_root k (-m*n))"
	+ by (simp add: gen_ramanujan_sum_def)
	+ also have "\<dots> = (\<Sum>n\<in>{1..k}. (\<Sum>d \| d dvd (gcd n k). f(d) * g(k div d) * unity_root k (-m*n)))"
	+ by (simp add: sum_distrib_right)
	+ also have "\<dots> = (\<Sum>d \| d dvd k. \<Sum>n \| n \<in> {1..k} \<and> d dvd n. ?h n d)"
	+ proof -
	+ have "(\<Sum>n = 1..k. \<Sum>d \| d dvd gcd n k. ?h n d) =
	+ (\<Sum>n = 1..k. \<Sum>d \| d dvd k \<and> d dvd n . ?h n d)"
	+ using gcd.commute[of _ k] by simp
	+ also have "\<dots> = (\<Sum>d \| d dvd k. \<Sum>n \| n \<in> {1..k} \<and> d dvd n. ?h n d)"
	+ using sum.swap_restrict[of "{1..k}" "{d. d dvd k}"
	+ _ "\<lambda>n d. d dvd n"] assms by fastforce
	+ finally have "
	+ (\<Sum>n = 1..k. \<Sum>d \| d dvd gcd n k. ?h n d) =
	+ (\<Sum>d \| d dvd k. \<Sum>n \| n \<in> {1..k} \<and> d dvd n. ?h n d)" by blast
	+ then show ?thesis by simp
	+ qed
	+ also have "\<dots> = (\<Sum>d \| d dvd k. f(d)g(k div d)
	+ (\<Sum>n \| n \<in> {1..k} \<and> d dvd n. unity_root k (- m * int n)))"
	+ by (simp add: sum_distrib_left)
	+ also have "\<dots> = (\<Sum>d \| d dvd k. f(d)g(k div d)
	+ (\<Sum>e \<in> {1..k div d}. unity_root k (- m * (e*d))))"
	+ using assms(1) sum_div_reduce div_greater_zero_iff dvd_div_gt0 by auto
	+ also have "\<dots> = (\<Sum>d \| d dvd k. f(d)g(k div d)
	+ (\<Sum>e \<in> {1..k div d}. unity_root (k div d) (- m * e)))"
	+ proof -
	+ {
	+ fix d e
	+ assume "d dvd k"
	+ hence "2 * pi * real_of_int (- int m * int (e * d)) / real k =
	+ 2 * pi * real_of_int (- int m * int e) / real (k div d)" by auto
	+ hence "unity_root k (- m * (e * d)) = unity_root (k div d) (- m * e)"
	+ unfolding unity_root_def by simp
	+ }
	+ then show ?thesis by simp
	+ qed
	+ also have "\<dots> = dirichlet_prod (\<lambda>d. f(d)*g(k div d))
	+ (\<lambda>d. (\<Sum>e \<in> {1..d}. unity_root d (- m * e))) k"
	+ unfolding dirichlet_prod_def by blast
	+ also have "\<dots> = dirichlet_prod (\<lambda>d. (\<Sum>e \<in> {1..d}. unity_root d (- m * e)))
	+ (\<lambda>d. f(d)*g(k div d)) k"
	+ using dirichlet_prod_commutes[of
	+ "(\<lambda>d. f(d)*g(k div d))"
	+ "(\<lambda>d. (\<Sum>e \<in> {1..d}. unity_root d (- m * e)))"] by argo
	+ also have "\<dots> = (\<Sum>d \| d dvd k.
	+ (\<Sum>e \<in> {1..(d::nat)}. unity_root d (- m * e))(f(k div d)g(k div (k div d))))"
	+ unfolding dirichlet_prod_def by blast
	+ also have "\<dots> = (\<Sum>d \| d dvd k. (\<Sum>e \<in> {1..(d::nat)}.
	+ unity_root d (- m * e))(f(k div d)g(d)))"
	+ proof -
	+ {
	+ fix d :: nat
	+ assume "d dvd k"
	+ then have "k div (k div d) = d"
	+ by (simp add: assms(1) div_div_eq_right)
	+ }
	+ then show ?thesis by simp
	+ qed
	+ also have "\<dots> = (\<Sum>(d::nat) \| d dvd k \<and> d dvd m. d(f(k div d)g(d)))"
	+ proof -
	+ {
	+ fix d
	+ assume "d dvd k"
	+ with assms have "d > 0" by (intro Nat.gr0I) auto
	+ have "periodic_arithmetic (\<lambda>x. unity_root d (- m * int x)) d"
	+ using unity_periodic_arithmetic_mult by blast
	+ then have "(\<Sum>e \<in> {1..d}. unity_root d (- m * e)) =
	+ (\<Sum>e \<in> {0..d-1}. unity_root d (- m * e))"
	+ using periodic_arithmetic_sum_periodic_arithmetic_shift[of "\<lambda>e. unity_root d (- m * e)" d 1] assms \<open>d dvd k\<close>
	+ by fastforce
	+ also have "\<dots> = unity_root_sum d (-m)"
	+ unfolding unity_root_sum_def using \<open>d > 0\<close> by (intro sum.cong) auto
	+ finally have
	+ "(\<Sum>e \<in> {1..d}. unity_root d (- m * e)) = unity_root_sum d (-m)"
	+ by argo
	+ }
	+ then have "
	+ (\<Sum>d \| d dvd k. (\<Sum>e = 1..d. unity_root d (- m * int e)) * (f (k div d) * g d)) =
	+ (\<Sum>d \| d dvd k. unity_root_sum d (-m) * (f (k div d) * g d))" by simp
	+ also have "\<dots> = (\<Sum>d \| d dvd k \<and> d dvd m. unity_root_sum d (-m) * (f (k div d) * g d))"
	+ proof (intro sum.mono_neutral_right,simp add: \<open>k > 0\<close>,blast,standard)
	+ fix i
	+ assume as: "i \<in> {d. d dvd k} - {d. d dvd k \<and> d dvd m}"
	+ then have "i \<ge> 1" using \<open>k > 0\<close> by auto
	+ have "k \<ge> 1" using \<open>k > 0\<close> by auto
	+ have "\<not> i dvd (-m)" using as by auto
	+ thus "unity_root_sum i (- int m) * (f (k div i) * g i) = 0"
	+ using \<open>i \<ge> 1\<close> by (subst unity_root_sum(2)) auto
	+ qed
	+ also have "\<dots> = (\<Sum>d \| d dvd k \<and> d dvd m. d * (f (k div d) * g d))"
	+ proof -
	+ {fix d :: nat
	+ assume 1: "d dvd m"
	+ assume 2: "d dvd k"
	+ then have "unity_root_sum d (-m) = d"
	+ using unity_root_sum[of d "(-m)"] assms(1) 1 2
	+ by auto}
	+ then show ?thesis by auto
	+ qed
	+ finally show ?thesis by argo
	+ qed
	+ also have "\<dots> = (\<Sum>d \| d dvd gcd m k. of_nat d * (f (k div d) * g d))"
	+ by (simp add: gcd.commute)
	+ also have "\<dots> = (\<Sum>d \| d dvd gcd m k. g d * f (k div d) * d)"
	+ by (simp add: algebra_simps sum_distrib_left)
	+ also have "1 / k * \<dots> = a k m" using a_def by auto
	+ finally have "?g m = a k m" by simp}
	+ note a_eq_g = this
	+ {
	+ fix m
	+ from fourier_expansion_periodic_arithmetic(2)[of k "s f g k" ] gen_ramanujan_sum_periodic assms(1)
	+ have "s f g k m = (\<Sum>n<k. ?g n * unity_root k (int m * n))"
	+ by blast
	+ also have "\<dots> = (\<Sum>n<k. a k n * unity_root k (int m * n))"
	+ using a_eq_g by simp
	+ also have "\<dots> = (\<Sum>n\<le>k-1. a k n * unity_root k (int m * n))"
	+ using \<open>k > 0\<close> by (intro sum.cong) auto
	+ finally have "s f g k m =
	+ (\<Sum>n\<le>k - 1. a k n * unity_root k (int n * int m))"
	+ by (simp add: algebra_simps)
	+ }
	+ then show ?thesis by blast
	+qed
	+
	+text \<open>Theorem 8.6\<close>
	+theorem ramanujan_sum_dirichlet_form:
	+ fixes k n :: nat
	+ assumes "k > 0"
	+ shows "c k n = (\<Sum>d \| d dvd gcd n k. d * moebius_mu (k div d))"
	+proof -
	+ define a :: "nat \<Rightarrow> nat \<Rightarrow> complex"
	+ where "a = (\<lambda>k m.
	+ 1 / of_nat k * (\<Sum>d \| d dvd gcd m k. moebius_mu d * of_nat (k div d) * of_nat d))"
	+
	+ {fix m
	+ have "a k m = (if gcd m k = 1 then 1 else 0)"
	+ proof -
	+ have "a k m = 1 / of_nat k * (\<Sum>d \| d dvd gcd m k. moebius_mu d * of_nat (k div d) * of_nat d)"
	+ unfolding a_def by blast
	+ also have 2: "\<dots> = 1 / of_nat k * (\<Sum>d \| d dvd gcd m k. moebius_mu d * of_nat k)"
	+ proof -
	+ {fix d :: nat
	+ assume dvd: "d dvd gcd m k"
	+ have "moebius_mu d * of_nat (k div d) * of_nat d = moebius_mu d * of_nat k"
	+ proof -
	+ have "(k div d) * d = k" using dvd by auto
	+ then show "moebius_mu d * of_nat (k div d) * of_nat d = moebius_mu d * of_nat k"
	+ by (simp add: algebra_simps,subst of_nat_mult[symmetric],simp)
	+ qed} note eq = this
	+ show ?thesis using sum.cong by (simp add: eq)
	+ qed
	+
	+ also have 3: "\<dots> = (\<Sum>d \| d dvd gcd m k. moebius_mu d)"
	+ by (simp add: sum_distrib_left assms)
	+ also have 4: "\<dots> = (if gcd m k = 1 then 1 else 0)"
	+ using sum_moebius_mu_divisors' by blast
	+ finally show "a k m = (if gcd m k = 1 then 1 else 0)"
	+ using coprime_def by blast
	+ qed} note a_expr = this
	+
	+ let ?f = "(\<lambda>m. (if gcd m k = 1 then 1 else 0) *
	+ unity_root k (int m * n))"
	+ from gen_ramanujan_sum_fourier_expansion[of k id moebius_mu n] assms
	+ have "s (\<lambda>x. of_nat (id x)) moebius_mu k n =
	+ (\<Sum>m\<le>k - 1.
	+ 1 / of_nat k *
	+ (\<Sum>d \| d dvd gcd m k.
	+ moebius_mu d * of_nat (k div d) * of_nat d) *
	+ unity_root k (int m * n))" by simp
	+ also have "\<dots> = (\<Sum>m\<le>k - 1.
	+ a k m *
	+ unity_root k (int m * n))" using a_def by blast
	+ also have "\<dots> = (\<Sum>m\<le>k - 1.
	+ (if gcd m k = 1 then 1 else 0) *
	+ unity_root k (int m * n))" using a_expr by auto
	+ also have "\<dots> = (\<Sum>m \<in> {1..k}.
	+ (if gcd m k = 1 then 1 else 0) *
	+ unity_root k (int m * n))"
	+ proof -
	+ have "periodic_arithmetic (\<lambda>m. (if gcd m k = 1 then 1 else 0) *
	+ unity_root k (int m * n)) k"
	+ proof -
	+ have "periodic_arithmetic (\<lambda>m. if gcd m k = 1 then 1 else 0) k"
	+ by (simp add: periodic_arithmetic_def)
	+ moreover have "periodic_arithmetic (\<lambda>m. unity_root k (int m * n)) k"
	+ using unity_periodic_arithmetic_mult[of k n]
	+ by (subst mult.commute,simp)
	+ ultimately show "periodic_arithmetic ?f k"
	+ using mult_periodic_arithmetic by simp
	+ qed
	+ then have "sum ?f {0..k - 1} = sum ?f {1..k}"
	+ using periodic_arithmetic_sum_periodic_arithmetic_shift[of ?f k 1] by force
	+ then show ?thesis by (simp add: atMost_atLeast0)
	+ qed
	+ also have "\<dots> = (\<Sum>m \| m \<in> {1..k} \<and> gcd m k = 1.
	+ (if gcd m k = 1 then 1 else 0) *
	+ unity_root k (int m * int n))"
	+ by (intro sum.mono_neutral_right,auto)
	+ also have "\<dots> = (\<Sum>m \| m \<in> {1..k} \<and> gcd m k = 1.
	+ unity_root k (int m * int n))" by simp
	+ also have "\<dots> = (\<Sum>m \| m \<in> {1..k} \<and> coprime m k.
	+ unity_root k (int m * int n))"
	+ using coprime_iff_gcd_eq_1 by presburger
	+ also have "\<dots> = c k n" unfolding ramanujan_sum_def by simp
	+ finally show ?thesis unfolding gen_ramanujan_sum_def by auto
	+qed
	+
	+corollary ramanujan_sum_conv_gen_ramanujan_sum:
	+ "k > 0 \<Longrightarrow> c k n = s id moebius_mu k n"
	+ using ramanujan_sum_dirichlet_form unfolding gen_ramanujan_sum_def by simp
	+
	+text \<open>Theorem 8.7\<close>
	+theorem gen_ramanujan_sum_distrib:
	+ fixes f g :: "nat \<Rightarrow> complex"
	+ assumes "a > 0" "b > 0" "m > 0" "k > 0" (* remove cond. on m,n *)
	+ assumes "coprime a k" "coprime b m" "coprime k m"
	+ assumes "multiplicative_function f" and
	+ "multiplicative_function g"
	+ shows "s f g (mk) (ab) = s f g m a * s f g k b"
	+proof -
	+ from assms(1-6) have eq: "gcd (mk) (ab) = gcd a m * gcd k b"
	+ by (simp add: linear_gcd gcd.commute mult.commute)
	+ have "s f g (mk) (ab) =
	+ (\<Sum>d \| d dvd gcd (mk) (ab). f(d) * g((m*k) div d))"
	+ unfolding gen_ramanujan_sum_def by (rule sum.cong, simp add: gcd.commute,blast)
	+ also have "\<dots> =
	+ (\<Sum>d \| d dvd gcd a m * gcd k b. f(d) * g((m*k) div d))"
	+ using eq by simp
	+ also have "\<dots> =
	+ (\<Sum>(d1,d2) \| d1 dvd gcd a m \<and> d2 dvd gcd k b.
	+ f(d1d2) g((mk) div (d1d2)))"
	+ proof -
	+ have b: "bij_betw (\<lambda>(d1, d2). d1 * d2)
	+ {(d1, d2). d1 dvd gcd a m \<and> d2 dvd gcd k b}
	+ {d. d dvd gcd a m * gcd k b}"
	+ using assms(5) reindex_product_bij by blast
	+ have "(\<Sum>(d1, d2) \| d1 dvd gcd a m \<and> d2 dvd gcd k b.
	+ f (d1 * d2) * g (m * k div (d1 * d2))) =
	+ (\<Sum>x\<in>{(d1, d2). d1 dvd gcd a m \<and> d2 dvd gcd k b}.
	+ f (case x of (d1, d2) \<Rightarrow> d1 * d2)*
	+ g (m * k div (case x of (d1, d2) \<Rightarrow> d1 * d2)))"
	+ by (rule sum.cong,auto)
	+ also have "\<dots> = (\<Sum>d \| d dvd gcd a m * gcd k b. f d * g (m * k div d))"
	+ using b by (rule sum.reindex_bij_betw[of "\<lambda>(d1,d2). d1*d2" ])
	+ finally show ?thesis by argo
	+ qed
	+ also have "\<dots> = (\<Sum>d1 \| d1 dvd gcd a m. \<Sum>d2 \| d2 dvd gcd k b.
	+ f (d1d2) g ((mk) div (d1d2)))"
	+ by (simp add: sum.cartesian_product) (rule sum.cong,auto)
	+ also have "\<dots> = (\<Sum>d1 \| d1 dvd gcd a m. \<Sum>d2 \| d2 dvd gcd k b.
	+ f d1 * f d2 * g ((mk) div (d1d2)))"
	+ using assms(5) assms(8) multiplicative_function.mult_coprime
	+ by (intro sum.cong refl) fastforce+
	+ also have "\<dots> = (\<Sum>d1 \| d1 dvd gcd a m. \<Sum>d2 \| d2 dvd gcd k b.
	+ f d1 * f d2* g (m div d1) * g (k div d2))"
	+ proof (intro sum.cong refl, clarify, goal_cases)
	+ case (1 d1 d2)
	+ hence "g (m * k div (d1 * d2)) = g (m div d1) * g (k div d2)"
	+ using assms(7,9) multipl_div
	+ by (meson coprime_commute dvd_gcdD1 dvd_gcdD2)
	+ thus ?case by simp
	+ qed
	+ also have "\<dots> = (\<Sum>i\<in>{d1. d1 dvd gcd a m}. \<Sum>j\<in>{d2. d2 dvd gcd k b}.
	+ f i * g (m div i) * (f j * g (k div j)))"
	+ by (rule sum.cong,blast,rule sum.cong,blast,simp)
	+ also have "\<dots> = (\<Sum>d1 \| d1 dvd gcd a m. f d1 * g (m div d1)) *
	+ (\<Sum>d2 \| d2 dvd gcd k b. f d2 * g (k div d2))"
	+ by (simp add: sum_product)
	+ also have "\<dots> = s f g m a * s f g k b"
	+ unfolding gen_ramanujan_sum_def by (simp add: gcd.commute)
	+ finally show ?thesis by blast
	+qed
	+
	+corollary gen_ramanujan_sum_distrib_right:
	+ fixes f g :: "nat \<Rightarrow> complex"
	+ assumes "a > 0" and "b > 0" and "m > 0" (* TODO: remove cond. on m,n *)
	+ assumes "coprime b m"
	+ assumes "multiplicative_function f" and
	+ "multiplicative_function g"
	+ shows "s f g m (a * b) = s f g m a"
	+proof -
	+ have "s f g m (ab) = s f g m a s f g 1 b"
	+ using assms gen_ramanujan_sum_distrib[of a b m 1 f g] by simp
	+ also have "\<dots> = s f g m a * f 1 * g 1"
	+ using gen_ramanujan_sum_1_n by auto
	+ also have "\<dots> = s f g m a"
	+ using assms(5-6)
	+ by (simp add: multiplicative_function_def)
	+ finally show "s f g m (a*b) = s f g m a" by blast
	+qed
	+
	+corollary gen_ramanujan_sum_distrib_left:
	+ fixes f g :: "nat \<Rightarrow> complex"
	+ assumes "a > 0" and "k > 0" and "m > 0" (* TODO: remove cond. on m,n *)
	+ assumes "coprime a k" and "coprime k m"
	+ assumes "multiplicative_function f" and
	+ "multiplicative_function g"
	+ shows "s f g (mk) a = s f g m a g k"
	+proof -
	+ have "s f g (mk) a = s f g m a s f g k 1"
	+ using assms gen_ramanujan_sum_distrib[of a 1 m k f g] by simp
	+ also have "\<dots> = s f g m a * f(1) * g(k)"
	+ using gen_ramanujan_sum_k_1 by auto
	+ also have "\<dots> = s f g m a * g k"
	+ using assms(6)
	+ by (simp add: multiplicative_function_def)
	+ finally show ?thesis by blast
	+qed
	+
	+corollary ramanujan_sum_distrib:
	+ assumes "a > 0" and "k > 0" and "m > 0" and "b > 0" (* TODO: remove cond. on m,n *)
	+ assumes "coprime a k" "coprime b m" "coprime m k"
	+ shows "c (mk) (ab) = c m a * c k b"
	+proof -
	+ have "c (mk) (ab) = s id moebius_mu (mk) (ab)"
	+ using ramanujan_sum_conv_gen_ramanujan_sum assms(2,3) by simp
	+
	+ also have "\<dots> = (s id moebius_mu m a) * (s id moebius_mu k b)"
	+ using gen_ramanujan_sum_distrib[of a b m k id moebius_mu]
	+ assms mult_id mult_moebius mult_of_nat
	+ coprime_commute[of m k] by auto
	+ also have "\<dots> = c m a * c k b" using ramanujan_sum_conv_gen_ramanujan_sum assms by simp
	+ finally show ?thesis by simp
	+qed
	+
	+corollary ramanujan_sum_distrib_right:
	+ assumes "a > 0" and "k > 0" and "m > 0" and "b > 0" (* remove cond. on m,n *)
	+ assumes "coprime b m"
	+ shows "c m (a*b) = c m a"
	+ using assms ramanujan_sum_conv_gen_ramanujan_sum mult_id mult_moebius
	+ mult_of_nat gen_ramanujan_sum_distrib_right by auto
	+
	+corollary ramanujan_sum_distrib_left:
	+ assumes "a > 0" "k > 0" "m > 0" (* remove cond. on m,n *)
	+ assumes "coprime a k" "coprime m k"
	+ shows "c (mk) a = c m a moebius_mu k"
	+ using assms
	+ by (simp add: ramanujan_sum_conv_gen_ramanujan_sum, subst gen_ramanujan_sum_distrib_left)
	+ (auto simp: coprime_commute mult_of_nat mult_moebius)
	+
	+lemma dirichlet_prod_completely_multiplicative_left:
	+ fixes f h :: "nat \<Rightarrow> complex" and k :: nat
	+ defines "g \<equiv> (\<lambda>k. moebius_mu k * h k)"
	+ defines "F \<equiv> dirichlet_prod f g"
	+ assumes "k > 0"
	+ assumes "completely_multiplicative_function f"
	+ "multiplicative_function h"
	+ assumes "\<And>p. prime p \<Longrightarrow> f(p) \<noteq> 0 \<and> f(p) \<noteq> h(p)"
	+ shows "F k = f k * (\<Prod>p\<in>prime_factors k. 1 - h p / f p)"
	+proof -
	+ have 1: "multiplicative_function (\<lambda>p. h(p) div f(p))"
	+ using multiplicative_function_divide
	+ comp_to_mult assms(4,5) by blast
	+ have "F k = dirichlet_prod g f k"
	+ unfolding F_def using dirichlet_prod_commutes[of f g] by auto
	+ also have "\<dots> = (\<Sum>d \| d dvd k. moebius_mu d * h d * f(k div d))"
	+ unfolding g_def dirichlet_prod_def by blast
	+ also have "\<dots> = (\<Sum>d \| d dvd k. moebius_mu d * h d * (f(k) div f(d)))"
	+ using multipl_div_mono[of f _ k] assms(4,6)
	+ by (intro sum.cong,auto,force)
	+ also have "\<dots> = f k * (\<Sum>d \| d dvd k. moebius_mu d * (h d div f(d)))"
	+ by (simp add: sum_distrib_left algebra_simps)
	+ also have "\<dots> = f k * (\<Prod>p\<in>prime_factors k. 1 - (h p div f p))"
	+ using sum_divisors_moebius_mu_times_multiplicative[of "\<lambda>p. h p div f p" k] 1
	+ assms(3) by simp
	+ finally show F_eq: "F k = f k * (\<Prod>p\<in>prime_factors k. 1 - (h p div f p))"
	+ by blast
	+qed
	+
	+text \<open>Theorem 8.8\<close>
	+theorem gen_ramanujan_sum_dirichlet_expr:
	+ fixes f h :: "nat \<Rightarrow> complex" and n k :: nat
	+ defines "g \<equiv> (\<lambda>k. moebius_mu k * h k)"
	+ defines "F \<equiv> dirichlet_prod f g"
	+ defines "N \<equiv> k div gcd n k"
	+ assumes "completely_multiplicative_function f"
	+ "multiplicative_function h"
	+ assumes "\<And>p. prime p \<Longrightarrow> f(p) \<noteq> 0 \<and> f(p) \<noteq> h(p)"
	+ assumes "k > 0" "n > 0"
	+ shows "s f g k n = (F(k)*g(N)) div (F(N))"
	+proof -
	+ define a where "a \<equiv> gcd n k"
	+ have 2: "k = a*N" unfolding a_def N_def by auto
	+ have 3: "a > 0" using a_def assms(7,8) by simp
	+ have Ngr0: "N > 0" using assms(7,8) 2 N_def by fastforce
	+ have f_k_not_z: "f k \<noteq> 0"
	+ using completely_multiplicative_nonzero assms(4,6,7) by blast
	+ have f_N_not_z: "f N \<noteq> 0"
	+ using completely_multiplicative_nonzero assms(4,6) Ngr0 by blast
	+ have bij: "bij_betw (\<lambda>d. a div d) {d. d dvd a} {d. d dvd a}"
	+ unfolding bij_betw_def
	+ proof
	+ show inj: "inj_on (\<lambda>d. a div d) {d. d dvd a}"
	+ using inj_on_def "3" dvd_div_eq_2 by blast
	+ show surj: "(\<lambda>d. a div d) ` {d. d dvd a} = {d. d dvd a}"
	+ unfolding image_def
	+ proof
	+ show " {y. \<exists>x\<in>{d. d dvd a}. y = a div x} \<subseteq> {d. d dvd a}"
	+ by auto
	+ show "{d. d dvd a} \<subseteq> {y. \<exists>x\<in>{d. d dvd a}. y = a div x}"
	+ proof
	+ fix d
	+ assume a: "d \<in> {d. d dvd a}"
	+ from a have 1: "(a div d) \<in> {d. d dvd a}" by auto
	+ from a have 2: "d = a div (a div d)" using 3 by auto
	+ from 1 2 show "d \<in> {y. \<exists>x\<in>{d. d dvd a}. y = a div x} " by blast
	+ qed
	+ qed
	+ qed
	+
	+ have "s f g k n = (\<Sum>d \| d dvd a. f(d)moebius_mu(k div d)h(k div d))"
	+ unfolding gen_ramanujan_sum_def g_def a_def by (simp add: mult.assoc)
	+ also have "\<dots> = (\<Sum>d \| d dvd a. f(d) * moebius_mu(aN div d)h(a*N div d))"
	+ using 2 by blast
	+ also have "\<dots> = (\<Sum>d \| d dvd a. f(a div d) * moebius_mu(Nd)h(N*d))"
	+ (is "?a = ?b")
	+ proof -
	+ define f_aux where "f_aux \<equiv> (\<lambda>d. f d * moebius_mu (a * N div d) * h (a * N div d))"
	+ have 1: "?a = (\<Sum>d \| d dvd a. f_aux d)" using f_aux_def by blast
	+ {fix d :: nat
	+ assume "d dvd a"
	+ then have "N * a div (a div d) = N * d"
	+ using 3 by force}
	+ then have 2: "?b = (\<Sum>d \| d dvd a. f_aux (a div d))"
	+ unfolding f_aux_def by (simp add: algebra_simps)
	+ show "?a = ?b"
	+ using bij 1 2
	+ by (simp add: sum.reindex_bij_betw[of "((div) a)" "{d. d dvd a}" "{d. d dvd a}"])
	+ qed
	+ also have "\<dots> = moebius_mu N * h N * f a * (\<Sum>d \| d dvd a \<and> coprime N d. moebius_mu d * (h d div f d))"
	+ (is "?a = ?b")
	+ proof -
	+ have "?a = (\<Sum>d \| d dvd a \<and> coprime N d. f(a div d) * moebius_mu (Nd) h (N*d))"
	+ by (rule sum.mono_neutral_right)(auto simp add: moebius_prod_not_coprime 3)
	+ also have "\<dots> = (\<Sum>d \| d dvd a \<and> coprime N d. moebius_mu N * h N * f(a div d) * moebius_mu d * h d)"
	+ proof (rule sum.cong,simp)
	+ fix d
	+ assume a: "d \<in> {d. d dvd a \<and> coprime N d}"
	+ then have 1: "moebius_mu (Nd) = moebius_mu N moebius_mu d"
	+ using mult_moebius unfolding multiplicative_function_def
	+ by (simp add: moebius_mu.mult_coprime)
	+ from a have 2: "h (Nd) = h N h d"
	+ using assms(5) unfolding multiplicative_function_def
	+ by (simp add: assms(5) multiplicative_function.mult_coprime)
	+ show "f (a div d) * moebius_mu (N * d) * h (N * d) =
	+ moebius_mu N * h N * f (a div d) * moebius_mu d * h d"
	+ by (simp add: divide_simps 1 2)
	+ qed
	+ also have "\<dots> = (\<Sum>d \| d dvd a \<and> coprime N d. moebius_mu N * h N * (f a div f d) * moebius_mu d * h d)"
	+ by (intro sum.cong refl) (use multipl_div_mono[of f _ a] assms(4,6-8) 3 in force)
	+ also have "\<dots> = moebius_mu N * h N * f a * (\<Sum>d \| d dvd a \<and> coprime N d. moebius_mu d * (h d div f d))"
	+ by (simp add: sum_distrib_left algebra_simps)
	+ finally show ?thesis by blast
	+ qed
	+ also have "\<dots> =
	+ moebius_mu N * h N * f a * (\<Prod>p\<in>{p. p \<in> prime_factors a \<and> \<not> (p dvd N)}. 1 - (h p div f p))"
	+ proof -
	+ have "multiplicative_function (\<lambda>d. h d div f d)"
	+ using multiplicative_function_divide
	+ comp_to_mult
	+ assms(4,5) by blast
	+ then have "(\<Sum>d \| d dvd a \<and> coprime N d. moebius_mu d * (h d div f d)) =
	+ (\<Prod>p\<in>{p. p \<in> prime_factors a \<and> \<not> (p dvd N)}. 1 - (h p div f p))"
	+ using sum_divisors_moebius_mu_times_multiplicative_revisited[
	+ of "(\<lambda>d. h d div f d)" a N]
	+ assms(8) Ngr0 3 by blast
	+ then show ?thesis by argo
	+ qed
	+ also have "\<dots> = f(a) * moebius_mu(N) * h(N) *
	+ ((\<Prod>p\<in>{p. p \<in> prime_factors (a*N)}. 1 - (h p div f p)) div
	+ (\<Prod>p\<in>{p. p \<in> prime_factors N}. 1 - (h p div f p)))"
	+ proof -
	+ have "{p. p \<in>prime_factors a \<and> \<not> p dvd N} =
	+ ({p. p \<in>prime_factors (a*N)} - {p. p \<in>prime_factors N})"
	+ using p_div_set[of a N] by blast
	+ then have eq2: "(\<Prod>p\<in>{p. p \<in>prime_factors a \<and> \<not> p dvd N}. 1 - h p / f p) =
	+ prod (\<lambda>p. 1 - h p / f p) ({p. p \<in>prime_factors (a*N)} - {p. p \<in>prime_factors N})"
	+ by auto
	+ also have eq: "\<dots> = prod (\<lambda>p. 1 - h p / f p) {p. p \<in>prime_factors (a*N)} div
	+ prod (\<lambda>p. 1 - h p / f p) {p. p \<in>prime_factors N}"
	+ proof (intro prod_div_sub,simp,simp,simp add: "3" Ngr0 dvd_prime_factors,simp,standard)
	+ fix b
	+ assume "b \<in># prime_factorization N"
	+ then have p_b: "prime b" using in_prime_factors_iff by blast
	+ then show "f b = 0 \<or> h b \<noteq> f b" using assms(6)[OF p_b] by auto
	+ qed
	+ also have "\<dots> = (\<Prod>p\<in>{p. p \<in> prime_factors (a*N)}. 1 - (h p div f p)) div
	+ (\<Prod>p\<in>{p. p \<in> prime_factors N}. 1 - (h p div f p))" by blast
	+ finally have "(\<Prod>p\<in>{p. p \<in>prime_factors a \<and> \<not> p dvd N}. 1 - h p / f p) =
	+ (\<Prod>p\<in>{p. p \<in> prime_factors (a*N)}. 1 - (h p div f p)) div
	+ (\<Prod>p\<in>{p. p \<in> prime_factors N}. 1 - (h p div f p))"
	+ using eq eq2 by auto
	+ then show ?thesis by simp
	+ qed
	+ also have "\<dots> = f(a) * moebius_mu(N) * h(N) * (F(k) div f(k)) * (f(N) div F(N))"
	+ (is "?a = ?b")
	+ proof -
	+ have "F(N) = (f N) *(\<Prod>p\<in> prime_factors N. 1 - (h p div f p))"
	+ unfolding F_def g_def
	+ by (intro dirichlet_prod_completely_multiplicative_left) (auto simp add: Ngr0 assms(4-6))
	+ then have eq_1: "(\<Prod>p\<in> prime_factors N. 1 - (h p div f p)) =
	+ F N div f N" using 2 f_N_not_z by simp
	+ have "F(k) = (f k) * (\<Prod>p\<in> prime_factors k. 1 - (h p div f p))"
	+ unfolding F_def g_def
	+ by (intro dirichlet_prod_completely_multiplicative_left) (auto simp add: assms(4-7))
	+ then have eq_2: "(\<Prod>p\<in> prime_factors k. 1 - (h p div f p)) =
	+ F k div f k" using 2 f_k_not_z by simp
	+
	+ have "?a = f a * moebius_mu N * h N *
	+ ((\<Prod>p\<in> prime_factors k. 1 - (h p div f p)) div
	+ (\<Prod>p\<in> prime_factors N. 1 - (h p div f p)))"
	+ using 2 by (simp add: algebra_simps)
	+ also have "\<dots> = f a * moebius_mu N * h N * ((F k div f k) div (F N div f N))"
	+ by (simp add: eq_1 eq_2)
	+ finally show ?thesis by simp
	+ qed
	+ also have "\<dots> = moebius_mu N * h N * ((F k * f a * f N) div (F N * f k))"
	+ by (simp add: algebra_simps)
	+ also have "\<dots> = moebius_mu N * h N * ((F k * f(aN)) div (F N f k))"
	+ proof -
	+ have "f a * f N = f (a*N)"
	+ proof (cases "a = 1 \<or> N = 1")
	+ case True
	+ then show ?thesis
	+ using assms(4) completely_multiplicative_function_def[of f]
	+ by auto
	+ next
	+ case False
	+ then show ?thesis
	+ using 2 assms(4) completely_multiplicative_function_def[of f]
	+ Ngr0 3 by auto
	+ qed
	+ then show ?thesis by simp
	+ qed
	+ also have "\<dots> = moebius_mu N * h N * ((F k * f(k)) div (F N * f k))"
	+ using 2 by blast
	+ also have "\<dots> = g(N) * (F k div F N)"
	+ using f_k_not_z g_def by simp
	+ also have "\<dots> = (F(k)*g(N)) div (F(N))" by auto
	+ finally show ?thesis by simp
	+qed
	+
	+(*TODO remove this and substitute
	+ the theorem totient_conv_moebius_mu in More_totient by
	+ this version: int \<rightarrow> of_nat*)
	+lemma totient_conv_moebius_mu_of_nat:
	+ "of_nat (totient n) = dirichlet_prod moebius_mu of_nat n"
	+proof (cases "n = 0")
	+ case False
	+ show ?thesis
	+ by (rule moebius_inversion)
	+ (insert False, simp_all add: of_nat_sum [symmetric] totient_divisor_sum del: of_nat_sum)
	+qed simp_all
	+
	+corollary ramanujan_sum_k_n_dirichlet_expr:
	+ fixes k n :: nat
	+ assumes "k > 0" "n > 0"
	+ shows "c k n = of_nat (totient k) *
	+ moebius_mu (k div gcd n k) div
	+ of_nat (totient (k div gcd n k))"
	+proof -
	+ define f :: "nat \<Rightarrow> complex"
	+ where "f \<equiv> of_nat"
	+ define F :: "nat \<Rightarrow> complex"
	+ where "F \<equiv> (\<lambda>d. dirichlet_prod f moebius_mu d)"
	+ define g :: "nat \<Rightarrow> complex "
	+ where "g \<equiv> (\<lambda>l. moebius_mu l)"
	+ define N where "N \<equiv> k div gcd n k"
	+ define h :: "nat \<Rightarrow> complex"
	+ where "h \<equiv> (\<lambda>x. (if x = 0 then 0 else 1))"
	+
	+ have F_is_totient_k: "F k = totient k"
	+ by (simp add: F_def f_def dirichlet_prod_commutes totient_conv_moebius_mu_of_nat[of k])
	+ have F_is_totient_N: "F N = totient N"
	+ by (simp add: F_def f_def dirichlet_prod_commutes totient_conv_moebius_mu_of_nat[of N])
	+
	+ have "c k n = s id moebius_mu k n"
	+ using ramanujan_sum_conv_gen_ramanujan_sum assms by blast
	+ also have "\<dots> = s f g k n"
	+ unfolding f_def g_def by auto
	+ also have "g = (\<lambda>k. moebius_mu k * h k)"
	+ by (simp add: fun_eq_iff h_def g_def)
	+ also have "multiplicative_function h"
	+ unfolding h_def by standard auto
	+ hence "s f (\<lambda>k. moebius_mu k * h k) k n =
	+ dirichlet_prod of_nat (\<lambda>k. moebius_mu k * h k) k *
	+ (moebius_mu (k div gcd n k) * h (k div gcd n k)) /
	+ dirichlet_prod of_nat (\<lambda>k. moebius_mu k * h k) (k div gcd n k)"
	+ unfolding f_def using assms mult_of_nat_c
	+ by (intro gen_ramanujan_sum_dirichlet_expr) (auto simp: h_def)
	+ also have "\<dots> = of_nat (totient k) * moebius_mu (k div gcd n k) / of_nat (totient (k div gcd n k))"
	+ using F_is_totient_k F_is_totient_N by (auto simp: h_def F_def N_def f_def)
	+ finally show ?thesis .
	+qed
	+
	+no_notation ramanujan_sum ("c")
	+no_notation gen_ramanujan_sum ("s")
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Gauss_Sums/document/root.bib b/thys/Gauss_Sums/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Gauss_Sums/document/root.bib
	@@ -0,0 +1,9 @@
	+@book{apostol1976analytic,
	+ series = "Undergraduate {T}exts in {M}athematics",
	+ title = "Introduction to {A}nalytic {N}umber {T}heory",
	+ year = 1976,
	+ author = "Tom M. Apostol",
	+ publisher = "Springer-Verlag",
	+ doi = "10.1007/978-1-4757-5579-4",
	+ isbn = "978-0-387-90163-3"
	+}
	diff --git a/thys/Gauss_Sums/document/root.tex b/thys/Gauss_Sums/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Gauss_Sums/document/root.tex
	@@ -0,0 +1,45 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage{isabelle,isabellesym}
	+\usepackage{amsfonts, 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{Gauss Sums and the P\'olya--Vinogradov Inequality}
	+\author{Rodrigo Raya and Manuel Eberl}
	+\maketitle
	+
	+\begin{abstract}
	+This article provides a full formalisation of Chapter 8 of Apostol's \emph{Introduction to Analytic Number Theory}~\cite{apostol1976analytic}.
	+Subjects that are covered are:
	+\begin{itemize}
	+\item periodic arithmetic functions and their finite Fourier series
	+\item (generalised) Ramanujan sums
	+\item Gauss sums and separable characters
	+\item induced moduli and primitive characters
	+\item the P\'olya--Vinogradov inequality
	+\end{itemize}
	+\end{abstract}
	+
	+\tableofcontents
	+\newpage
	+\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/Mersenne_Primes/Lucas_Lehmer.thy b/thys/Mersenne_Primes/Lucas_Lehmer.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Mersenne_Primes/Lucas_Lehmer.thy
	@@ -0,0 +1,1254 @@
	+section \<open>The Lucas--Lehmer test\<close>
	+theory Lucas_Lehmer
	+imports
	+ Lucas_Lehmer_Auxiliary
	+ "HOL-Algebra.Ring"
	+ "Probabilistic_Prime_Tests.Jacobi_Symbol"
	+ "Pell.Pell" (* only needed for irrationality of sqrt(3) *)
	+begin
	+
	+subsection \<open>General properties of Mersenne numbers and Mersenne primes\<close>
	+
	+text \<open>
	+ We mostly follow the proofs given on Wikipedia~\cite{wiki:mersenne,wiki:lucas_lehmer} in the
	+ following sections.
	+
	+ We first show some basic and theorems about Mersenne numbers and Mersenne primes in general,
	+ beginning with this: Mersenne primes are the only primes of the form $a^n - 1$ for $n > 1$.
	+\<close>
	+lemma prime_power_minus_oneD:
	+ fixes a n :: nat
	+ assumes "prime (a ^ n - 1)"
	+ shows "n = 1 \<or> a = 2"
	+proof -
	+ from assms have "n > 0"
	+ by (intro Nat.gr0I) auto
	+ have "a \<noteq> 0" "a \<noteq> 1"
	+ by (rule notI, use \<open>n > 0\<close> assms in \<open>simp add: zero_power\<close>)+
	+ hence "a > 1" by auto
	+ have "[a - 1 + 1 = 0 + 1] (mod (a - 1))"
	+ by (rule cong_add) (auto simp: cong_def)
	+ hence "[a = 1] (mod (a - 1))"
	+ using \<open>a > 1\<close> by simp
	+ hence "[a ^ n - 1 = 1 ^ n - 1] (mod (a - 1))"
	+ using \<open>a > 1\<close> by (intro cong_pow cong_diff_nat) auto
	+ hence "(a - 1) dvd (a ^ n - 1)"
	+ by (simp add: cong_0_iff)
	+ have "a - 1 = 1 \<or> a - 1 = a ^ n - 1"
	+ using \<open>prime (a ^ n - 1)\<close> and \<open>(a - 1) dvd _\<close> by (rule prime_natD)
	+ thus ?thesis
	+ proof
	+ assume "a - 1 = 1"
	+ hence "a = 2" by simp
	+ thus ?thesis by simp
	+ next
	+ assume "a - 1 = a ^ n - 1"
	+ hence "a ^ n = a ^ 1"
	+ using \<open>a > 1\<close> by (simp add: Nat.eq_diff_iff)
	+ hence "n = 1"
	+ using \<open>a > 1\<close> by (subst (asm) power_inject_exp) auto
	+ thus ?thesis by simp
	+ qed
	+qed
	+
	+text \<open>
	+ Next, we show that if a prime \<open>q\<close> divides a Mersenne number $2^p - 1$ with an odd prime
	+ exponent \<open>p\<close>, then \<open>q\<close> must be of the form $q = 1 + 2kp$ for some $k > 0$.
	+\<close>
	+lemma prime_dvd_mersenneD:
	+ fixes p q :: nat
	+ assumes "prime p" "p \<noteq> 2" "prime q" "q dvd (2 ^ p - 1)"
	+ shows "[q = 1] (mod (2 * p))"
	+proof -
	+ from assms have "odd p"
	+ using prime_gt_1_nat[of p] by (intro prime_odd_nat) auto
	+ have "q \<noteq> 0" "q \<noteq> 1" "q \<noteq> 2"
	+ using assms by (auto intro!: Nat.gr0I)
	+ hence "q > 2" by simp
	+ with \<open>prime q\<close> have "odd q"
	+ by (simp add: prime_odd_nat)
	+
	+ have "ord q 2 = p"
	+ proof -
	+ from assms have "[2 ^ p - 1 + 1 = 0 + 1] (mod q)"
	+ by (intro cong_add cong_refl) (auto simp: cong_0_iff)
	+ hence "[2 ^ p = 1] (mod q)" by simp
	+ hence "ord q 2 dvd p"
	+ by (subst (asm) ord_divides)
	+ hence "ord q 2 = 1 \<or> ord q 2 = p"
	+ using \<open>prime p\<close> and prime_natD by blast
	+ moreover have "ord q 2 \<noteq> 1"
	+ using ord_works[of 2 q] and \<open>prime q\<close> by (auto simp: cong_altdef_nat)
	+ ultimately show "ord q 2 = p" by blast
	+ qed
	+
	+ have q_dvd_iff: "q dvd (2 ^ x - 1) \<longleftrightarrow> p dvd x" for x :: nat
	+ proof -
	+ have "q dvd (2 ^ x - 1) \<longleftrightarrow> [2 ^ x = 1] (mod q)"
	+ by (auto simp: cong_altdef_nat)
	+ also have "\<dots> \<longleftrightarrow> ord q 2 dvd x"
	+ by (rule ord_divides)
	+ also note \<open>ord q 2 = p\<close>
	+ finally show ?thesis .
	+ qed
	+
	+ from \<open>q > 2\<close> and assms have "\<not>q dvd 2"
	+ using primes_dvd_imp_eq two_is_prime_nat by blast
	+ hence "[2 ^ (q - 1) - 1 = 1 - 1] (mod q)"
	+ using assms by (intro fermat_theorem cong_diff_nat) auto
	+ hence "q dvd (2 ^ (q - 1) - 1)"
	+ by (simp add: cong_0_iff)
	+ hence "p dvd (q - 1)"
	+ by (subst (asm) q_dvd_iff)
	+ hence "[q = 1] (mod p)"
	+ using \<open>q > 2\<close> by (auto simp: cong_altdef_nat prime_gt_1_nat)
	+
	+ moreover have "[q = 1] (mod 2)"
	+ using \<open>odd q\<close> by (auto simp: cong_def odd_iff_mod_2_eq_one)
	+ ultimately show "[q = 1] (mod (2 * p))"
	+ using \<open>odd p\<close> by (intro coprime_cong_mult_nat) auto
	+qed
	+
	+lemma prime_dvd_mersenneD':
	+ fixes p q :: nat
	+ assumes "prime p" "p \<noteq> 2" "prime q" "q dvd (2 ^ p - 1)"
	+ shows "\<exists>k>0. q = 1 + 2 * k * p"
	+proof -
	+ have "q \<noteq> 0" "q \<noteq> 1" "q \<noteq> 2"
	+ using assms by (auto intro!: Nat.gr0I)
	+ hence "q > 2" by simp
	+
	+ have "[q = 1] (mod (2 * p))"
	+ by (rule prime_dvd_mersenneD) fact+
	+ hence "(2 * p) dvd (q - 1)"
	+ using \<open>q > 2\<close> by (auto simp: cong_altdef_nat)
	+ then obtain k where k: "q - 1 = (2 * p) * k"
	+ by blast
	+ hence "q = 1 + 2 * k * p"
	+ using \<open>q > 2\<close> by (simp add: algebra_simps)
	+ moreover have "k > 0"
	+ using \<open>q > 2\<close> and k by (intro Nat.gr0I) auto
	+ ultimately show ?thesis by blast
	+qed
	+
	+
	+text \<open>
	+ A Mersenne number is any number of the form $2^p - 1$ for a natural number $p$. To make things
	+ a bit more pleasant, we additionally exclude $2^2 - 1$, i.e. we require $p > 2$. It can
	+ be shown that $p$ is then always an odd prime.
	+\<close>
	+locale mersenne_prime =
	+ fixes p M :: nat
	+ defines "M \<equiv> 2 ^ p - 1"
	+ assumes p_gt_2: "p > 2" and prime: "prime M"
	+begin
	+
	+lemma M_gt_6: "M > 6"
	+proof -
	+ from p_gt_2 have "2 ^ p \<ge> (2 ^ 3 :: nat)"
	+ by (intro power_increasing) auto
	+ thus ?thesis by (simp add: M_def)
	+qed
	+
	+lemma M_odd: "odd M"
	+ using p_gt_2 by (auto simp: M_def)
	+
	+theorem p_prime: "prime p"
	+proof (rule ccontr)
	+ assume "\<not>prime p"
	+ then obtain a b where ab: "p = a * b" "a > 1" "b > 1"
	+ using p_gt_2 not_prime_imp_ex_prod_nat[of p] by auto
	+
	+ have geometric_sum_aux: "(x - (1 :: int)) * (\<Sum>k<a. x ^ k) = x ^ a - 1" for x
	+ by (induction a) (auto simp: algebra_simps)
	+ have "(2 ^ b - 1 :: int) * (\<Sum>k<a. (2 ^ b) ^ k) = (2 ^ b) ^ a - 1"
	+ by (rule geometric_sum_aux)
	+ hence "2 ^ (ab) - 1 = (2 ^ b - 1 :: int) (\<Sum>k<a. 2 ^ (k*b))"
	+ by (simp flip: power_mult add: algebra_simps)
	+ hence "(2 ^ b - 1) dvd (2 ^ (a*b) - 1 :: int)"
	+ by simp
	+ hence "int (2 ^ b - 1) dvd int (2 ^ (a * b) - 1)"
	+ by (subst of_nat_diff) (auto simp: of_nat_diff)
	+ hence "(2 ^ b - 1) dvd (2 ^ (a * b) - 1 :: nat)"
	+ by (subst (asm) int_dvd_int_iff)
	+ with prime have "2 ^ b - 1 = (1 :: nat) \<or> 2 ^ b - 1 = (2 ^ p - 1 :: nat)"
	+ unfolding ab M_def by (intro prime_natD) auto
	+ moreover have "2 ^ b > (2 ^ 1 :: nat)"
	+ using ab by (intro power_strict_increasing) auto
	+ moreover have "2 ^ b < (2 ^ p :: nat)"
	+ using ab by (intro power_strict_increasing) auto
	+ hence "2 ^ b - 1 < (2 ^ p - 1 :: nat)"
	+ by (subst less_diff_iff) auto
	+ ultimately show False by auto
	+qed
	+
	+lemma p_odd: "odd p"
	+ using p_prime p_gt_2 prime_odd_nat by auto
	+
	+text \<open>
	+ We now first show a few more properties of Mersenne primes regarding congruences
	+ and the Legendre symbol.
	+\<close>
	+lemma M_cong_7_mod_12: "[M = 7] (mod 12)"
	+proof -
	+ have "[M = 8 - 1] (mod 12)"
	+ using p_gt_2 p_odd unfolding M_def by (intro cong_diff_nat two_power_odd_mod_12) auto
	+ thus "[M = 7] (mod 12)" by simp
	+qed
	+
	+lemma Legendre_3_M: "Legendre 3 M = -1"
	+ using prime M_cong_7_mod_12 by (subst Legendre_3_left) (auto simp: cong_def)
	+
	+lemma M_cong_7_mod_8: "[M = 7] (mod 8)"
	+proof -
	+ have "2 ^ 3 dvd (2 ^ p :: int)"
	+ using p_gt_2 by (intro le_imp_power_dvd) auto
	+ hence "[2 ^ p - 1 = 0 - 1] (mod (8 :: int))"
	+ by (intro cong_diff) (auto simp: cong_def)
	+ also have "2 ^ p - 1 = int M"
	+ by (simp add: M_def of_nat_diff)
	+ finally have "int M mod int 8 = 7"
	+ by (simp add: cong_def)
	+ thus "[M = 7] (mod 8)"
	+ by (subst (asm) zmod_int [symmetric]) (auto simp: cong_def)
	+qed
	+
	+lemma Legendre_2_M: "Legendre 2 M = 1"
	+ using prime M_gt_6 M_cong_7_mod_8
	+ by (subst supplement2_Legendre') (auto simp: cong_def nat_mod_as_int)
	+
	+lemma M_not_dvd_24: "\<not>M dvd 24"
	+proof
	+ assume "M dvd 24"
	+ hence "M dvd 2 * 2 * 2 * 3"
	+ by simp
	+ also have "?this \<longleftrightarrow> M dvd 2 \<or> M dvd 3"
	+ using prime by (simp only: prime_dvd_mult_iff) auto
	+ finally show False using M_gt_6 by (auto dest: dvd_imp_le)
	+qed
	+
	+end
	+
	+
	+subsection \<open>The Lucas--Lehmer sequence\<close>
	+
	+text \<open>
	+ We now define the Lucas--Lehmer sequence $a_{n+1} = a_n ^ 2 - 2$. The starting value
	+ we will always use is $a_0 = 4$.
	+\<close>
	+primrec gen_lucas_lehmer_sequence :: "int \<Rightarrow> nat \<Rightarrow> int" where
	+ "gen_lucas_lehmer_sequence a 0 = a"
	+\| "gen_lucas_lehmer_sequence a (Suc n) = gen_lucas_lehmer_sequence a n ^ 2 - 2"
	+
	+lemma gen_lucas_lehmer_sequence_Suc':
	+ "gen_lucas_lehmer_sequence a (Suc n) = gen_lucas_lehmer_sequence (a ^ 2 - 2) n"
	+ by (induction n arbitrary: a) auto
	+
	+lemmas gen_lucas_lehmer_code [code] =
	+ gen_lucas_lehmer_sequence.simps(1) gen_lucas_lehmer_sequence_Suc'
	+
	+text \<open>
	+ For $a_0 = 4$, the recurrence has the closed form $a_{4,n} = \omega^{2^n} + \bar\omega^{2^n}$
	+ with $\omega = 2 + \sqrt{3}$ and $\bar\omega = 2 - \sqrt{3}$.
	+\<close>
	+lemma gen_lucas_lehmer_sequence_4_closed_form1:
	+ "real_of_int (gen_lucas_lehmer_sequence 4 n) = (2 + sqrt 3) ^ (2 ^ n) + (2 - sqrt 3) ^ (2 ^ n)"
	+ by (induction n)
	+ (auto simp: algebra_simps power2_eq_square power_mult simp flip: power_mult_distrib)
	+
	+lemma gen_lucas_lehmer_sequence_4_closed_form2:
	+ "gen_lucas_lehmer_sequence 4 n = round ((2 + sqrt 3) ^ (2 ^ n))"
	+proof (rule sym, rule round_unique')
	+ have "5 / 3 < sqrt (3 :: real)"
	+ by (rule real_less_rsqrt) (auto simp: power2_eq_square)
	+ hence "(2 - sqrt 3) ^ (2 ^ n) < (1 / 3) ^ (2 ^ n)"
	+ by (intro power_strict_mono) (auto simp: real_le_lsqrt)
	+ also have "\<dots> \<le> (1 / 3) ^ 1"
	+ by (intro power_decreasing) auto
	+ finally have "(2 - sqrt 3) ^ (2 ^ n) < 1 / 2" by simp
	+ moreover have "(2 - sqrt 3) ^ (2 ^ n) \<ge> 0"
	+ by (intro zero_le_power) (auto simp: real_le_lsqrt)
	+ ultimately show "\<bar>(2 + sqrt 3) ^ 2 ^ n - real_of_int (gen_lucas_lehmer_sequence 4 n)\<bar> < 1 / 2"
	+ unfolding gen_lucas_lehmer_sequence_4_closed_form1 by linarith
	+qed
	+
	+lemma gen_lucas_lehmer_sequence_4_closed_form3:
	+ "gen_lucas_lehmer_sequence 4 n = \<lceil>(2 + sqrt 3) ^ (2 ^ n)\<rceil>"
	+proof (rule sym, rule ceiling_unique)
	+ show "real_of_int (gen_lucas_lehmer_sequence 4 n) \<ge> (2 + sqrt 3) ^ 2 ^ n"
	+ unfolding gen_lucas_lehmer_sequence_4_closed_form1 by (auto intro!: zero_le_power real_le_lsqrt)
	+next
	+ have "5 / 3 < sqrt (3 :: real)"
	+ by (rule real_less_rsqrt) (auto simp: power2_eq_square)
	+ hence "(2 - sqrt 3) ^ (2 ^ n) < (1 / 3) ^ (2 ^ n)"
	+ by (intro power_strict_mono) (auto simp: real_le_lsqrt)
	+ also have "\<dots> \<le> (1 / 3) ^ 1"
	+ by (intro power_decreasing) auto
	+ finally have "(2 - sqrt 3) ^ (2 ^ n) < 1 / 2" by simp
	+ moreover have "(2 - sqrt 3) ^ (2 ^ n) \<ge> 0"
	+ by (intro zero_le_power) (auto simp: real_le_lsqrt)
	+ ultimately show "real_of_int (gen_lucas_lehmer_sequence 4 n) - 1 < (2 + sqrt 3) ^ 2 ^ n"
	+ unfolding gen_lucas_lehmer_sequence_4_closed_form1 by linarith
	+qed
	+
	+
	+subsection \<open>The ring $\mathbb{Z}[\sqrt{3}]$\<close>
	+
	+text \<open>
	+ To relate this sequence to Mersenne primes, we now first need to define the ring
	+ $\mathbb{Z}[\sqrt{3}]$, which is a subring of $\mathbb{R}$. This ring can be seen as the
	+ lattice on $\mathbb{R}$ that is freely generated by $1$ and $\sqrt{3}$.
	+
	+ It is, however, more convenient to explicitly describe it as a ring structure over the
	+ set $\mathbb{Z}\times\mathbb{Z}$ with a corresponding injective homomorphism
	+ $\mathbb{Z}\times\mathbb{Z} \to \mathbb{R}$.
	+\<close>
	+
	+definition lucas_lehmer_add' :: "int \<times> int \<Rightarrow> int \<times> int \<Rightarrow> int \<times> int" where
	+ "lucas_lehmer_add' = (\<lambda>(a,b) (c,d). (a + c, b + d))"
	+
	+definition lucas_lehmer_mult' :: "int \<times> int \<Rightarrow> int \<times> int \<Rightarrow> int \<times> int" where
	+ "lucas_lehmer_mult' = (\<lambda>(a,b) (c,d). (a * c + 3 * b * d, a * d + b * c))"
	+
	+definition lucas_lehmer_ring :: "(int \<times> int) ring" where
	+ "lucas_lehmer_ring =
	+ \<lparr>carrier = UNIV,
	+ monoid.mult = lucas_lehmer_mult',
	+ one = (1, 0),
	+ ring.zero = (0, 0),
	+ add = lucas_lehmer_add'\<rparr>"
	+
	+lemma carrier_lucas_lehmer_ring [simp]: "carrier lucas_lehmer_ring = UNIV"
	+ by (simp add: lucas_lehmer_ring_def)
	+
	+lemma cring_lucas_lehmer_ring [intro]: "cring (lucas_lehmer_ring)"
	+proof
	+ have "\<exists>aa ba. lucas_lehmer_add' (aa, ba) (a, b) = (0, 0) \<and>
	+ lucas_lehmer_add' (a, b) (aa, ba) = (0, 0)" for a b
	+ by (rule exI[of _ "-a"], rule exI[of _ "-b"]) (auto simp: lucas_lehmer_add'_def)
	+ thus "carrier (add_monoid lucas_lehmer_ring) \<subseteq> Units (add_monoid lucas_lehmer_ring)"
	+ by (auto simp: Units_def lucas_lehmer_ring_def)
	+qed (auto simp: lucas_lehmer_ring_def lucas_lehmer_add'_def lucas_lehmer_mult'_def algebra_simps)
	+
	+
	+subsection \<open>The ring $(\mathbb{Z}/m\mathbb{Z})[\sqrt{3}]$\<close>
	+
	+text \<open>
	+ We shall also need the ring $(\mathbb{Z}/m\mathbb{Z})[\sqrt{3}]$, which is obtained from
	+ $\mathbb{Z}[\sqrt{3}]$ by reducing each component separately modulo $m$. This essentially
	+ identifies any two points that are a multiple of $m$ apart and then all those that are
	+ a multiple of $m\sqrt{3}$ apart.
	+\<close>
	+definition lucas_lehmer_mult :: "nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat" where
	+ "lucas_lehmer_mult m = (\<lambda>(a,b) (c,d). ((a * c + 3 * b * d) mod m, (a * d + b * c) mod m))"
	+
	+definition lucas_lehmer_add :: "nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat" where
	+ "lucas_lehmer_add m = (\<lambda>(a,b) (c,d). ((a + c) mod m, (b + d) mod m))"
	+
	+definition lucas_lehmer_ring_mod :: "nat \<Rightarrow> (nat \<times> nat) ring" where
	+ "lucas_lehmer_ring_mod m =
	+ \<lparr>carrier = {..<m} \<times> {..<m},
	+ monoid.mult = lucas_lehmer_mult m,
	+ one = (1, 0),
	+ ring.zero = (0, 0),
	+ add = lucas_lehmer_add m\<rparr>"
	+
	+lemma lucas_lehmer_add_in_carrier: "m > 0 \<Longrightarrow> lucas_lehmer_add m x y \<in> {..<m} \<times> {..<m}"
	+ by (auto simp: lucas_lehmer_add_def split: prod.splits)
	+
	+lemma lucas_lehmer_mult_in_carrier: "m > 0 \<Longrightarrow> lucas_lehmer_mult m x y \<in> {..<m} \<times> {..<m}"
	+ by (auto simp: lucas_lehmer_mult_def split: prod.splits)
	+
	+lemma lucas_lehmer_add_cong:
	+ "[fst (lucas_lehmer_add m x y) = fst x + fst y] (mod m)"
	+ "[snd (lucas_lehmer_add m x y) = snd x + snd y] (mod m)"
	+ by (simp_all add: lucas_lehmer_add_def cong_def case_prod_unfold)
	+
	+lemma lucas_lehmer_mult_cong:
	+ "[fst (lucas_lehmer_mult m x y) = fst x * fst y + 3 * snd x * snd y] (mod m)"
	+ "[snd (lucas_lehmer_mult m x y) = fst x * snd y + snd x * fst y] (mod m)"
	+ by (simp_all add: lucas_lehmer_mult_def cong_def case_prod_unfold)
	+
	+lemma lucas_lehmer_add_neutral [simp]:
	+ assumes "fst x < m" "snd x < m"
	+ shows "lucas_lehmer_add m (0, 0) x = x"
	+ and "lucas_lehmer_add m x (0, 0) = x"
	+ using assms by (auto simp: lucas_lehmer_add_def case_prod_unfold)
	+
	+lemma lucas_lehmer_mult_neutral [simp]:
	+ assumes "fst x < m" "snd x < m"
	+ shows "lucas_lehmer_mult m (Suc 0, 0) x = x"
	+ and "lucas_lehmer_mult m x (Suc 0, 0) = x"
	+ using assms by (auto simp: lucas_lehmer_mult_def case_prod_unfold)
	+
	+lemma lucas_lehmer_add_commute: "lucas_lehmer_add m x y = lucas_lehmer_add m y x"
	+ by (simp add: lucas_lehmer_add_def algebra_simps case_prod_unfold)
	+
	+lemma lucas_lehmer_mult_commute: "lucas_lehmer_mult m x y = lucas_lehmer_mult m y x"
	+ by (simp add: lucas_lehmer_mult_def algebra_simps case_prod_unfold)
	+
	+lemma lucas_lehmer_add_assoc:
	+ assumes m: "m > 0"
	+ shows "lucas_lehmer_add m x (lucas_lehmer_add m y z) =
	+ lucas_lehmer_add m (lucas_lehmer_add m x y) z"
	+proof (rule prod_eqI)
	+ let ?add = "lucas_lehmer_add m"
	+ have "[fst (?add x (?add y z)) = fst x + (fst y + fst z)] (mod m)"
	+ by (rule lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+
	+ also have "fst x + (fst y + fst z) = (fst x + fst y) + fst z"
	+ by (simp add: add_ac)
	+ also have "[\<dots> = fst (?add (?add x y) z)] (mod m)"
	+ by (rule cong_sym, (rule lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
	+ finally show "fst (?add x (?add y z)) = fst (?add (?add x y) z)"
	+ by (rule cong_less_modulus_unique_nat)
	+ (use m in \<open>auto simp: lucas_lehmer_add_def case_prod_unfold\<close>)
	+
	+ have "[snd (?add x (?add y z)) = snd x + (snd y + snd z)] (mod m)"
	+ by (rule lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+
	+ also have "snd x + (snd y + snd z) = (snd x + snd y) + snd z"
	+ by (simp add: add_ac)
	+ also have "[\<dots> = snd (?add (?add x y) z)] (mod m)"
	+ by (rule cong_sym, (rule lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
	+ finally show "snd (?add x (?add y z)) = snd (?add (?add x y) z)"
	+ by (rule cong_less_modulus_unique_nat)
	+ (use m in \<open>auto simp: lucas_lehmer_add_def case_prod_unfold\<close>)
	+qed
	+
	+lemma lucas_lehmer_mult_assoc:
	+ assumes m: "m > 0"
	+ shows "lucas_lehmer_mult m x (lucas_lehmer_mult m y z) =
	+ lucas_lehmer_mult m (lucas_lehmer_mult m x y) z"
	+proof (rule prod_eqI)
	+ let ?mul = "lucas_lehmer_mult m"
	+ have "[fst (?mul x (?mul y z)) = fst x * (fst y * fst z + 3 * snd y * snd z) +
	+ 3 * snd x * (fst y * snd z + snd y * fst z)] (mod m)"
	+ by (rule lucas_lehmer_mult_cong[THEN cong_trans] cong_add cong_mult cong_refl)+
	+ also have "fst x * (fst y * fst z + 3 * snd y * snd z) +
	+ 3 * snd x * (fst y * snd z + snd y * fst z) =
	+ (fst x * fst y + 3 * snd x * snd y) * fst z +
	+ 3 * (fst x * snd y + snd x * fst y) * snd z"
	+ by (simp add: algebra_simps)
	+ also have "[\<dots> = fst (?mul (?mul x y) z)] (mod m)"
	+ by (rule cong_sym, (rule lucas_lehmer_mult_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
	+ finally show "fst (?mul x (?mul y z)) = fst (?mul (?mul x y) z)"
	+ by (rule cong_less_modulus_unique_nat)
	+ (use m in \<open>auto simp: lucas_lehmer_mult_def case_prod_unfold\<close>)
	+
	+ have "[snd (?mul x (?mul y z)) = fst x * (fst y * snd z + snd y * fst z) +
	+ snd x * (fst y * fst z + 3 * snd y * snd z)] (mod m)"
	+ by (rule lucas_lehmer_mult_cong[THEN cong_trans] cong_add cong_mult cong_refl)+
	+ also have "fst x * (fst y * snd z + snd y * fst z) + snd x * (fst y * fst z + 3 * snd y * snd z) =
	+ (fst x * fst y + 3 * snd x * snd y) * snd z + (fst x * snd y + snd x * fst y) * fst z"
	+ by (simp add: algebra_simps)
	+ also have "[\<dots> = snd (?mul (?mul x y) z)] (mod m)"
	+ by (rule cong_sym, (rule lucas_lehmer_mult_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
	+ finally show "snd (?mul x (?mul y z)) = snd (?mul (?mul x y) z)"
	+ by (rule cong_less_modulus_unique_nat)
	+ (use m in \<open>auto simp: lucas_lehmer_mult_def case_prod_unfold\<close>)
	+qed
	+
	+lemma lucas_lehmer_distrib_right:
	+ assumes m: "m > 1"
	+ shows "lucas_lehmer_mult m (lucas_lehmer_add m x y) z =
	+ lucas_lehmer_add m (lucas_lehmer_mult m x z) (lucas_lehmer_mult m y z)"
	+proof (rule prod_eqI)
	+ let ?mul = "lucas_lehmer_mult m" and ?add = "lucas_lehmer_add m"
	+ have "[fst (?mul (?add x y) z) = (fst x + fst y) * fst z + 3 * (snd x + snd y) * snd z] (mod m)"
	+ by (rule lucas_lehmer_mult_cong[THEN cong_trans] lucas_lehmer_add_cong[THEN cong_trans]
	+ cong_add cong_mult cong_refl)+
	+ also have "(fst x + fst y) * fst z + 3 * (snd x + snd y) * snd z =
	+ (fst x * fst z + 3 * snd x * snd z) + (fst y * fst z + 3 * snd y * snd z)"
	+ by (simp add: algebra_simps)
	+ also have "[\<dots> = fst (?add (?mul x z) (?mul y z))] (mod m)"
	+ by (rule cong_sym, (rule lucas_lehmer_mult_cong[THEN cong_trans]
	+ lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
	+ finally show "fst (?mul (?add x y) z) = fst (?add (?mul x z) (?mul y z))"
	+ by (rule cong_less_modulus_unique_nat)
	+ (use m in \<open>auto simp: lucas_lehmer_add_def lucas_lehmer_mult_def case_prod_unfold\<close>)
	+
	+ have "[snd (?mul (?add x y) z) = (fst x + fst y) * snd z + (snd x + snd y) * fst z] (mod m)"
	+ by (rule lucas_lehmer_mult_cong[THEN cong_trans] lucas_lehmer_add_cong[THEN cong_trans]
	+ cong_add cong_mult cong_refl)+
	+ also have "(fst x + fst y) * snd z + (snd x + snd y) * fst z =
	+ (fst x * snd z + snd x * fst z) + (fst y * snd z + snd y * fst z)"
	+ by (simp add: algebra_simps)
	+ also have "[\<dots> = snd (?add (?mul x z) (?mul y z))] (mod m)"
	+ by (rule cong_sym, (rule lucas_lehmer_mult_cong[THEN cong_trans]
	+ lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
	+ finally show "snd (?mul (?add x y) z) = snd (?add (?mul x z) (?mul y z))"
	+ by (rule cong_less_modulus_unique_nat)
	+ (use m in \<open>auto simp: lucas_lehmer_add_def lucas_lehmer_mult_def case_prod_unfold\<close>)
	+qed
	+
	+lemma lucas_lehmer_distrib_left:
	+ assumes "m > 1"
	+ shows "lucas_lehmer_mult m z (lucas_lehmer_add m x y) =
	+ lucas_lehmer_add m (lucas_lehmer_mult m z x) (lucas_lehmer_mult m z y)"
	+ using lucas_lehmer_distrib_right[of m x y z] assms
	+ by (simp add: lucas_lehmer_mult_commute)
	+
	+lemma cring_lucas_lehmer_ring_mod [intro]:
	+ assumes "m > 1"
	+ shows "cring (lucas_lehmer_ring_mod m)"
	+proof unfold_locales
	+ let ?neg = "\<lambda>x. if x = 0 then 0 else m - x"
	+ have "\<exists>x\<in>carrier (lucas_lehmer_ring_mod m).
	+ x \<oplus>\<^bsub>lucas_lehmer_ring_mod m\<^esub> (a, b) = \<zero>\<^bsub>lucas_lehmer_ring_mod m\<^esub> \<and>
	+ (a, b) \<oplus>\<^bsub>lucas_lehmer_ring_mod m\<^esub> x = \<zero>\<^bsub>lucas_lehmer_ring_mod m\<^esub>"
	+ if "(a, b) \<in> carrier (lucas_lehmer_ring_mod m)" for a b
	+ using that assms
	+ by (intro bexI[of _ "(?neg a, ?neg b)"])
	+ (auto simp: lucas_lehmer_ring_mod_def lucas_lehmer_add_def)
	+ thus "carrier (add_monoid (lucas_lehmer_ring_mod m)) \<subseteq> Units (add_monoid (lucas_lehmer_ring_mod m))"
	+ by (auto simp: Units_def)
	+qed (insert assms,
	+ auto simp: lucas_lehmer_ring_mod_def algebra_simps lucas_lehmer_mult_assoc
	+ lucas_lehmer_add_assoc lucas_lehmer_distrib_right lucas_lehmer_distrib_left
	+ intro: lucas_lehmer_mult_in_carrier lucas_lehmer_add_in_carrier
	+ lucas_lehmer_add_commute lucas_lehmer_mult_commute)
	+
	+text \<open>
	+ Since $0$ is clearly not a unit in the ring and its carrier has size $m ^ 2$, the
	+ number of units is strictly less than $m ^ 2$.
	+\<close>
	+lemma card_lucas_lehmer_Units:
	+ assumes "m > 1"
	+ shows "card (Units (lucas_lehmer_ring_mod m)) < m ^ 2"
	+proof -
	+ interpret cring "lucas_lehmer_ring_mod m"
	+ using assms by auto
	+ have "m ^ 2 > 0"
	+ using assms by auto
	+ from assms have "card (Units (lucas_lehmer_ring_mod m)) \<le> card ({..<m} \<times> {..<m} - {(0, 0)})"
	+ by (intro card_mono) (auto simp: Units_def lucas_lehmer_ring_mod_def lucas_lehmer_mult_def)
	+ also have "\<dots> = m ^ 2 - 1"
	+ using assms by (subst card_Diff_subset) (auto simp: power2_eq_square)
	+ finally show ?thesis using \<open>m ^ 2 > 0\<close> by linarith
	+qed
	+
	+text \<open>
	+ Consider now the case of a prime modulus $m$: Since $\mathbb{Z}/m\mathbb{Z} = \text{GF}(m)$
	+ is a field, any element of $\mathbb{Z}/m\mathbb{Z}$ is a unit in
	+ $(\mathbb{Z}/m\mathbb{Z})[\sqrt{3}]$.
	+\<close>
	+lemma int_in_Units_lucas_lehmer_ring_mod:
	+ assumes "prime p"
	+ assumes "x > 0" "x < p"
	+ shows "(x, 0) \<in> Units (lucas_lehmer_ring_mod p)"
	+proof -
	+ define R where "R = lucas_lehmer_ring_mod p"
	+ have "[x * (x ^ (p - 2) mod p) = x * x ^ (p - 2)] (mod p)"
	+ by (intro cong_mult) (auto simp: cong_def)
	+ also have "x * x ^ (p - 2) = x ^ (Suc (p - 2))"
	+ by (simp add: mult_ac)
	+ also have "Suc (p - 2) = p - 1"
	+ using prime_gt_1_nat[of p] assms by simp
	+ also have "[x ^ (p - 1) = 1] (mod p)"
	+ using assms by (intro fermat_theorem) (auto dest: dvd_imp_le)
	+ finally have "(x, 0) \<otimes>\<^bsub>R\<^esub> (x ^ (p - 2) mod p, 0) = \<one>\<^bsub>R\<^esub>"
	+ "(x ^ (p - 2) mod p, 0) \<otimes>\<^bsub>R\<^esub> (x, 0) = \<one>\<^bsub>R\<^esub>"
	+ "(x ^ (p - 2) mod p, 0) \<in> carrier R"
	+ using prime_gt_1_nat[of p] assms
	+ by (auto simp: lucas_lehmer_mult_def cong_def lucas_lehmer_ring_mod_def mult_ac R_def)
	+ moreover from assms have "(x, 0) \<in> carrier R"
	+ by (auto simp: R_def lucas_lehmer_ring_mod_def)
	+ ultimately show ?thesis using assms
	+ by (auto simp: Units_def R_def)
	+qed
	+
	+
	+subsection \<open>$\mathbb{Z}[\sqrt{3}]$ as a subring of $\mathbb{R}$\<close>
	+
	+text \<open>
	+ We now define the homomorphism from $\mathbb{Z}[\sqrt{3}]$ into the reals:
	+\<close>
	+definition lucas_lehmer_to_real :: "int \<times> int \<Rightarrow> real" where
	+ "lucas_lehmer_to_real = (\<lambda>(a,b). real_of_int a + real_of_int b * sqrt 3)"
	+
	+context
	+begin
	+
	+interpretation cring lucas_lehmer_ring ..
	+
	+lemma minus_lucas_lehmer_ring: "\<ominus>\<^bsub>lucas_lehmer_ring\<^esub> x = (case x of (a, b) \<Rightarrow> (-a, -b))"
	+ by (rule sym, rule sum_zero_eq_neg)
	+ (auto simp: case_prod_unfold lucas_lehmer_ring_def lucas_lehmer_add'_def)
	+
	+lemma lucas_lehmer_to_real_simps1:
	+ "lucas_lehmer_to_real (a, b) = of_int a + of_int b * sqrt 3"
	+ "lucas_lehmer_to_real (x \<oplus>\<^bsub>lucas_lehmer_ring\<^esub> y) =
	+ lucas_lehmer_to_real x + lucas_lehmer_to_real y"
	+ "lucas_lehmer_to_real (x \<otimes>\<^bsub>lucas_lehmer_ring\<^esub> y) =
	+ lucas_lehmer_to_real x * lucas_lehmer_to_real y"
	+ "lucas_lehmer_to_real (\<ominus>\<^bsub>lucas_lehmer_ring\<^esub> x) = -lucas_lehmer_to_real x"
	+ "lucas_lehmer_to_real (\<zero>\<^bsub>lucas_lehmer_ring\<^esub>) = 0"
	+ "lucas_lehmer_to_real (\<one>\<^bsub>lucas_lehmer_ring\<^esub>) = 1"
	+ using minus_lucas_lehmer_ring
	+ by (simp_all add: lucas_lehmer_to_real_def lucas_lehmer_add'_def lucas_lehmer_mult'_def
	+ case_prod_unfold algebra_simps lucas_lehmer_ring_def)
	+
	+lemma lucas_lehmer_to_add_pow_nat:
	+ "lucas_lehmer_to_real ([n] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x) = of_nat n * lucas_lehmer_to_real x"
	+ by (induction n) (auto simp: lucas_lehmer_to_real_simps1 algebra_simps)
	+
	+lemma lucas_lehmer_to_add_pow_int:
	+ "lucas_lehmer_to_real ([n] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x) = of_int n * lucas_lehmer_to_real x"
	+proof (cases "n \<ge> 0")
	+ case True
	+ hence "lucas_lehmer_to_real ([n] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x) =
	+ lucas_lehmer_to_real ([int (nat n)] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x)"
	+ by simp
	+ also have "\<dots> = lucas_lehmer_to_real ([nat n] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x)"
	+ by (simp add: add_pow_int_ge)
	+ also have "\<dots> = of_int n * lucas_lehmer_to_real x" using True
	+ by (simp add: lucas_lehmer_to_add_pow_nat algebra_simps)
	+ finally show ?thesis .
	+next
	+ case False
	+ hence "lucas_lehmer_to_real ([n] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x) =
	+ lucas_lehmer_to_real (add_pow lucas_lehmer_ring (-int (nat (-n))) x)"
	+ by simp
	+ also have "add_pow lucas_lehmer_ring (-int (nat (-n))) x =
	+ \<ominus>\<^bsub>lucas_lehmer_ring\<^esub> (add_pow lucas_lehmer_ring (nat (-n)) x)"
	+ using False by (subst add.int_pow_neg_int) (auto simp: lucas_lehmer_ring_def)
	+ also have "lucas_lehmer_to_real \<dots> = of_int n * lucas_lehmer_to_real x" using False
	+ by (simp add: lucas_lehmer_to_add_pow_nat lucas_lehmer_to_real_simps1 algebra_simps)
	+ finally show ?thesis .
	+qed
	+
	+lemma lucas_lehmer_to_real_power:
	+ "lucas_lehmer_to_real (x [^]\<^bsub>lucas_lehmer_ring\<^esub> (n :: nat)) = lucas_lehmer_to_real x ^ n"
	+ by (induction n) (auto simp: lucas_lehmer_to_real_simps1)
	+
	+lemmas lucas_lehmer_to_real_simps =
	+ lucas_lehmer_to_real_simps1 lucas_lehmer_to_real_power
	+ lucas_lehmer_to_add_pow_nat lucas_lehmer_to_add_pow_int
	+
	+end
	+
	+lemma lucas_lehmer_to_real_inj: "inj lucas_lehmer_to_real"
	+proof (rule injI, clarify)
	+ fix a b c d :: int
	+ assume eq: "lucas_lehmer_to_real (a, b) = lucas_lehmer_to_real (c, d)"
	+ have "b = d"
	+ proof (rule ccontr)
	+ assume "b \<noteq> d"
	+ hence "sqrt 3 = (c - a) / (b - d)"
	+ using eq by (simp add: lucas_lehmer_to_real_def field_simps)
	+ also have "\<dots> \<in> \<rat>" by auto
	+ finally have "sqrt 3 \<in> \<rat>" .
	+ moreover have "sqrt 3 \<notin> \<rat>"
	+ using is_nth_power_prime_power_nat_iff[of 3 2 1] irrat_sqrt_nonsquare[of 3] by auto
	+ ultimately show False by contradiction
	+ qed
	+ moreover from this and eq have "a = c"
	+ by (auto simp: lucas_lehmer_to_real_def)
	+ ultimately show "a = c \<and> b = d" by blast
	+qed
	+
	+
	+subsection \<open>The canonical homomorphism $\mathbb{Z}[\sqrt 3] \to (\mathbb{Z}/m\mathbb{Z})[\sqrt 3]$\<close>
	+
	+text \<open>
	+ Next, we show that reduction modulo $m$ is indeed a homomorphism.
	+\<close>
	+definition lucas_lehmer_hom :: "nat \<Rightarrow> (int \<times> int) \<Rightarrow> (nat \<times> nat)" where
	+ "lucas_lehmer_hom m = (\<lambda>(x,y). (nat (x mod m), nat (y mod m)))"
	+
	+lemma lucas_lehmer_hom_cong:
	+ "[fst x = fst y] (mod int m) \<Longrightarrow> [snd x = snd y] (mod int m) \<Longrightarrow>
	+ lucas_lehmer_hom m x = lucas_lehmer_hom m y"
	+ by (auto simp: lucas_lehmer_hom_def cong_def case_prod_unfold)
	+
	+lemma lucas_lehmer_hom_cong':
	+ "[a = b] (mod int m) \<Longrightarrow> [c = d] (mod int m) \<Longrightarrow>
	+ lucas_lehmer_hom m (a, c) = lucas_lehmer_hom m (b, d)"
	+ by (auto simp: lucas_lehmer_hom_def cong_def)
	+
	+context
	+ fixes m :: nat
	+ assumes m: "m > 1"
	+begin
	+
	+lemma lucas_lehmer_hom_in_carrier: "lucas_lehmer_hom m x \<in> {..<m} \<times> {..<m}"
	+ using m nat_less_iff by (auto simp: lucas_lehmer_hom_def case_prod_unfold)
	+
	+lemma lucas_lehmer_hom_add:
	+ "lucas_lehmer_hom m (lucas_lehmer_add' x y) =
	+ lucas_lehmer_add m (lucas_lehmer_hom m x) (lucas_lehmer_hom m y)"
	+proof (rule prod_eqI)
	+ let ?add1 = "lucas_lehmer_add'" and ?add2 = "lucas_lehmer_add m"
	+ let ?\<phi> = "lucas_lehmer_hom m"
	+ have "fst (?\<phi> (?add1 x y)) = nat ((fst x + fst y) mod int m)"
	+ by (simp add: lucas_lehmer_hom_def lucas_lehmer_add'_def case_prod_unfold)
	+ also have "(fst x + fst y) mod int m = ((fst x mod m) + (fst y mod m)) mod int m"
	+ by (simp add: mod_add_eq)
	+ also have "nat \<dots> = (nat (fst x mod int m) + nat (fst y mod int m)) mod m"
	+ using m nat_add_distrib nat_mod_distrib by auto
	+ also have "\<dots> = fst (?add2 (?\<phi> x) (?\<phi> y))"
	+ by (auto simp: lucas_lehmer_hom_def lucas_lehmer_add_def case_prod_unfold)
	+ finally show "fst (?\<phi> (?add1 x y)) = fst (?add2 (?\<phi> x) (?\<phi> y))" .
	+
	+ have "snd (?\<phi> (?add1 x y)) = nat ((snd x + snd y) mod int m)"
	+ by (simp add: lucas_lehmer_hom_def lucas_lehmer_add'_def case_prod_unfold)
	+ also have "(snd x + snd y) mod int m = ((snd x mod m) + (snd y mod m)) mod int m"
	+ by (simp add: mod_add_eq)
	+ also have "nat \<dots> = (nat (snd x mod int m) + nat (snd y mod int m)) mod m"
	+ using m nat_add_distrib nat_mod_distrib by auto
	+ also have "\<dots> = snd (?add2 (?\<phi> x) (?\<phi> y))"
	+ by (auto simp: lucas_lehmer_hom_def lucas_lehmer_add_def case_prod_unfold)
	+ finally show "snd (?\<phi> (?add1 x y)) = snd (?add2 (?\<phi> x) (?\<phi> y))" .
	+qed
	+
	+lemma lucas_lehmer_hom_mult:
	+ "lucas_lehmer_hom m (lucas_lehmer_mult' x y) =
	+ lucas_lehmer_mult m (lucas_lehmer_hom m x) (lucas_lehmer_hom m y)"
	+proof (rule prod_eqI)
	+ let ?mul1 = "lucas_lehmer_mult'" and ?mul2 = "lucas_lehmer_mult m"
	+ let ?\<phi> = "lucas_lehmer_hom m"
	+ have "fst (?\<phi> (?mul1 x y)) = nat ((fst x * fst y + 3 * snd x * snd y) mod int m)"
	+ by (simp add: lucas_lehmer_hom_def lucas_lehmer_mult'_def case_prod_unfold)
	+ also have "(fst x * fst y + 3 * snd x * snd y) mod int m =
	+ ((fst x mod int m) * (fst y mod int m) +
	+ 3 * (snd x mod int m) * (snd y mod int m)) mod m"
	+ by (intro congD cong_mult cong_add cong_refl) (auto simp: cong_def)
	+ also have "\<dots> = int (nat (((fst x mod int m) * (fst y mod int m) +
	+ 3 * (snd x mod int m) * (snd y mod int m)) mod m))"
	+ using m by (subst of_nat_nat) auto
	+ also have "\<dots> = int (nat (fst x mod int m) * nat (fst y mod int m) +
	+ 3 * (nat (snd x mod int m)) * nat (snd y mod int m)) mod m"
	+ using m by simp
	+ also have "nat \<dots> = (nat (fst x mod int m) * nat (fst y mod int m) +
	+ 3 * nat (snd x mod int m) * nat (snd y mod int m)) mod m"
	+ using m by (metis nat_int zmod_int)
	+ also have "\<dots> = fst (?mul2 (?\<phi> x) (?\<phi> y))"
	+ by (simp add: lucas_lehmer_hom_def lucas_lehmer_mult_def case_prod_unfold)
	+ finally show "fst (?\<phi> (?mul1 x y)) = fst (?mul2 (?\<phi> x) (?\<phi> y))" .
	+
	+ have "snd (?\<phi> (?mul1 x y)) = nat ((fst x * snd y + snd x * fst y) mod int m)"
	+ by (simp add: lucas_lehmer_hom_def lucas_lehmer_mult'_def case_prod_unfold)
	+ also have "(fst x * snd y + snd x * fst y) mod int m =
	+ ((fst x mod int m) * (snd y mod int m) +
	+ (snd x mod int m) * (fst y mod int m)) mod m"
	+ by (intro congD cong_mult cong_add cong_refl) (auto simp: cong_def)
	+ also have "\<dots> = int (nat (((fst x mod int m) * (snd y mod int m) +
	+ (snd x mod int m) * (fst y mod int m)) mod m))"
	+ using m by (subst of_nat_nat) auto
	+ also have "\<dots> = int (nat (fst x mod int m) * nat (snd y mod int m) +
	+ (nat (snd x mod int m)) * nat (fst y mod int m)) mod m"
	+ using m by simp
	+ also have "nat \<dots> = (nat (fst x mod int m) * nat (snd y mod int m) +
	+ nat (snd x mod int m) * nat (fst y mod int m)) mod m"
	+ using m by (metis nat_int zmod_int)
	+ also have "\<dots> = snd (?mul2 (?\<phi> x) (?\<phi> y))"
	+ by (simp add: lucas_lehmer_hom_def lucas_lehmer_mult_def case_prod_unfold)
	+ finally show "snd (?\<phi> (?mul1 x y)) = snd (?mul2 (?\<phi> x) (?\<phi> y))" .
	+qed
	+
	+lemma lucas_lehmer_hom_1 [simp]: "lucas_lehmer_hom m (1, 0) = (1, 0)"
	+ using m by (simp add: lucas_lehmer_hom_def)
	+
	+lemma ring_hom_lucas_lehmer_hom:
	+ "lucas_lehmer_hom m \<in> ring_hom lucas_lehmer_ring (lucas_lehmer_ring_mod m)"
	+proof -
	+ interpret R: cring lucas_lehmer_ring ..
	+ from m interpret S: cring "lucas_lehmer_ring_mod m" ..
	+ show ?thesis
	+ unfolding ring_hom_def using lucas_lehmer_hom_in_carrier m
	+ by (auto simp: lucas_lehmer_ring_mod_def lucas_lehmer_hom_add
	+ lucas_lehmer_ring_def lucas_lehmer_hom_mult)
	+qed
	+
	+end
	+
	+
	+subsection \<open>Correctness of the Lucas--Lehmer test\<close>
	+
	+text \<open>
	+ In this section, we will prove that the Lucas--Lehmer test is both a necessary and sufficient
	+ condition for the primality of a Mersenne number of the form $2^p - 1$ for an odd prime $p$.
	+ The proof that shall be given here is rather explicit and heavily draws from the Wikipedia
	+ article on the Lucas--Lehmer test~\cite{wiki:lucas_lehmer}.
	+
	+ A shorter and more high-level proof of a more general statement can be obtained using more
	+ theory on finite fields (in particular the field $\text{GF}(q^2)$ (cf.\ e.\,g.\
	+ Rödseth~\cite{roedseth94}).
	+\<close>
	+
	+definition lucas_lehmer_test where
	+ "lucas_lehmer_test p = (p > 2 \<and>
	+ (2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2))"
	+
	+text \<open>
	+ We can now prove that any Mersenne number $2^p - 1$ for $p$ prime that passes the
	+ Lucas--Lehmer test is prime. We follow the simple argument given by Bruce~\cite{bruce93},
	+ which is also given on Wikipedia~\cite{wiki:lucas_lehmer}.
	+\<close>
	+theorem lucas_lehmer_sufficient:
	+ assumes "prime p" "odd p"
	+ assumes "(2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
	+ shows "prime (2 ^ p - 1 :: nat)"
	+proof (rule ccontr)
	+ assume not_prime: "\<not>prime (2 ^ p - 1 :: nat)"
	+ from assms obtain k :: int where k: "gen_lucas_lehmer_sequence 4 (p - 2) = k * (2 ^ p - 1)"
	+ by (elim dvdE) (auto simp: mult_ac)
	+ from assms have "p > 2"
	+ using odd_prime_gt_2_nat by blast
	+ from \<open>p > 2\<close> have "2 ^ p \<ge> (2 ^ 3 :: nat)" by (intro power_increasing) auto
	+ hence "2 ^ p \<ge> (8 :: nat)" by simp
	+
	+ define q :: nat where "q = Min (prime_factors (2 ^ p - 1))"
	+ have "q \<in> prime_factors (2 ^ p - 1)" using \<open>2 ^ p \<ge> 8\<close>
	+ unfolding q_def by (intro Min_in) (auto simp: prime_factorization_empty_iff)
	+ hence q: "prime q" "q dvd (2 ^ p - 1 :: nat)"
	+ by (auto simp: in_prime_factors_iff)
	+ have q_minimal: "q \<le> q'" if "q' \<in> prime_factors (2 ^ p - 1)" for q'
	+ unfolding q_def by (rule Min_le) (use that in auto)
	+
	+ have "2 ^ p - 1 \<ge> q ^ 2"
	+ proof -
	+ from q obtain k where k: "2 ^ p - 1 = q * k" by auto
	+ have "prime_factorization (2 ^ p - 1 :: nat) \<noteq> {#q#}"
	+ proof
	+ assume *: "prime_factorization (2 ^ p - 1 :: nat) = {#q#}"
	+ have "2 ^ p - 1 = prod_mset (prime_factorization (2 ^ p - 1 :: nat))"
	+ using \<open>2 ^ p \<ge> 8\<close> by (subst prod_mset_prime_factorization_nat) auto
	+ also have "\<dots> = q" by (subst *) auto
	+ finally show False using not_prime q by simp
	+ qed
	+ hence "prime_factorization k \<noteq> {#}" using q k \<open>2 ^ p \<ge> 8\<close>
	+ by (subst (asm) k, subst (asm) prime_factorization_mult)
	+ (auto intro!: Nat.gr0I simp: prime_factorization_prime)
	+ hence "k \<noteq> 1" by (auto simp: prime_factorization_empty_iff)
	+ then obtain q' where q': "prime q'" "q' dvd k"
	+ using prime_factor_nat by blast
	+ from q' k \<open>2 ^ p \<ge> 8\<close> have "q \<le> q'"
	+ by (intro q_minimal) (auto simp: in_prime_factors_iff intro!: Nat.gr0I)
	+ hence "q ^ 2 \<le> q * q'"
	+ unfolding power2_eq_square by (intro mult_mono) auto
	+ also have "q * q' \<le> 2 ^ p - 1"
	+ using q q' k \<open>2 ^ p \<ge> 8\<close> by (intro dvd_imp_le) (auto intro!: Nat.gr0I)
	+ finally show "2 ^ p - 1 \<ge> q ^ 2" .
	+ qed
	+
	+ have "q \<noteq> 2" using q \<open>p > 2\<close> by auto
	+ moreover from q have "q \<noteq> 0" "q \<noteq> 1" by auto
	+ ultimately have "q > 2" by auto
	+
	+ write lucas_lehmer_ring ("R")
	+ define S where "S = lucas_lehmer_ring_mod q"
	+ define S' where "S' = units_of S"
	+ define \<phi> where "\<phi> = lucas_lehmer_hom q"
	+
	+ interpret R: cring R ..
	+ interpret S: cring S
	+ unfolding S_def by (rule cring_lucas_lehmer_ring_mod) (use \<open>q > 2\<close> in auto)
	+ interpret S': comm_group S'
	+ unfolding S'_def by (rule S.units_comm_group)
	+ have "\<phi> \<in> ring_hom R S"
	+ unfolding \<phi>_def S_def by (rule ring_hom_lucas_lehmer_hom) (use \<open>q > 2\<close> in auto)
	+ interpret \<phi>: ring_hom_cring R S \<phi>
	+ by standard fact
	+
	+ have "(2 + sqrt 3) ^ (2 ^ (p - 2)) + (2 - sqrt 3) ^ (2 ^ (p - 2)) =
	+ real_of_int (gen_lucas_lehmer_sequence 4 (p - 2))"
	+ unfolding gen_lucas_lehmer_sequence_4_closed_form1 ..
	+ also have "\<dots> = real_of_int k * (2 ^ p - 1)"
	+ by (simp add: k)
	+ finally have *: "(2 + sqrt 3) ^ (2 ^ (p - 2)) =
	+ real_of_int k * (2 ^ p - 1) - (2 - sqrt 3) ^ (2 ^ (p - 2))"
	+ by (simp add: algebra_simps)
	+ have "((2 + sqrt 3) ^ (2 ^ (p - 2))) ^ 2 =
	+ real_of_int k * (2 ^ p - 1) * (2 + sqrt 3) ^ (2 ^ (p - 2)) -
	+ (2 - sqrt 3) ^ (2 ^ (p - 2)) * (2 + sqrt 3) ^ (2 ^ (p - 2))"
	+ unfolding power2_eq_square by (subst *) (simp add: algebra_simps)
	+ also have "((2 + sqrt 3) ^ (2 ^ (p - 2))) ^ 2 = (2 + sqrt 3) ^ (2 * 2 ^ (p - 2))"
	+ by (simp flip: power_mult add: mult_ac)
	+ also have "2 * 2 ^ (p - 2) = 2 ^ (Suc (p - 2))"
	+ by simp
	+ also from \<open>p > 2\<close> have "Suc (p - 2) = p - 1"
	+ by linarith
	+ also have "(2 - sqrt 3) ^ (2 ^ (p - 2)) * (2 + sqrt 3) ^ (2 ^ (p - 2)) = 1"
	+ by (subst power_mult_distrib [symmetric]) (auto simp: algebra_simps)
	+ finally have "(2 + sqrt 3) ^ (2 ^ (p - 1)) =
	+ real_of_int k * (2 ^ p - 1) * (2 + sqrt 3) ^ (2 ^ (p - 2)) - 1" .
	+
	+ also have "(2 + sqrt 3) ^ (2 ^ (p - 1)) =
	+ lucas_lehmer_to_real ((2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 1) :: nat))"
	+ by (simp add: lucas_lehmer_to_real_simps)
	+ also have "real_of_int k * (2 ^ p - 1) * (2 + sqrt 3) ^ (2 ^ (p - 2)) - 1 =
	+ lucas_lehmer_to_real ((k * (2 ^ p - 1), 0) \<otimes>\<^bsub>R\<^esub>
	+ (2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)"
	+ by (simp add: lucas_lehmer_to_real_simps)
	+ finally have "((2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 1) :: nat)) =
	+ ((k * (2 ^ p - 1), 0) \<otimes>\<^bsub>R\<^esub> (2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)"
	+ by (rule injD[OF lucas_lehmer_to_real_inj])
	+
	+ hence "\<phi> ((2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 1) :: nat)) =
	+ \<phi> ((k * (2 ^ p - 1), 0) \<otimes>\<^bsub>R\<^esub> (2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)"
	+ by (simp only:)
	+ also have "\<phi> ((2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 1) :: nat)) = \<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ (p - 1) :: nat)"
	+ by simp
	+ also {
	+ have "int q dvd int (2 ^ p - 1)"
	+ by (subst int_dvd_int_iff) (use q in auto)
	+ also have "int (2 ^ p - 1) = 2 ^ p - 1"
	+ by (simp add: of_nat_diff)
	+ finally have "\<phi> (k * (2 ^ p - 1), 0) = \<zero>\<^bsub>S\<^esub>"
	+ by (simp add: \<phi>_def lucas_lehmer_hom_def S_def lucas_lehmer_ring_mod_def)
	+ }
	+ hence "\<phi> ((k * (2 ^ p - 1), 0) \<otimes>\<^bsub>R\<^esub> (2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) =
	+ \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
	+ by simp
	+ finally have eq: "\<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ (p - 1) :: nat) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>" .
	+
	+ have "\<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ p :: nat) = \<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ (p - 1) * 2 :: nat)"
	+ using \<open>p > 2\<close> by (cases p) (auto simp: mult_ac)
	+ also have "\<dots> = (\<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ (p - 1) :: nat)) [^]\<^bsub>S\<^esub> (2 :: nat)"
	+ by (subst S.nat_pow_pow) auto
	+ also have "\<dots> = \<one>\<^bsub>S\<^esub>"
	+ by (subst eq) (auto simp: numeral_2_eq_2 S.l_minus)
	+ finally have eq': "\<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ p :: nat) = \<one>\<^bsub>S\<^esub>" .
	+
	+ from eq' have unit: "\<phi> (2, 1) \<in> Units S"
	+ by (rule S.pow_nat_eq_1_imp_unit) auto
	+
	+ have neg_one_not_one: "\<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub> \<noteq> \<one>\<^bsub>S\<^esub>"
	+ proof
	+ assume *: "\<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub> = \<one>\<^bsub>S\<^esub>"
	+ have "(\<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>) \<oplus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub> = \<zero>\<^bsub>S\<^esub>"
	+ by (rule S.l_neg) auto
	+ hence "\<one>\<^bsub>S\<^esub> \<oplus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub> = \<zero>\<^bsub>S\<^esub>"
	+ by (simp only: *)
	+ thus False using \<open>q > 2\<close>
	+ by (auto simp: S_def lucas_lehmer_ring_mod_def lucas_lehmer_add_def)
	+ qed
	+
	+ have fin: "finite (Units S)"
	+ by (rule finite_subset[of _ "carrier S"]) (auto simp: Units_def S_def lucas_lehmer_ring_mod_def)
	+
	+ have "group.ord S' (\<phi> (2, 1)) = 2 ^ p"
	+ using \<open>p > 2\<close> eq eq' unit neg_one_not_one
	+ by (intro S'.ord_eqI_prime_factors)
	+ (auto simp: prime_factors_power prime_factorization_prime
	+ S'_def S.units_of_pow units_of_carrier units_of_one power_diff)
	+ hence "2 ^ p = group.ord S' (\<phi> (2, 1))"
	+ by simp
	+ also have "\<dots> = card (generate S' {\<phi> (2, 1)})"
	+ using unit fin
	+ by (intro S'.generate_pow_card) (auto simp: S'_def units_of_carrier)
	+ also have "\<dots> \<le> card (carrier S')"
	+ using fin unit by (intro card_mono S'.generate_incl) (auto simp: S'_def units_of_carrier)
	+ also have "\<dots> < q ^ 2"
	+ unfolding S'_def S_def using card_lucas_lehmer_Units[of q] \<open>q > 2\<close>
	+ by (auto simp: units_of_carrier)
	+ also note \<open>q ^ 2 \<le> 2 ^ p - 1\<close>
	+ finally show False by simp
	+qed
	+
	+text \<open>
	+ Next, we show that any Mersenne prime passes the Lucas--Lehmer test. We again follow the
	+ rather explicit proof outlined on Wikipedia~\cite{wiki:lucas_lehmer}, which is a simplified
	+ (but less general and less abstract) version of the proof by Rödseth~\cite{roedseth94}.
	+\<close>
	+theorem (in mersenne_prime) lucas_lehmer_necessary:
	+ "(2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
	+proof -
	+ write lucas_lehmer_ring ("R")
	+ define S where "S = lucas_lehmer_ring_mod M"
	+ define S' where "S' = units_of S"
	+ define \<phi> where "\<phi> = lucas_lehmer_hom M"
	+
	+ interpret R: cring R ..
	+ interpret S: cring S unfolding S_def
	+ by (rule cring_lucas_lehmer_ring_mod) (use M_gt_6 in auto)
	+ interpret S': comm_group S'
	+ unfolding S'_def by (rule S.units_comm_group)
	+ have "\<phi> \<in> ring_hom R S" unfolding \<phi>_def S_def
	+ by (rule ring_hom_lucas_lehmer_hom) (use M_gt_6 in auto)
	+ interpret \<phi>: ring_hom_cring R S \<phi>
	+ by standard fact
	+
	+ have R_pow_int: "(n, 0) [^]\<^bsub>R\<^esub> m = (n ^ m, 0)" for n :: int and m :: nat
	+ by (induction m; simp; simp add: lucas_lehmer_ring_def lucas_lehmer_mult'_def)
	+
	+ have "add_pow R n \<one>\<^bsub>R\<^esub> = (int n, 0)" for n
	+ by (induction n; simp; simp add: lucas_lehmer_ring_def lucas_lehmer_add'_def)
	+ hence "add_pow R M \<one>\<^bsub>R\<^esub> = (int M, 0)"
	+ by simp
	+ also have "\<phi> \<dots> = \<zero>\<^bsub>S\<^esub>"
	+ by (simp add: \<phi>_def S_def lucas_lehmer_ring_mod_def lucas_lehmer_hom_def)
	+ finally have "add_pow S M \<one>\<^bsub>S\<^esub> = \<zero>\<^bsub>S\<^esub>"
	+ by (simp add: \<phi>.hom_add_pow_nat)
	+
	+ define \<sigma> :: "int \<times> int" where "\<sigma> = (0, 2)"
	+ have eq1: "\<phi> ((6, 2) [^]\<^bsub>R\<^esub> M) = \<phi> (6, -2)"
	+ proof -
	+ have "(6, 2) = (6, 0) \<oplus>\<^bsub>R\<^esub> \<sigma>"
	+ by (simp add: lucas_lehmer_ring_def \<sigma>_def lucas_lehmer_add'_def)
	+ also have "\<phi> (\<dots> [^]\<^bsub>R\<^esub> M) = \<phi> ((6, 0) [^]\<^bsub>R\<^esub> M) \<oplus>\<^bsub>S\<^esub> \<phi> (\<sigma> [^]\<^bsub>R\<^esub> M)"
	+ using prime and \<open>add_pow S M \<one>\<^bsub>S\<^esub> = \<zero>\<^bsub>S\<^esub>\<close>
	+ by (simp add: S.binomial_finite_char)
	+ also have "(6, 0) [^]\<^bsub>R\<^esub> M = (6 ^ M, 0)"
	+ by (simp add: R_pow_int)
	+ also have "[6 ^ M = 6] (mod (int M))" using M_gt_6
	+ by (intro little_Fermat_int) (use prime in \<open>auto simp flip: dvd_nat_abs_iff\<close>)
	+ hence "\<phi> (6 ^ M, 0) = \<phi> (6, 0)"
	+ unfolding \<phi>_def by (intro lucas_lehmer_hom_cong) auto
	+ also have "\<sigma> = (2, 0) \<otimes>\<^bsub>R\<^esub> (0, 1)"
	+ by (simp add: \<sigma>_def lucas_lehmer_ring_def lucas_lehmer_mult'_def)
	+ hence "\<phi> (\<sigma> [^]\<^bsub>R\<^esub> M) = \<phi> ((2, 0) [^]\<^bsub>R\<^esub> M \<otimes>\<^bsub>R\<^esub> (0, 1) [^]\<^bsub>R\<^esub> M)"
	+ by (subst R.nat_pow_distrib [symmetric]) auto
	+ also have "\<dots> = \<phi> ((2, 0) [^]\<^bsub>R\<^esub> M) \<otimes>\<^bsub>S\<^esub> \<phi> ((0, 1) [^]\<^bsub>R\<^esub> M)"
	+ by simp
	+ also have "(2, 0) [^]\<^bsub>R\<^esub> M = (2 ^ M, 0)"
	+ by (simp add: R_pow_int)
	+ also have "[2 ^ M = 2] (mod int M)" using M_gt_6 prime
	+ by (intro little_Fermat_int) (auto simp flip: dvd_nat_abs_iff dest: dvd_imp_le)
	+ hence "\<phi> (2 ^ M, 0) = \<phi> (2, 0)"
	+ unfolding \<phi>_def by (intro lucas_lehmer_hom_cong) auto
	+ also have M_eq: "M = Suc (2 * ((M - 1) div 2))"
	+ using M_odd by auto
	+ have "(0, 1) [^]\<^bsub>R\<^esub> M = (0, 1) \<otimes>\<^bsub>R\<^esub> ((0, 1) [^]\<^bsub>R\<^esub> (2::nat)) [^]\<^bsub>R\<^esub> ((M - 1) div 2)"
	+ by (subst M_eq) (auto simp: R.nat_pow_mult R.nat_pow_pow R.cring_simprules)
	+ also have "(0, 1) [^]\<^bsub>R\<^esub> (2::nat) = (3, 0)"
	+ by (simp add: eval_nat_numeral) (simp add: lucas_lehmer_ring_def lucas_lehmer_mult'_def)
	+ also have "\<phi> ((0, 1) \<otimes>\<^bsub>R\<^esub> (3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) =
	+ \<phi> ((3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) \<otimes>\<^bsub>S\<^esub> \<phi> (0, 1)"
	+ by (simp add: S.cring_simprules)
	+ also have "(3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2) = (3 ^ ((M - 1) div 2), 0)"
	+ by (simp add: R_pow_int)
	+ also have "\<phi> (3 ^ ((M - 1) div 2), 0) = \<phi> (-1, 0)"
	+ unfolding \<phi>_def
	+ proof (intro lucas_lehmer_hom_cong')
	+ have "[3 ^ ((M - 1) div 2) = Legendre 3 M] (mod int M)"
	+ by (rule cong_sym, rule euler_criterion) (use prime M_gt_6 in auto)
	+ thus "[3 ^ ((M - 1) div 2) = -1] (mod int M)"
	+ by (simp add: Legendre_3_M)
	+ qed auto
	+ also have "\<phi> (2, 0) \<otimes>\<^bsub>S\<^esub> (\<phi> (- 1, 0) \<otimes>\<^bsub>S\<^esub> \<phi> (0, 1)) = \<phi> ((2, 0) \<otimes>\<^bsub>R\<^esub> (-1, 0) \<otimes>\<^bsub>R\<^esub> (0, 1))"
	+ by (simp add: R.cring_simprules S.cring_simprules)
	+ also have "\<phi> (6, 0) \<oplus>\<^bsub>S\<^esub> \<phi> ((2, 0) \<otimes>\<^bsub>R\<^esub> (- 1, 0) \<otimes>\<^bsub>R\<^esub> (0, 1)) =
	+ \<phi> ((6, 0) \<oplus>\<^bsub>R\<^esub> (2, 0) \<otimes>\<^bsub>R\<^esub> (- 1, 0) \<otimes>\<^bsub>R\<^esub> (0, 1))"
	+ by simp
	+ also have "\<dots> = \<phi> (6, -2)" unfolding \<phi>_def
	+ by (intro lucas_lehmer_hom_cong)
	+ (auto simp: lucas_lehmer_ring_def lucas_lehmer_mult'_def lucas_lehmer_add'_def)
	+ finally show "\<phi> ((6, 2) [^]\<^bsub>R\<^esub> M) = \<phi> (6, -2)"
	+ by (simp add: R.cring_simprules S.cring_simprules)
	+ qed
	+
	+ have eq2: "\<phi> ((24, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
	+ proof -
	+ have "(24, 0) = (2, 0) [^]\<^bsub>R\<^esub> (3::nat) \<otimes>\<^bsub>R\<^esub> (3, 0)"
	+ by (simp add: eval_nat_numeral) (auto simp: lucas_lehmer_ring_def lucas_lehmer_mult'_def)
	+ also have "\<dots> [^]\<^bsub>R\<^esub> ((M - 1) div 2) =
	+ ((2, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) [^]\<^bsub>R\<^esub> (3::nat) \<otimes>\<^bsub>R\<^esub> (3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)"
	+ by (simp add: R.cring_simprules R.nat_pow_distrib R.nat_pow_pow mult_ac)
	+ also have "\<phi> \<dots> = (\<phi> ((2, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2))) [^]\<^bsub>S\<^esub> (3::nat) \<otimes>\<^bsub>S\<^esub>
	+ \<phi> ((3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2))" by simp
	+ also have "(2, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2) = (2 ^ ((M - 1) div 2), 0)"
	+ by (simp add: R_pow_int)
	+ also have "\<phi> \<dots> = \<phi> (1, 0)"
	+ unfolding \<phi>_def
	+ proof (intro lucas_lehmer_hom_cong')
	+ have "[2 ^ ((M - 1) div 2) = Legendre 2 M] (mod int M)"
	+ by (rule cong_sym, rule euler_criterion) (use prime M_gt_6 in auto)
	+ thus "[2 ^ ((M - 1) div 2) = 1] (mod int M)"
	+ using Legendre_2_M by simp
	+ qed auto
	+ also have "(1, 0) = \<one>\<^bsub>R\<^esub>"
	+ by (simp add: lucas_lehmer_ring_def)
	+ also have "(3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2) = (3 ^ ((M - 1) div 2), 0)"
	+ by (simp add: R_pow_int)
	+ also have "\<phi> \<dots> = \<phi> (-1, 0)"
	+ unfolding \<phi>_def
	+ proof (intro lucas_lehmer_hom_cong')
	+ have "[3 ^ ((M - 1) div 2) = Legendre 3 M] (mod int M)"
	+ by (rule cong_sym, rule euler_criterion) (use prime M_gt_6 in auto)
	+ thus "[3 ^ ((M - 1) div 2) = -1] (mod int M)"
	+ using Legendre_3_M by simp
	+ qed auto
	+ also have "(-1, 0) = \<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>"
	+ using minus_lucas_lehmer_ring by (simp add: lucas_lehmer_ring_def)
	+ finally show "\<phi> ((24, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
	+ by simp
	+ qed
	+
	+ define \<omega> \<omega>' :: "int \<times> int" where "\<omega> = (2, 1)" and "\<omega>' = (2, -1)"
	+ have eq3: "\<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2)) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
	+ proof -
	+ have "(M + 1) div 2 = Suc ((M - 1) div 2)"
	+ using M_odd M_gt_6 by (auto elim!: oddE)
	+ have *: "\<phi> ((24, 0) \<otimes>\<^bsub>R\<^esub> \<omega>) = \<phi> ((6, 2) [^]\<^bsub>R\<^esub> (2 :: nat))" unfolding \<phi>_def
	+ by (intro lucas_lehmer_hom_cong)
	+ (simp_all add: eval_nat_numeral,
	+ auto simp: lucas_lehmer_ring_def lucas_lehmer_mult'_def \<omega>_def)
	+ have "\<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<phi> ((24, 0) \<otimes>\<^bsub>R\<^esub> \<omega>) [^]\<^bsub>S\<^esub> ((M + 1) div 2) =
	+ \<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<phi> ((6, 2) [^]\<^bsub>R\<^esub> (2 :: nat)) [^]\<^bsub>S\<^esub> ((M + 1) div 2)"
	+ by (subst *) auto
	+ hence "\<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<phi> ((24, 0) [^]\<^bsub>R\<^esub> ((M + 1) div 2)) \<otimes>\<^bsub>S\<^esub> \<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2)) =
	+ \<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<phi> ((6, 2) [^]\<^bsub>R\<^esub> (2 * ((M + 1) div 2)))"
	+ by (simp add: R.nat_pow_distrib S.nat_pow_distrib R.nat_pow_pow
	+ S.nat_pow_pow R.cring_simprules S.cring_simprules)
	+ also have "2 * ((M + 1) div 2) = M + 1"
	+ using M_odd by auto
	+ finally have "\<phi> (24, 0) \<otimes>\<^bsub>S\<^esub> (\<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<phi> ((24, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2))) \<otimes>\<^bsub>S\<^esub>
	+ \<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2)) =
	+ \<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> (\<phi> (6, 2) \<otimes>\<^bsub>S\<^esub> \<phi> ((6, 2) [^]\<^bsub>R\<^esub> M))"
	+ by (subst (asm) \<open>(M + 1) div 2 = _\<close>) (simp add: S.cring_simprules R.cring_simprules)
	+
	+ also have "\<phi> ((24, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
	+ by (subst eq2) auto
	+ also have "(\<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>) = \<one>\<^bsub>S\<^esub>"
	+ by (simp add: S.cring_simprules)
	+ also have "\<phi> ((6, 2) [^]\<^bsub>R\<^esub> M) = \<phi> (6, -2)"
	+ by (subst eq1) auto
	+ also have "\<phi> (6, 2) \<otimes>\<^bsub>S\<^esub> \<phi> (6, -2) = \<phi> ((6, 2) \<otimes>\<^bsub>R\<^esub> (6, -2))"
	+ by simp
	+ also have "\<dots> = \<phi> (24, 0)" unfolding \<phi>_def
	+ by (intro lucas_lehmer_hom_cong) (auto simp: lucas_lehmer_ring_def lucas_lehmer_mult'_def)
	+ finally have "\<phi> (24, 0) \<otimes>\<^bsub>S\<^esub> (\<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2))) =
	+ \<phi> (24, 0) \<otimes>\<^bsub>S\<^esub> \<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)"
	+ by (simp add: S.cring_simprules)
	+ also have "\<phi> (24, 0) = (24 mod M, 0)"
	+ by (simp add: \<phi>_def lucas_lehmer_hom_def nat_mod_as_int)
	+ finally have "(24 mod M, 0) \<otimes>\<^bsub>S\<^esub> (\<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2))) =
	+ (24 mod M, 0) \<otimes>\<^bsub>S\<^esub> \<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)" .
	+ moreover have "(24 mod M, 0) \<in> Units S"
	+ unfolding S_def using M_gt_6 prime M_not_dvd_24
	+ by (intro int_in_Units_lucas_lehmer_ring_mod) (auto simp: dvd_mod_iff intro!: Nat.gr0I)
	+ ultimately show "\<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2)) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
	+ by (subst (asm) S.Units_l_cancel) auto
	+ qed
	+
	+ have eq4: "\<phi> (\<omega> [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<omega>' [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat)) = \<zero>\<^bsub>S\<^esub>"
	+ (is "\<phi> ?lhs = _")
	+ proof -
	+ have "\<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2)) \<otimes>\<^bsub>S\<^esub> \<phi> (\<omega>' [^]\<^bsub>R\<^esub> ((M + 1) div 4)) \<oplus>\<^bsub>S\<^esub>
	+ \<phi> (\<omega>' [^]\<^bsub>R\<^esub> ((M + 1) div 4)) = \<zero>\<^bsub>S\<^esub>"
	+ by (subst eq3) (auto simp: S.cring_simprules)
	+ also have "2 ^ 2 dvd (2 ^ p :: nat)"
	+ by (intro le_imp_power_dvd) (use p_gt_2 in auto)
	+ hence "4 dvd (M + 1)" by (auto simp: M_def)
	+ hence "(M + 1) div 2 = (M + 1) div 4 + (M + 1) div 4"
	+ by presburger
	+ also have "\<phi> (\<omega> [^]\<^bsub>R\<^esub> \<dots>) \<otimes>\<^bsub>S\<^esub> \<phi> (\<omega>' [^]\<^bsub>R\<^esub> ((M + 1) div 4)) =
	+ \<phi> (\<omega> \<otimes>\<^bsub>R\<^esub> \<omega>') [^]\<^bsub>S\<^esub> ((M + 1) div 4) \<otimes>\<^bsub>S\<^esub> \<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 4))"
	+ by (simp add: S.cring_simprules S.nat_pow_distrib flip: S.nat_pow_mult)
	+ also have "\<phi> (\<omega> \<otimes>\<^bsub>R\<^esub> \<omega>') = \<phi> \<one>\<^bsub>R\<^esub>" unfolding \<phi>_def
	+ by (intro lucas_lehmer_hom_cong)
	+ (auto simp: \<omega>_def \<omega>'_def lucas_lehmer_ring_def lucas_lehmer_mult'_def)
	+ also have "(M + 1) div 4 = 2 ^ (p - 2)"
	+ using p_gt_2 by (auto simp: M_def power_diff)
	+ finally show eq4: "\<phi> (\<omega> [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<omega>' [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat)) = \<zero>\<^bsub>S\<^esub>"
	+ by simp
	+ qed
	+
	+ have "\<phi> ?lhs = \<zero>\<^bsub>S\<^esub>"
	+ by (rule eq4)
	+ also have "lucas_lehmer_to_real ?lhs =
	+ lucas_lehmer_to_real (gen_lucas_lehmer_sequence 4 (p - 2), 0)"
	+ by (simp add: \<omega>_def \<omega>'_def lucas_lehmer_to_real_simps gen_lucas_lehmer_sequence_4_closed_form1)
	+ hence "?lhs = (gen_lucas_lehmer_sequence 4 (p - 2), 0)"
	+ by (rule injD[OF lucas_lehmer_to_real_inj])
	+ finally have "gen_lucas_lehmer_sequence 4 (p - 2) mod M = 0" using M_gt_6
	+ by (auto simp: \<phi>_def lucas_lehmer_hom_def S_def lucas_lehmer_ring_mod_def)
	+ thus "(2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
	+ by (simp add: M_def mod_eq_0_iff_dvd of_nat_diff)
	+qed
	+
	+corollary lucas_lehmer_correct:
	+ "prime (2 ^ p - 1 :: nat) \<longleftrightarrow>
	+ prime p \<and> (p = 2 \<or> (2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2))"
	+proof (intro iffI; (elim conjE)?)
	+ assume prime: "prime (2 ^ p - 1 :: nat)"
	+ from prime have "p \<noteq> 0" "p \<noteq> 1"
	+ by (auto intro!: Nat.gr0I)
	+ hence "p = 2 \<or> p > 2" by auto
	+ thus "prime p \<and> (p = 2 \<or> (2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2))"
	+ proof (elim disjE)
	+ assume "p > 2"
	+ with prime interpret mersenne_prime p "2 ^ p - 1"
	+ by unfold_locales
	+ from lucas_lehmer_necessary p_prime show ?thesis by auto
	+ qed auto
	+next
	+ assume prime: "prime p" and *: "p = 2 \<or> (2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
	+ from * consider "p = 2" \| "p \<noteq> 2" "(2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
	+ by auto
	+ thus "prime (2 ^ p - 1 :: nat)"
	+ proof cases
	+ assume "p \<noteq> 2" and dvd: "(2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
	+ from \<open>prime p\<close> and \<open>p \<noteq> 2\<close> have "p > 2"
	+ using prime_gt_1_nat[of p] by auto
	+ with prime have "odd p" by (auto simp: prime_odd_nat)
	+ with prime dvd show ?thesis
	+ by (intro lucas_lehmer_sufficient)
	+ qed auto
	+qed
	+
	+corollary lucas_lehmer_correct':
	+ "prime (2 ^ p - 1 :: nat) \<longleftrightarrow> prime p \<and> (p = 2 \<or> lucas_lehmer_test p)"
	+ using lucas_lehmer_correct[of p] prime_gt_1_nat[of p]
	+ by (auto simp: lucas_lehmer_test_def)
	+
	+
	+subsection \<open>A first executable version Lucas--Lehmer test\<close>
	+
	+text \<open>
	+ The following is an implementation of the Lucas--Lehmer test using modular
	+ arithmetic on the integers. This is not the most efficient implementation --
	+ the modular arithmetic can be replaced by much cheaper bitwise operations,
	+ and we will do that in the next section.
	+\<close>
	+
	+primrec gen_lucas_lehmer_sequence' :: "int \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int" where
	+ "gen_lucas_lehmer_sequence' m a 0 = a"
	+\| "gen_lucas_lehmer_sequence' m a (Suc n) = gen_lucas_lehmer_sequence' m ((a ^ 2 - 2) mod m) n"
	+
	+lemma gen_lucas_lehmer_sequence'_Suc':
	+ "gen_lucas_lehmer_sequence' m a (Suc n) = (gen_lucas_lehmer_sequence' m a n ^ 2 - 2) mod m"
	+ by (induction n arbitrary: a) auto
	+
	+lemma gen_lucas_lehmer_sequence'_correct:
	+ assumes "a \<in> {0..<m}"
	+ shows "gen_lucas_lehmer_sequence' m a n = gen_lucas_lehmer_sequence a n mod m"
	+ using assms
	+proof (induction n)
	+ case (Suc n)
	+ have "gen_lucas_lehmer_sequence' m a (Suc n) =
	+ ((gen_lucas_lehmer_sequence a n mod m)\<^sup>2 - 2) mod m"
	+ using Suc unfolding gen_lucas_lehmer_sequence'_Suc' by simp
	+ also have "\<dots> = ((gen_lucas_lehmer_sequence a n)\<^sup>2 - 2) mod m"
	+ by (intro congD cong_diff cong_pow cong_refl) (auto simp: cong_def)
	+ finally show ?case by simp
	+qed auto
	+
	+lemma lucas_lehmer_test_code_arithmetic [code]:
	+ "lucas_lehmer_test p = (p > 2 \<and>
	+ gen_lucas_lehmer_sequence' (2 ^ p - 1) 4 (p - 2) = 0)"
	+ unfolding lucas_lehmer_test_def
	+proof (intro conj_cong refl)
	+ assume p: "p > 2"
	+ from p have "2 ^ p \<ge> (2 ^ 3 :: int)" by (intro power_increasing) auto
	+ have "(2 ^ p - 1 dvd gen_lucas_lehmer_sequence 4 (p - 2)) \<longleftrightarrow>
	+ gen_lucas_lehmer_sequence 4 (p - 2) mod (2 ^ p - 1) = 0"
	+ by auto
	+ also have "gen_lucas_lehmer_sequence 4 (p - 2) mod (2 ^ p - 1) =
	+ gen_lucas_lehmer_sequence' (2 ^ p - 1) 4 (p - 2)"
	+ using \<open>2 ^ p \<ge> 2 ^ 3\<close>
	+ by (intro gen_lucas_lehmer_sequence'_correct [symmetric]) auto
	+ finally show "(2 ^ p - 1 dvd gen_lucas_lehmer_sequence 4 (p - 2)) =
	+ (gen_lucas_lehmer_sequence' (2 ^ p - 1) 4 (p - 2) = 0)" .
	+qed
	+
	+lemma mersenne_prime_iff: "mersenne_prime p \<longleftrightarrow> p > 2 \<and> prime (2 ^ p - 1 :: nat)"
	+ by (simp add: mersenne_prime_def)
	+
	+lemma mersenne_prime_code [code]:
	+ "mersenne_prime p \<longleftrightarrow> prime p \<and> lucas_lehmer_test p"
	+ unfolding mersenne_prime_iff using lucas_lehmer_correct'[of p]
	+ by (auto simp: lucas_lehmer_test_def)
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Mersenne_Primes/Lucas_Lehmer_Auxiliary.thy b/thys/Mersenne_Primes/Lucas_Lehmer_Auxiliary.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Mersenne_Primes/Lucas_Lehmer_Auxiliary.thy
	@@ -0,0 +1,370 @@
	+section \<open>Auxiliary material\<close>
	+theory Lucas_Lehmer_Auxiliary
	+imports
	+ "HOL-Algebra.Ring"
	+ "Probabilistic_Prime_Tests.Jacobi_Symbol"
	+begin
	+
	+(* TODO: Much of this belongs in the library *)
	+
	+subsection \<open>Auxiliary number-theoretic material\<close>
	+
	+lemma congD: "[a = b] (mod n) \<Longrightarrow> a mod n = b mod n"
	+ by (auto simp: cong_def)
	+
	+lemma eval_coprime:
	+ "(b :: 'a :: euclidean_semiring_gcd) \<noteq> 0 \<Longrightarrow> coprime a b \<longleftrightarrow> coprime b (a mod b)"
	+ by (simp add: coprime_commute)
	+
	+lemma two_power_odd_mod_12:
	+ assumes "odd n" "n > 1"
	+ shows "[2 ^ n = 8] (mod (12 :: nat))"
	+ using assms
	+proof (induction n rule: less_induct)
	+ case (less n)
	+ show ?case
	+ proof (cases "n = 3")
	+ case False
	+ with less.prems have "n > 3" by (auto elim!: oddE)
	+ hence "[2 ^ (n - 2 + 2) = (8 * 4 :: nat)] (mod 12)"
	+ unfolding power_add using less.prems by (intro cong_mult less) auto
	+ also have "n - 2 + 2 = n"
	+ using \<open>n > 3\<close> by simp
	+ finally show ?thesis by (simp add: cong_def)
	+ qed auto
	+qed
	+
	+lemma Legendre_3_right:
	+ fixes p :: nat
	+ assumes p: "prime p" "p > 3"
	+ shows "p mod 12 \<in> {1, 5, 7, 11}" and "Legendre p 3 = (if p mod 12 \<in> {1, 7} then 1 else -1)"
	+proof -
	+ have "coprime p 2" using p prime_nat_not_dvd[of p 2]
	+ by (intro prime_imp_coprime) (auto dest: dvd_imp_le)
	+ moreover have "coprime p 3" using p
	+ by (intro prime_imp_coprime) auto
	+ ultimately have "coprime p (2 * 2 * 3)"
	+ unfolding coprime_mult_right_iff by auto
	+ hence "coprime 12 p"
	+ by (simp add: coprime_commute)
	+
	+ hence "p mod 12 \<in> {p\<in>{..11}. coprime 12 p}" by auto
	+ also have "{p\<in>{..11}. coprime 12 p} = {1::nat, 5, 7, 11}"
	+ unfolding atMost_nat_numeral pred_numeral_simps arith_simps
	+ by (auto simp del: coprime_imp_gcd_eq_1 simp: eval_coprime)
	+ finally show "p mod 12 \<in> {1, 5, 7, 11}" by auto
	+ hence "p mod 12 = 1 \<or> p mod 12 = 5 \<or> p mod 12 = 7 \<or> p mod 12 = 11"
	+ by auto
	+ thus "Legendre p 3 = (if p mod 12 \<in> {1, 7} then 1 else -1)"
	+ proof safe
	+ assume "p mod 12 = 1"
	+ have "Legendre (int p) 3 = Legendre (int p mod 3) 3"
	+ by (intro Legendre_mod [symmetric]) auto
	+ also from \<open>p mod 12 = 1\<close> have "p mod 12 mod 3 = 1" by simp
	+ hence "p mod 3 = 1" by (simp add: mod_mod_cancel)
	+ hence "int p mod 3 = 1" by presburger
	+ finally have "Legendre p 3 = 1" by simp
	+ thus ?thesis using \<open>p mod 12 = 1\<close> by simp
	+ next
	+ assume "p mod 12 = 5"
	+ have "Legendre (int p) 3 = Legendre (int p mod 3) 3"
	+ by (intro Legendre_mod [symmetric]) auto
	+ also from \<open>p mod 12 = 5\<close> have "p mod 12 mod 3 = 2" by simp
	+ hence "p mod 3 = 2" by (simp add: mod_mod_cancel)
	+ hence "int p mod 3 = 2" by presburger
	+ finally have "Legendre p 3 = -1" by (simp add: supplement2_Legendre)
	+ thus ?thesis using \<open>p mod 12 = 5\<close> by simp
	+ next
	+ assume "p mod 12 = 7"
	+ have "Legendre (int p) 3 = Legendre (int p mod 3) 3"
	+ by (intro Legendre_mod [symmetric]) auto
	+ also from \<open>p mod 12 = 7\<close> have "p mod 12 mod 3 = 1" by simp
	+ hence "p mod 3 = 1" by (simp add: mod_mod_cancel)
	+ hence "int p mod 3 = 1" by presburger
	+ finally have "Legendre p 3 = 1" by simp
	+ thus ?thesis using \<open>p mod 12 = 7\<close> by simp
	+ next
	+ assume "p mod 12 = 11"
	+ have "Legendre (int p) 3 = Legendre (int p mod 3) 3"
	+ by (intro Legendre_mod [symmetric]) auto
	+ also from \<open>p mod 12 = 11\<close> have "p mod 12 mod 3 = 2" by simp
	+ hence "p mod 3 = 2" by (simp add: mod_mod_cancel)
	+ hence "int p mod 3 = 2" by presburger
	+ finally have "Legendre p 3 = -1" by (simp add: supplement2_Legendre)
	+ thus ?thesis using \<open>p mod 12 = 11\<close> by simp
	+ qed
	+qed
	+
	+lemma Legendre_3_left:
	+ fixes p :: nat
	+ assumes p: "prime p" "p > 3"
	+ shows "Legendre 3 p = (if p mod 12 \<in> {1, 11} then 1 else -1)"
	+proof (cases "p mod 12 = 1 \<or> p mod 12 = 5")
	+ case True
	+ hence "p mod 12 mod 4 = 1" by auto
	+ hence "even ((p - Suc 0) div 2)"
	+ by (intro even_mod_4_div_2) (auto simp: mod_mod_cancel)
	+ with Quadratic_Reciprocity[of p 3] Legendre_3_right(2)[of p] assms True show ?thesis
	+ by auto
	+next
	+ case False
	+ with Legendre_3_right(1)[OF assms] have *: "p mod 12 = 7 \<or> p mod 12 = 11" by auto
	+ hence "p mod 12 mod 4 = 3" by auto
	+ hence "odd ((p - Suc 0) div 2)"
	+ by (intro odd_mod_4_div_2) (auto simp: mod_mod_cancel)
	+ with Quadratic_Reciprocity[of p 3] Legendre_3_right(2)[of p] assms * show ?thesis
	+ by fastforce
	+qed
	+
	+lemma supplement2_Legendre':
	+ assumes "prime p" "p \<noteq> 2"
	+ shows "Legendre 2 p = (if p mod 8 = 1 \<or> p mod 8 = 7 then 1 else -1)"
	+proof -
	+ from assms have "p > 2"
	+ using prime_gt_1_int[of p] by auto
	+ moreover from this and assms have "odd p"
	+ by (auto simp: prime_odd_int)
	+ ultimately show ?thesis
	+ using supplement2_Jacobi'[of p] assms prime_odd_int[of p]
	+ by (simp add: prime_p_Jacobi_eq_Legendre)
	+qed
	+
	+lemma little_Fermat_nat:
	+ fixes a :: nat
	+ assumes "prime p" "\<not>p dvd a"
	+ shows "[a ^ p = a] (mod p)"
	+proof -
	+ have "p = Suc (p - 1)"
	+ using prime_gt_0_nat[OF assms(1)] by simp
	+ also have "p - 1 = totient p"
	+ using assms by (simp add: totient_prime)
	+ also have "a ^ (Suc \<dots>) = a * a ^ totient p"
	+ by simp
	+ also have "[\<dots> = a * 1] (mod p)"
	+ using prime_imp_coprime[of p a] assms
	+ by (intro cong_mult cong_refl euler_theorem) (auto simp: coprime_commute)
	+ finally show ?thesis by simp
	+qed
	+
	+lemma little_Fermat_int:
	+ fixes a :: int and p :: nat
	+ assumes "prime p" "\<not>p dvd a"
	+ shows "[a ^ p = a] (mod p)"
	+proof -
	+ have "p > 1" using prime_gt_1_nat assms by simp
	+ have "\<not>int p dvd a mod int p"
	+ using assms by (simp add: dvd_mod_iff)
	+ also from \<open>p > 1\<close> have "a mod int p = int (nat (a mod int p))"
	+ by simp
	+ finally have not_dvd: "\<not>p dvd nat (a mod int p)"
	+ by (subst (asm) int_dvd_int_iff)
	+
	+ have "[a ^ p = (a mod p) ^ p] (mod p)"
	+ by (intro cong_pow) (auto simp: cong_def)
	+ also have "(a mod p) ^ p = (int (nat (a mod p))) ^ p"
	+ using \<open>p > 1\<close> by (subst of_nat_nat) auto
	+ also have "\<dots> = int (nat (a mod p) ^ p)"
	+ by simp
	+ also have "[\<dots> = int (nat (a mod p))] (mod p)"
	+ by (subst cong_int_iff, rule little_Fermat_nat) (use assms not_dvd in auto)
	+ also have "int (nat (a mod p)) = a mod p"
	+ using \<open>p > 1\<close> by simp
	+ also have "[a mod p = a] (mod p)"
	+ by (auto simp: cong_def)
	+ finally show ?thesis .
	+qed
	+
	+lemma prime_dvd_choose:
	+ assumes "0 < k" "k < p" "prime p"
	+ shows "p dvd (p choose k)"
	+proof -
	+ have "k \<le> p" using \<open>k < p\<close> by auto
	+
	+ have "p dvd fact p" using assms by (simp add: prime_dvd_fact_iff)
	+
	+ moreover have "\<not> p dvd fact k * fact (p - k)"
	+ unfolding prime_dvd_mult_iff[OF assms(3)] prime_dvd_fact_iff[OF assms(3)]
	+ using assms by simp
	+
	+ ultimately show ?thesis
	+ unfolding binomial_fact_lemma[OF \<open>k \<le> p\<close>, symmetric]
	+ using assms prime_dvd_multD by blast
	+qed
	+
	+lemma prime_natD:
	+ assumes "prime (p :: nat)" "a dvd p"
	+ shows "a = 1 \<or> a = p"
	+ using assms by (auto simp: prime_nat_iff)
	+
	+ lemma not_prime_imp_ex_prod_nat:
	+ assumes "m > 1" "\<not> prime (m::nat)"
	+ shows "\<exists>n k. m = n * k \<and> 1 < n \<and> n < m \<and> 1 < k \<and> k < m"
	+proof -
	+ from assms have "\<not>Factorial_Ring.irreducible m"
	+ by (simp flip: prime_elem_iff_irreducible)
	+ with assms obtain n k where nk: "m = n * k" "n \<noteq> 1" "k \<noteq> 1"
	+ by (auto simp: Factorial_Ring.irreducible_def)
	+ moreover from this assms have "n > 0" "k > 0"
	+ by auto
	+ with nk have "n > 1" "k > 1" by auto
	+ moreover {
	+ from assms nk have "n dvd m" "k dvd m" by auto
	+ with assms have "n \<le> m" "k \<le> m"
	+ by (auto intro!: dvd_imp_le)
	+ moreover from nk \<open>n > 1\<close> \<open>k > 1\<close> have "n \<noteq> m" "k \<noteq> m"
	+ by auto
	+ ultimately have "n < m" "k < m" by auto
	+ }
	+ ultimately show ?thesis by blast
	+qed
	+
	+
	+subsection \<open>Auxiliary algebraic material\<close>
	+
	+lemma (in group) ord_eqI_prime_factors:
	+ assumes "\<And>p. p \<in> prime_factors n \<Longrightarrow> x [^] (n div p) \<noteq> \<one>" and "x [^] n = \<one>"
	+ assumes "x \<in> carrier G" "n > 0"
	+ shows "group.ord G x = n"
	+proof -
	+ have "group.ord G x dvd n"
	+ using assms by (subst pow_eq_id [symmetric]) auto
	+ then obtain k where k: "n = group.ord G x * k"
	+ by auto
	+ have "k = 1"
	+ proof (rule ccontr)
	+ assume "k \<noteq> 1"
	+ then obtain p where p: "prime p" "p dvd k"
	+ using prime_factor_nat by blast
	+ have "x [^] (group.ord G x * (k div p)) = \<one>"
	+ by (subst pow_eq_id) (use assms in auto)
	+ also have "group.ord G x * (k div p) = n div p"
	+ using p by (auto simp: k)
	+ finally have "x [^] (n div p) = \<one>" .
	+ moreover have "x [^] (n div p) \<noteq> \<one>"
	+ using p k assms by (intro assms) (auto simp: in_prime_factors_iff)
	+ ultimately show False by contradiction
	+ qed
	+ with k show ?thesis by simp
	+qed
	+
	+lemma (in monoid) pow_nat_eq_1_imp_unit:
	+ fixes n :: nat
	+ assumes "x [^] n = \<one>" and "n > 0" and [simp]: "x \<in> carrier G"
	+ shows "x \<in> Units G"
	+proof -
	+ from \<open>n > 0\<close> have "x [^] (1 :: nat) \<otimes> x [^] (n - 1) = x [^] n"
	+ by (subst nat_pow_mult) auto
	+ with assms have "x \<otimes> x [^] (n - 1) = \<one>"
	+ by simp
	+ moreover from \<open>n > 0\<close> have "x [^] (n - 1) \<otimes> x [^] (1 :: nat) = x [^] n"
	+ by (subst nat_pow_mult) auto
	+ with assms have "x [^] (n - 1) \<otimes> x = \<one>"
	+ by simp
	+ ultimately show ?thesis by (auto simp: Units_def)
	+qed
	+
	+lemma (in cring) finsum_reindex_bij_betw:
	+ assumes "bij_betw h S T" "g \<in> T \<rightarrow> carrier R"
	+ shows "finsum R (\<lambda>x. g (h x)) S = finsum R g T"
	+ using assms by (auto simp: bij_betw_def finsum_reindex)
	+
	+lemma (in cring) finsum_reindex_bij_witness:
	+ assumes witness:
	+ "\<And>a. a \<in> S \<Longrightarrow> i (j a) = a"
	+ "\<And>a. a \<in> S \<Longrightarrow> j a \<in> T"
	+ "\<And>b. b \<in> T \<Longrightarrow> j (i b) = b"
	+ "\<And>b. b \<in> T \<Longrightarrow> i b \<in> S"
	+ "\<And>b. b \<in> S \<Longrightarrow> g b \<in> carrier R"
	+ assumes eq:
	+ "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
	+ shows "finsum R g S = finsum R h T"
	+proof -
	+ have bij: "bij_betw j S T"
	+ using bij_betw_byWitness[where A=S and f=j and f'=i and A'=T] witness by auto
	+ hence T_eq: "T = j ` S" by (auto simp: bij_betw_def)
	+ from assms have "h \<in> T \<rightarrow> carrier R"
	+ by (subst T_eq) auto
	+ moreover have "finsum R g S = finsum R (\<lambda>x. h (j x)) S"
	+ using assms by (intro finsum_cong) (auto simp: eq)
	+ ultimately show ?thesis using assms(5)
	+ using finsum_reindex_bij_betw[OF bij, of h] by simp
	+qed
	+
	+lemma (in cring) binomial:
	+ fixes n :: nat
	+ assumes [simp]: "x \<in> carrier R" "y \<in> carrier R"
	+ shows "(x \<oplus> y) [^] n = (\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (n - i)))"
	+proof (induction n)
	+ case (Suc n)
	+ have binomial_Suc: "Suc n choose i = (n choose (i - 1)) + (n choose i)" if "i \<in> {1..n}" for i
	+ using that by (cases i) auto
	+ have Suc_diff: "Suc n - i = Suc (n - i)" if "i \<le> n" for i
	+ using that by linarith
	+ have "(x \<oplus> y) [^] Suc n =
	+ (\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (n - i))) \<otimes> x \<oplus>
	+ (\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (n - i))) \<otimes> y"
	+ by (simp add: semiring_simprules Suc)
	+ also have "(\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (n - i))) \<otimes> x =
	+ (\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] Suc i \<otimes> y [^] (n - i)))"
	+ by (subst finsum_ldistr)
	+ (auto simp: cring_simprules Suc add_pow_rdistr intro!: finsum_cong)
	+ also have "\<dots> = (\<Oplus>i\<in>{1..Suc n}. add_pow R (n choose (i - 1)) (x [^] i \<otimes> y [^] (Suc n - i)))"
	+ by (intro finsum_reindex_bij_witness[of _ "\<lambda>i. i - 1" Suc]) auto
	+ also have "{1..Suc n} = insert (Suc n) {1..n}" by auto
	+ also have "(\<Oplus>i\<in>\<dots>. add_pow R (n choose (i - 1)) (x [^] i \<otimes> y [^] (Suc n - i))) =
	+ x [^] Suc n \<oplus> (\<Oplus>i\<in>{1..n}. add_pow R (n choose (i - 1)) (x [^] i \<otimes> y [^] (Suc n - i)))"
	+ (is "_ = _ \<oplus> ?S1") by (subst finsum_insert) auto
	+ also have "(\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (n - i))) \<otimes> y =
	+ (\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (Suc n - i)))"
	+ by (subst finsum_ldistr)
	+ (auto simp: cring_simprules Suc add_pow_rdistr Suc_diff intro!: finsum_cong)
	+ also have "{..n} = insert 0 {1..n}" by auto
	+ also have "(\<Oplus>i\<in>\<dots>. add_pow R (n choose i) (x [^] i \<otimes> y [^] (Suc n - i))) =
	+ y [^] Suc n \<oplus> (\<Oplus>i\<in>{1..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (Suc n - i)))"
	+ (is "_ = _ \<oplus> ?S2") by (subst finsum_insert) auto
	+ also have "(x [^] Suc n \<oplus> ?S1) \<oplus> (y [^] Suc n \<oplus> ?S2) =
	+ x [^] Suc n \<oplus> y [^] Suc n \<oplus> (?S1 \<oplus> ?S2)"
	+ by (simp add: cring_simprules)
	+ also have "?S1 \<oplus> ?S2 = (\<Oplus>i\<in>{1..n}. add_pow R (Suc n choose i) (x [^] i \<otimes> y [^] (Suc n - i)))"
	+ by (subst finsum_addf [symmetric], simp, simp, rule finsum_cong')
	+ (auto intro!: finsum_cong simp: binomial_Suc add.nat_pow_mult)
	+ also have "x [^] Suc n \<oplus> y [^] Suc n \<oplus> \<dots> =
	+ (\<Oplus>i\<in>{0, Suc n} \<union> {1..n}. add_pow R (Suc n choose i) (x [^] i \<otimes> y [^] (Suc n - i)))"
	+ by (subst finsum_Un_disjoint) (auto simp: cring_simprules)
	+ also have "{0, Suc n} \<union> {1..n} = {..Suc n}" by auto
	+ finally show ?case .
	+qed auto
	+
	+lemma (in cring) binomial_finite_char:
	+ fixes p :: nat
	+ assumes [simp]: "x \<in> carrier R" "y \<in> carrier R" and "add_pow R p \<one> = \<zero>" "prime p"
	+ shows "(x \<oplus> y) [^] p = x [^] p \<oplus> y [^] p"
	+proof -
	+ have *: "add_pow R (p choose i) (x [^] i \<otimes> y [^] (p - i)) = \<zero>" if "i \<in> {1..<p}" for i
	+ proof -
	+ have "p dvd (p choose i)"
	+ by (rule prime_dvd_choose) (use that assms in auto)
	+ then obtain k where [simp]: "(p choose i) = p * k"
	+ by auto
	+ have "add_pow R (p choose i) (x [^] i \<otimes> y [^] (p - i)) =
	+ add_pow R (p choose i) \<one> \<otimes> (x [^] i \<otimes> y [^] (p - i))"
	+ by (simp add: add_pow_ldistr)
	+ also have "add_pow R (p choose i) \<one> = \<zero>"
	+ using assms by (simp flip: add.nat_pow_pow)
	+ finally show ?thesis by simp
	+ qed
	+
	+ have "(x \<oplus> y) [^] p = (\<Oplus>i\<in>{..p}. add_pow R (p choose i) (x [^] i \<otimes> y [^] (p - i)))"
	+ by (rule binomial) auto
	+ also have "\<dots> = (\<Oplus>i\<in>{0, p}. add_pow R (p choose i) (x [^] i \<otimes> y [^] (p - i)))"
	+ using * by (intro add.finprod_mono_neutral_cong_right) auto
	+ also have "\<dots> = x [^] p \<oplus> y [^] p"
	+ using assms prime_gt_0_nat[of p] by (simp add: cring_simprules)
	+ finally show ?thesis .
	+qed
	+
	+lemma (in ring_hom_cring) hom_add_pow_nat:
	+ "x \<in> carrier R \<Longrightarrow> h (add_pow R (n::nat) x) = add_pow S n (h x)"
	+ by (induction n) auto
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Mersenne_Primes/Lucas_Lehmer_Code.thy b/thys/Mersenne_Primes/Lucas_Lehmer_Code.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Mersenne_Primes/Lucas_Lehmer_Code.thy
	@@ -0,0 +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"
	+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 = (k AND ((1 << n) - 1)) + (k >> n)"
	+ by (simp add: mersenne_mod_def shiftr_int_def shiftl_int_def AND_mod)
	+
	+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 = (1 << p) - 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 = (1 << p) - 1))"
	+ by (simp add: shiftl_int_def Let_def)
	+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/Mersenne_Primes/ROOT b/thys/Mersenne_Primes/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Mersenne_Primes/ROOT
	@@ -0,0 +1,15 @@
	+chapter AFP
	+
	+session Mersenne_Primes (AFP) = "HOL-Algebra" +
	+ options [timeout = 1200]
	+ sessions
	+ "HOL-Library"
	+ Pell
	+ Native_Word
	+ Probabilistic_Prime_Tests
	+ theories
	+ Lucas_Lehmer_Code
	+ document_files
	+ "root.tex"
	+ "root.bib"
	+
	diff --git a/thys/Mersenne_Primes/document/root.bib b/thys/Mersenne_Primes/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Mersenne_Primes/document/root.bib
	@@ -0,0 +1,42 @@
	+@misc{wiki:mersenne,
	+ author = "{Wikipedia contributors}",
	+ title = "{M}ersenne prime --- {W}ikipedia{,} The Free Encyclopedia",
	+ year = "2020",
	+ url = "https://en.wikipedia.org/w/index.php?title=Mersenne_prime&oldid=934998572",
	+ note = "[Online; accessed 17 Jan 2020]"
	+}
	+
	+@misc{wiki:lucas_lehmer,
	+ author = "{Wikipedia contributors}",
	+ title = "{L}ucas--{L}ehmer primality test --- {W}ikipedia{,} The Free Encyclopedia",
	+ year = "2020",
	+ url = "https://en.wikipedia.org/w/index.php?title=Lucas%E2%80%93Lehmer_primality_test&oldid=927504420",
	+ note = "[Online; accessed 17 Jan 2020]"
	+}
	+
	+@article{bruce93,
	+ ISSN = {00029890, 19300972},
	+ author = {J. W. Bruce},
	+ journal = {The American Mathematical Monthly},
	+ number = {4},
	+ pages = {370--371},
	+ publisher = {Mathematical Association of America},
	+ title = {A Really Trivial Proof of the {L}ucas-{L}ehmer Test},
	+ volume = {100},
	+ year = {1993}
	+}
	+
	+@Article{roedseth94,
	+author="R{\"o}dseth, {\"O}. J.",
	+title="A note on primality tests for $N = h\cdot 2^n - 1$",
	+journal="BIT Numerical Mathematics",
	+year="1994",
	+month="Sep",
	+day="01",
	+volume="34",
	+number="3",
	+pages="451--454",
	+issn="1572-9125",
	+doi="10.1007/BF01935653",
	+}
	+
	diff --git a/thys/Mersenne_Primes/document/root.tex b/thys/Mersenne_Primes/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Mersenne_Primes/document/root.tex
	@@ -0,0 +1,38 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage{isabelle,isabellesym}
	+\usepackage{amsfonts, 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{Mersenne primes and the Lucas--Lehmer test}
	+\author{Manuel Eberl}
	+\maketitle
	+
	+\begin{abstract}
	+This article provides formal proofs of basic properties of Mersenne numbers, i.\,e.\ numbers of the form $2^n - 1$, and especially of Mersenne primes.
	+In particular, an efficient, verified, and executable version of the Lucas--Lehmer test is developed. This test decides primality for Mersenne numbers in
	+time polynomial in $n$.
	+\end{abstract}
	+
	+\tableofcontents
	+\newpage
	+\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/Poincare_Disc/Hyperbolic_Functions.thy b/thys/Poincare_Disc/Hyperbolic_Functions.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Hyperbolic_Functions.thy
	@@ -0,0 +1,187 @@
	+section \<open>Introduction\<close>
	+
	+text\<open>Poincar\'e disc is a model of hyperbolic geometry. That fact has been
	+a mathematical folklore for more than 100 years. However, up to the
	+best of our knowledge, fully precise, formal proofs of this fact are
	+lacking. In this paper we present a formalization of the Poincar\'e disc model
	+in Isabelle/HOL, introduce its basic notions (h-points, h-lines,
	+h-congruence, h-isometries, h-betweenness) and prove that it models
	+Tarski's axioms except for Euclid's axiom. We shown that is satisfies
	+the negation of Euclid's axiom, and, moreover, the existence of
	+limiting parallels axiom. The model is defined within the extended
	+complex plane, which has been described quite precisely by
	+Schwerdfeger~\cite{schwerdtfeger} and formalized in the previous work
	+of the first two authors~\cite{amai-complexplane}.\<close>
	+
	+paragraph \<open>Related work.\<close>
	+
	+text\<open>In 1840 Lobachevsky~\cite{lobachevsky1840geometrische} published developments
	+about non-Euclidean geometry. Hyperbolic
	+geometry is studied through many of its models. The concept of a
	+projective disc model was introduced by Klein while Poincar\'e
	+investigated the half-plane model proposed by Liouville and Beltrami
	+and primarily studied the isometries of the hyperbolic plane that
	+preserve orientation. In this paper, we focus on the formalization of
	+the latter.
	+
	+Regarding non-Euclidean geometry, Makarios showed the
	+independence of Euclid's axiom~\cite{makarios}. He did so by
	+formalizing that the Klein--Beltrami model is a model of Tarski's
	+axioms at the exception of Euclid's axiom. Latter Coghetto formalized
	+the Klein-Beltrami model within Mizar~\cite{coghetto2018klein1,coghetto2018klein2}.
	+\<close>
	+
	+section \<open>Background theories\<close>
	+
	+subsection\<open>Hyperbolic Functions\<close>
	+
	+text \<open>In this section hyperbolic cosine and hyperbolic sine functions are introduced and some of their
	+properties needed for further development are proved.\<close>
	+
	+theory Hyperbolic_Functions
	+ imports Complex_Main Complex_Geometry.More_Complex
	+begin
	+
	+lemma cosh_arcosh [simp]:
	+ fixes x :: real
	+ assumes "x \<ge> 1"
	+ shows "cosh (arcosh x) = x"
	+proof-
	+ from assms
	+ have **: "x + sqrt(x\<^sup>2 - 1) \<ge> 1"
	+ by (smt one_le_power real_sqrt_ge_zero)
	+ hence *: "x + sqrt(x\<^sup>2 - 1) \<noteq> 0"
	+ by simp
	+ moreover
	+ have "sqrt (x\<^sup>2 - 1) + 1 / (x + sqrt (x\<^sup>2 - 1)) = x" (is "?lhs = x")
	+ proof-
	+ have "?lhs = (x*sqrt(x\<^sup>2 - 1) + x\<^sup>2) / (x + sqrt(x\<^sup>2 - 1))"
	+ using * \<open>x \<ge> 1\<close>
	+ by (subst add_divide_eq_iff, simp, simp add: field_simps)
	+ also have "... = x * (sqrt(x\<^sup>2 - 1) + x) / (x + sqrt(x\<^sup>2 - 1))"
	+ by (simp add: field_simps power2_eq_square)
	+ finally
	+ show ?thesis
	+ using nonzero_mult_div_cancel_right[OF *, of x]
	+ by (simp add: field_simps)
	+ qed
	+ thus ?thesis
	+ using arcosh_real_def[OF assms(1)]
	+ unfolding cosh_def
	+ using ln_div[of 1, symmetric] **
	+ by auto
	+qed
	+
	+
	+lemma arcosh_ge_0 [simp]:
	+ fixes x::real
	+ assumes "x \<ge> 1"
	+ shows "arcosh x \<ge> 0"
	+ by (smt arcosh_def assms ln_ge_zero powr_ge_pzero)
	+
	+lemma arcosh_eq_0_iff:
	+ fixes x::real
	+ assumes "x \<ge> 1"
	+ shows "arcosh x = 0 \<longleftrightarrow> x = 1"
	+ using assms
	+ using cosh_arcosh by fastforce
	+
	+lemma arcosh_eq_iff:
	+ fixes x y::real
	+ assumes "x \<ge> 1" "y \<ge> 1"
	+ shows "arcosh x = arcosh y \<longleftrightarrow> x = y"
	+ using assms
	+ using cosh_arcosh by fastforce
	+
	+
	+lemma cosh_gt_1 [simp]:
	+ fixes x ::real
	+ assumes "x > 0"
	+ shows "cosh x > 1"
	+ using assms cosh_real_strict_mono by force
	+
	+
	+lemma cosh_eq_iff:
	+ fixes x y::real
	+ assumes "x \<ge> 0" "y \<ge> 0"
	+ shows "cosh x = cosh y \<longleftrightarrow> x = y"
	+ by (simp add: assms(1) assms(2))
	+
	+
	+lemma arcosh_mono:
	+ fixes x y::real
	+ assumes "x \<ge> 1" "y \<ge> 1"
	+ shows "arcosh x \<ge> arcosh y \<longleftrightarrow> x \<ge> y"
	+ using assms
	+ by (smt arcosh_ge_0 cosh_arcosh cosh_real_nonneg_less_iff)
	+
	+
	+lemma arcosh_add:
	+ fixes x y::real
	+ assumes "x \<ge> 1" "y \<ge> 1"
	+ shows "arcosh x + arcosh y = arcosh (xy + sqrt((x\<^sup>2 - 1)(y\<^sup>2 - 1)))"
	+proof-
	+ have "sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)) \<ge> 0"
	+ using assms
	+ by simp
	+ moreover
	+ have "x * y \<ge> 1"
	+ using assms
	+ by (smt mult_le_cancel_left1)
	+ ultimately
	+ have *: "x y + sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)) \<ge> 1"
	+ by linarith
	+ hence 1: "0 \<le> (x * y + sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)))\<^sup>2 - 1"
	+ by simp
	+
	+ have 2: "x * sqrt (y\<^sup>2 - 1) + y * sqrt (x\<^sup>2 - 1) \<ge> 0"
	+ using assms
	+ by simp
	+
	+ have "(xsqrt(y\<^sup>2 - 1)+ysqrt(x\<^sup>2 -1))\<^sup>2 = (sqrt((xy+sqrt((x\<^sup>2-1)(y\<^sup>2-1)))\<^sup>2 - 1))\<^sup>2"
	+ using assms
	+ proof (subst real_sqrt_pow2)
	+ show "0 \<le> (x * y + sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)))\<^sup>2 - 1"
	+ by fact
	+ next
	+ have "(x * sqrt (y\<^sup>2 - 1))\<^sup>2 = x\<^sup>2 * (y\<^sup>2 - 1)"
	+ using assms
	+ apply (subst power_mult_distrib)
	+ apply (subst real_sqrt_pow2, simp_all)
	+ done
	+ moreover
	+ have "(y * sqrt (x\<^sup>2 - 1))\<^sup>2 = y\<^sup>2 * (x\<^sup>2 - 1)"
	+ using assms
	+ apply (subst power_mult_distrib)
	+ apply (subst real_sqrt_pow2, simp_all)
	+ done
	+ ultimately show "(x * sqrt (y\<^sup>2 - 1) + y * sqrt (x\<^sup>2 - 1))\<^sup>2 = (x * y + sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)))\<^sup>2 - 1"
	+ using assms
	+ unfolding power2_sum
	+ apply (simp add: real_sqrt_mult power_mult_distrib)
	+ apply (simp add: field_simps)
	+ done
	+ qed
	+ hence "sqrt ((x * y + sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)))\<^sup>2 - 1) = x * sqrt (y\<^sup>2 - 1) + y * sqrt (x\<^sup>2 - 1)"
	+ using power2_eq_iff_nonneg[OF 2 real_sqrt_ge_zero[OF 1]]
	+ by simp
	+ thus ?thesis
	+ using assms
	+ apply (subst arcosh_real_def[OF assms(1)])
	+ apply (subst arcosh_real_def[OF assms(2)])
	+ apply (subst arcosh_real_def[OF **])
	+ apply (subst ln_mult[symmetric])
	+ apply (smt one_le_power real_sqrt_ge_zero)
	+ apply (smt one_le_power real_sqrt_ge_zero)
	+ apply (simp add: real_sqrt_mult)
	+ apply (simp add: field_simps)
	+ done
	+qed
	+
	+lemma arcosh_double:
	+ fixes x :: real
	+ assumes "x \<ge> 1"
	+ shows "2 * arcosh x = arcosh (2*x\<^sup>2 - 1)"
	+ by (smt arcosh_add arcosh_mono assms one_power2 power2_eq_square real_sqrt_abs)
	+
	+end
	diff --git a/thys/Poincare_Disc/Poincare.thy b/thys/Poincare_Disc/Poincare.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Poincare.thy
	@@ -0,0 +1,210 @@
	+section\<open>Poincar\'e disc model types\<close>
	+
	+text \<open>In this section we introduce datatypes that represent objects in the Poincar\'e disc model.
	+The types are defined as subtypes (e.g., the h-points are defined as elements of $\mathbb{C}P^1$
	+that lie within the unit disc). The functions on those types are defined by lifting the functions
	+defined on the carrier type (e.g., h-distance is defined by lifting the distance function defined
	+for elements of $\mathbb{C}P^1$).\<close>
	+
	+theory Poincare
	+imports Poincare_Lines Poincare_Between Poincare_Distance Poincare_Circles
	+begin
	+
	+(* ------------------------------------------------------------------ *)
	+subsection \<open>H-points\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+typedef p_point = "{z. z \<in> unit_disc}"
	+ using zero_in_unit_disc
	+ by (rule_tac x="0\<^sub>h" in exI, simp)
	+
	+setup_lifting type_definition_p_point
	+
	+text \<open>Point zero\<close>
	+lift_definition p_zero :: "p_point" is "0\<^sub>h"
	+ by (rule zero_in_unit_disc)
	+
	+text \<open>Constructing h-points from complex numbers\<close>
	+lift_definition p_of_complex :: "complex \<Rightarrow> p_point" is "\<lambda> z. if cmod z < 1 then of_complex z else 0\<^sub>h"
	+ by auto
	+
	+(* ------------------------------------------------------------------ *)
	+subsection \<open>H-lines\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+typedef p_line = "{H. is_poincare_line H}"
	+ by (rule_tac x="x_axis" in exI, simp)
	+
	+setup_lifting type_definition_p_line
	+
	+lift_definition p_incident :: "p_line \<Rightarrow> p_point \<Rightarrow> bool" is on_circline
	+ done
	+
	+text \<open>Set of h-points on an h-line\<close>
	+definition p_points :: "p_line \<Rightarrow> p_point set" where
	+ "p_points l = {p. p_incident l p}"
	+
	+text \<open>x-axis is an example of an h-line\<close>
	+lift_definition p_x_axis :: "p_line" is x_axis
	+ by simp
	+
	+text \<open>Constructing the unique h-line from two h-points\<close>
	+lift_definition p_line :: "p_point \<Rightarrow> p_point \<Rightarrow> p_line" is poincare_line
	+proof-
	+ fix u v
	+ show "is_poincare_line (poincare_line u v)"
	+ proof (cases "u \<noteq> v")
	+ case True
	+ thus ?thesis
	+ by simp
	+ next
	+ text\<open>This branch must work only for formal reasons.\<close>
	+ case False
	+ thus ?thesis
	+ by (transfer, transfer, auto simp add: hermitean_def mat_adj_def mat_cnj_def split: if_split_asm)
	+ qed
	+qed
	+
	+text \<open>Next we show how to lift some lemmas. This could be done for all the lemmas that we have
	+proved earlier, but we do not do that.\<close>
	+
	+text \<open>If points are different then the constructed line contains the starting points\<close>
	+lemma p_on_line:
	+ assumes "z \<noteq> w"
	+ shows "p_incident (p_line z w) z"
	+ "p_incident (p_line z w) w"
	+ using assms
	+ by (transfer, simp)+
	+
	+text \<open>There is a unique h-line passing trough the two different given h-points\<close>
	+lemma
	+ assumes "u \<noteq> v"
	+ shows "\<exists>! l. {u, v} \<subseteq> p_points l"
	+ using assms
	+ apply (rule_tac a="p_line u v" in ex1I, auto simp add: p_points_def p_on_line)
	+ apply (transfer, simp add: unique_poincare_line)
	+ done
	+
	+text \<open>The unique h-line trough zero and a non-zero h-point on the x-axis is the x-axis\<close>
	+lemma
	+ assumes "p_zero \<in> p_points l" "u \<in> p_points l" "u \<noteq> p_zero" "u \<in> p_points p_x_axis"
	+ shows "l = p_x_axis"
	+ using assms
	+ unfolding p_points_def
	+ apply simp
	+ apply transfer
	+ using is_poincare_line_0_real_is_x_axis inf_notin_unit_disc
	+ unfolding circline_set_def
	+ by blast
	+
	+(* ------------------------------------------------------------------ *)
	+subsection \<open>H-collinearity\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lift_definition p_collinear :: "p_point set \<Rightarrow> bool" is poincare_collinear
	+ done
	+
	+(* ------------------------------------------------------------------ *)
	+subsection \<open>H-isometries\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text \<open>H-isometries are functions that map the unit disc onto itself\<close>
	+typedef p_isometry = "{f. unit_disc_fix_f f}"
	+ by (rule_tac x="id" in exI, simp add: unit_disc_fix_f_def, rule_tac x="id_moebius" in exI, simp)
	+
	+setup_lifting type_definition_p_isometry
	+
	+text \<open>Action of an h-isometry on an h-point\<close>
	+lift_definition p_isometry_pt :: "p_isometry \<Rightarrow> p_point \<Rightarrow> p_point" is "\<lambda> f p. f p"
	+ using unit_disc_fix_f_unit_disc
	+ by auto
	+
	+text \<open>Action of an h-isometry on an h-line\<close>
	+lift_definition p_isometry_line :: "p_isometry \<Rightarrow> p_line \<Rightarrow> p_line" is "\<lambda> f l. unit_disc_fix_f_circline f l"
	+proof-
	+ fix f H
	+ assume "unit_disc_fix_f f" "is_poincare_line H"
	+ then obtain M where "unit_disc_fix M" and *: "f = moebius_pt M \<or> f = moebius_pt M \<circ> conjugate"
	+ unfolding unit_disc_fix_f_def
	+ by auto
	+ show "is_poincare_line (unit_disc_fix_f_circline f H)"
	+ using *
	+ proof
	+ assume "f = moebius_pt M"
	+ thus ?thesis
	+ using \<open>unit_disc_fix M\<close> \<open>is_poincare_line H\<close>
	+ using unit_disc_fix_f_circline_direct[of M f H]
	+ by auto
	+ next
	+ assume "f = moebius_pt M \<circ> conjugate"
	+ thus ?thesis
	+ using \<open>unit_disc_fix M\<close> \<open>is_poincare_line H\<close>
	+ using unit_disc_fix_f_circline_indirect[of M f H]
	+ by auto
	+ qed
	+qed
	+
	+text \<open>An example lemma about h-isometries.\<close>
	+
	+text \<open>H-isometries preserve h-collinearity\<close>
	+lemma p_collinear_p_isometry_pt [simp]:
	+ shows "p_collinear (p_isometry_pt M ` A) \<longleftrightarrow> p_collinear A"
	+proof-
	+ have *: "\<forall> M A. ((\<lambda>x. moebius_pt M (conjugate x)) ` A = moebius_pt M ` (conjugate ` A))"
	+ by auto
	+ show ?thesis
	+ by transfer (auto simp add: unit_disc_fix_f_def *)
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection \<open>H-distance and h-congruence\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lift_definition p_dist :: "p_point \<Rightarrow> p_point \<Rightarrow> real" is poincare_distance
	+ done
	+
	+definition p_congruent :: "p_point \<Rightarrow> p_point \<Rightarrow> p_point \<Rightarrow> p_point \<Rightarrow> bool" where
	+ [simp]: "p_congruent u v u' v' \<longleftrightarrow> p_dist u v = p_dist u' v'"
	+
	+lemma
	+ assumes "p_dist u v = p_dist u' v'"
	+ assumes "p_dist v w = p_dist v' w'"
	+ assumes "p_dist u w = p_dist u' w'"
	+ shows "\<exists> f. p_isometry_pt f u = u' \<and> p_isometry_pt f v = v' \<and> p_isometry_pt f w = w'"
	+ using assms
	+ apply transfer
	+ using unit_disc_fix_f_congruent_triangles
	+ by auto
	+
	+text\<open>We prove that unit disc equipped with Poincar\'e distance is a metric space, i.e. an
	+instantiation of @{term metric_space} locale.\<close>
	+
	+instantiation p_point :: metric_space
	+begin
	+definition "dist_p_point = p_dist"
	+definition "(uniformity_p_point :: (p_point \<times> p_point) filter) = (INF e:{0<..}. principal {(x, y). dist_class.dist x y < e})"
	+definition "open_p_point (U :: p_point set) = (\<forall> x \<in> U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"
	+instance
	+proof
	+ fix x y :: p_point
	+ show "(dist_class.dist x y = 0) = (x = y)"
	+ unfolding dist_p_point_def
	+ by (transfer, simp add: poincare_distance_eq_0_iff)
	+next
	+ fix x y z :: p_point
	+ show "dist_class.dist x y \<le> dist_class.dist x z + dist_class.dist y z"
	+ unfolding dist_p_point_def
	+ apply transfer
	+ using poincare_distance_triangle_inequality poincare_distance_sym
	+ by metis
	+qed (simp_all add: open_p_point_def uniformity_p_point_def)
	+end
	+
	+(* ------------------------------------------------------------------ *)
	+subsection \<open>H-betweennes\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lift_definition p_between :: "p_point \<Rightarrow> p_point \<Rightarrow> p_point \<Rightarrow> bool" is poincare_between
	+ done
	+
	+end
	diff --git a/thys/Poincare_Disc/Poincare_Between.thy b/thys/Poincare_Disc/Poincare_Between.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Poincare_Between.thy
	@@ -0,0 +1,1263 @@
	+theory Poincare_Between
	+ imports Poincare_Distance
	+begin
	+
	+(* ------------------------------------------------------------------ *)
	+section\<open>H-betweenness in the Poincar\'e model\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+subsection \<open>H-betwenness expressed by a cross-ratio\<close>
	+
	+text\<open>The point $v$ is h-between $u$ and $w$ if the cross-ratio between the pairs $u$ and $w$ and $v$
	+and inverse of $v$ is real and negative.\<close>
	+definition poincare_between :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo \<Rightarrow> bool" where
	+ "poincare_between u v w \<longleftrightarrow>
	+ u = v \<or> v = w \<or>
	+ (let cr = cross_ratio u v w (inversion v)
	+ in is_real (to_complex cr) \<and> Re (to_complex cr) < 0)"
	+
	+subsubsection \<open>H-betwenness is preserved by h-isometries\<close>
	+
	+text \<open>Since they preserve cross-ratio and inversion, h-isometries (unit disc preserving Möbius
	+transformations and conjugation) preserve h-betweeness.\<close>
	+
	+lemma unit_disc_fix_moebius_preserve_poincare_between [simp]:
	+ assumes "unit_disc_fix M" and "u \<in> unit_disc" and "v \<in> unit_disc" and "w \<in> unit_disc"
	+ shows "poincare_between (moebius_pt M u) (moebius_pt M v) (moebius_pt M w) \<longleftrightarrow>
	+ poincare_between u v w"
	+proof (cases "u = v \<or> v = w")
	+ case True
	+ thus ?thesis
	+ using assms
	+ unfolding poincare_between_def
	+ by auto
	+next
	+ case False
	+ moreover
	+ hence "moebius_pt M u \<noteq> moebius_pt M v \<and> moebius_pt M v \<noteq> moebius_pt M w"
	+ by auto
	+ moreover
	+ have "v \<noteq> inversion v" "w \<noteq> inversion v"
	+ using inversion_noteq_unit_disc[of v w]
	+ using inversion_noteq_unit_disc[of v v]
	+ using \<open>v \<in> unit_disc\<close> \<open>w \<in> unit_disc\<close>
	+ by auto
	+ ultimately
	+ show ?thesis
	+ using assms
	+ using unit_circle_fix_moebius_pt_inversion[of M v, symmetric]
	+ unfolding poincare_between_def
	+ by (simp del: unit_circle_fix_moebius_pt_inversion)
	+qed
	+
	+lemma conjugate_preserve_poincare_between [simp]:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "w \<in> unit_disc"
	+ shows "poincare_between (conjugate u) (conjugate v) (conjugate w) \<longleftrightarrow>
	+ poincare_between u v w"
	+proof (cases "u = v \<or> v = w")
	+ case True
	+ thus ?thesis
	+ using assms
	+ unfolding poincare_between_def
	+ by auto
	+next
	+ case False
	+ moreover
	+ hence "conjugate u \<noteq> conjugate v \<and> conjugate v \<noteq> conjugate w"
	+ using conjugate_inj by blast
	+ moreover
	+ have "v \<noteq> inversion v" "w \<noteq> inversion v"
	+ using inversion_noteq_unit_disc[of v w]
	+ using inversion_noteq_unit_disc[of v v]
	+ using \<open>v \<in> unit_disc\<close> \<open>w \<in> unit_disc\<close>
	+ by auto
	+ ultimately
	+ show ?thesis
	+ using assms
	+ using conjugate_cross_ratio[of v w "inversion v" u]
	+ unfolding poincare_between_def
	+ by (metis conjugate_id_iff conjugate_involution inversion_def inversion_sym o_apply)
	+qed
	+
	+
	+subsubsection \<open>Some elementary properties of h-betwenness\<close>
	+
	+lemma poincare_between_nonstrict [simp]:
	+ shows "poincare_between u u v" and "poincare_between u v v"
	+ by (simp_all add: poincare_between_def)
	+
	+lemma poincare_between_sandwich:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ assumes "poincare_between u v u"
	+ shows "u = v"
	+proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ thus False
	+ using assms
	+ using inversion_noteq_unit_disc[of v u]
	+ using cross_ratio_1[of v u "inversion v"]
	+ unfolding poincare_between_def Let_def
	+ by auto
	+qed
	+
	+lemma poincare_between_rev:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "w \<in> unit_disc"
	+ shows "poincare_between u v w \<longleftrightarrow> poincare_between w v u"
	+ using assms
	+ using inversion_noteq_unit_disc[of v w]
	+ using inversion_noteq_unit_disc[of v u]
	+ using cross_ratio_commute_13[of u v w "inversion v"]
	+ using cross_ratio_not_inf[of w "inversion v" v u]
	+ using cross_ratio_not_zero[of w v u "inversion v"]
	+ using inf_or_of_complex[of "cross_ratio w v u (inversion v)"]
	+ unfolding poincare_between_def
	+ by (auto simp add: Let_def Im_complex_div_eq_0 Re_divide divide_less_0_iff)
	+
	+subsubsection \<open>H-betwenness and h-collinearity\<close>
	+
	+text\<open>Three points can be in an h-between relation only when they are h-collinear.\<close>
	+lemma poincare_between_poincare_collinear [simp]:
	+ assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
	+ assumes betw: "poincare_between u v w"
	+ shows "poincare_collinear {u, v, w}"
	+proof (cases "u = v \<or> v = w")
	+ case True
	+ thus ?thesis
	+ using assms
	+ by auto
	+next
	+ case False
	+ hence distinct: "distinct [u, v, w, inversion v]"
	+ using in_disc inversion_noteq_unit_disc[of v v] inversion_noteq_unit_disc[of v u] inversion_noteq_unit_disc[of v w]
	+ using betw poincare_between_sandwich[of w v]
	+ by (auto simp add: poincare_between_def Let_def)
	+
	+ then obtain H where *: "{u, v, w, inversion v} \<subseteq> circline_set H"
	+ using assms
	+ unfolding poincare_between_def
	+ using four_points_on_circline_iff_cross_ratio_real[of u v w "inversion v"]
	+ by auto
	+ hence "H = poincare_line u v"
	+ using assms distinct
	+ using unique_circline_set[of u v "inversion v"]
	+ using poincare_line[of u v] poincare_line_inversion[of u v]
	+ unfolding circline_set_def
	+ by auto
	+ thus ?thesis
	+ using * assms False
	+ unfolding poincare_collinear_def
	+ by (rule_tac x="poincare_line u v" in exI) simp
	+qed
	+
	+lemma poincare_between_poincare_line_uvz:
	+ assumes "u \<noteq> v" and "u \<in> unit_disc" and "v \<in> unit_disc" and
	+ "z \<in> unit_disc" and "poincare_between u v z"
	+ shows "z \<in> circline_set (poincare_line u v)"
	+ using assms
	+ using poincare_between_poincare_collinear[of u v z]
	+ using unique_poincare_line[OF assms(1-3)]
	+ unfolding poincare_collinear_def
	+ by auto
	+
	+lemma poincare_between_poincare_line_uzv:
	+ assumes "u \<noteq> v" and "u \<in> unit_disc" and "v \<in> unit_disc" and
	+ "z \<in> unit_disc" "poincare_between u z v"
	+ shows "z \<in> circline_set (poincare_line u v)"
	+ using assms
	+ using poincare_between_poincare_collinear[of u z v]
	+ using unique_poincare_line[OF assms(1-3)]
	+ unfolding poincare_collinear_def
	+ by auto
	+
	+subsubsection \<open>H-betweeness on Euclidean segments\<close>
	+
	+text\<open>If the three points lie on an h-line that is a Euclidean line (e.g., if it contains zero),
	+h-betweenness can be characterized much simpler than in the definition.\<close>
	+
	+lemma poincare_between_x_axis_u0v:
	+ assumes "is_real u'" and "u' \<noteq> 0" and "v' \<noteq> 0"
	+ shows "poincare_between (of_complex u') 0\<^sub>h (of_complex v') \<longleftrightarrow> is_real v' \<and> Re u' * Re v' < 0"
	+proof-
	+ have "Re u' \<noteq> 0"
	+ using \<open>is_real u'\<close> \<open>u' \<noteq> 0\<close>
	+ using complex_eq_if_Re_eq
	+ by auto
	+ have nz: "of_complex u' \<noteq> 0\<^sub>h" "of_complex v' \<noteq> 0\<^sub>h"
	+ by (simp_all add: \<open>u' \<noteq> 0\<close> \<open>v' \<noteq> 0\<close>)
	+ hence "0\<^sub>h \<noteq> of_complex v'"
	+ by metis
	+
	+ let ?cr = "cross_ratio (of_complex u') 0\<^sub>h (of_complex v') \<infinity>\<^sub>h"
	+ have "is_real (to_complex ?cr) \<and> Re (to_complex ?cr) < 0 \<longleftrightarrow> is_real v' \<and> Re u' * Re v' < 0"
	+ using cross_ratio_0inf[of v' u'] \<open>v' \<noteq> 0\<close> \<open>u' \<noteq> 0\<close> \<open>is_real u'\<close>
	+ by (metis Re_complex_div_lt_0 Re_mult_real complex_cnj_divide divide_cancel_left eq_cnj_iff_real to_complex_of_complex)
	+ thus ?thesis
	+ unfolding poincare_between_def inversion_zero
	+ using \<open>of_complex u' \<noteq> 0\<^sub>h\<close> \<open>0\<^sub>h \<noteq> of_complex v'\<close>
	+ by simp
	+qed
	+
	+lemma poincare_between_u0v:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "u \<noteq> 0\<^sub>h" and "v \<noteq> 0\<^sub>h"
	+ shows "poincare_between u 0\<^sub>h v \<longleftrightarrow> (\<exists> k < 0. to_complex u = cor k * to_complex v)" (is "?P u v")
	+proof (cases "u = v")
	+ case True
	+ thus ?thesis
	+ using assms
	+ using inf_or_of_complex[of v]
	+ using poincare_between_sandwich[of u "0\<^sub>h"]
	+ by auto
	+next
	+ case False
	+ have "\<forall> u. u \<in> unit_disc \<and> u \<noteq> 0\<^sub>h \<longrightarrow> ?P u v" (is "?P' v")
	+ proof (rule wlog_rotation_to_positive_x_axis)
	+ fix \<phi> v
	+ let ?M = "moebius_pt (moebius_rotation \<phi>)"
	+ assume 1: "v \<in> unit_disc" "v \<noteq> 0\<^sub>h"
	+ assume 2: "?P' (?M v)"
	+ show "?P' v"
	+ proof (rule allI, rule impI, (erule conjE)+)
	+ fix u
	+ assume 3: "u \<in> unit_disc" "u \<noteq> 0\<^sub>h"
	+ have "poincare_between (?M u) 0\<^sub>h (?M v) \<longleftrightarrow> poincare_between u 0\<^sub>h v"
	+ using \<open>u \<in> unit_disc\<close> \<open>v \<in> unit_disc\<close>
	+ using unit_disc_fix_moebius_preserve_poincare_between unit_disc_fix_rotation zero_in_unit_disc
	+ by fastforce
	+ thus "?P u v"
	+ using 1 2[rule_format, of "?M u"] 3
	+ using inf_or_of_complex[of u] inf_or_of_complex[of v]
	+ by auto
	+ qed
	+ next
	+ fix x
	+ assume 1: "is_real x" "0 < Re x" "Re x < 1"
	+ hence "x \<noteq> 0"
	+ by auto
	+ show "?P' (of_complex x)"
	+ proof (rule allI, rule impI, (erule conjE)+)
	+ fix u
	+ assume 2: "u \<in> unit_disc" "u \<noteq> 0\<^sub>h"
	+ then obtain u' where "u = of_complex u'"
	+ using inf_or_of_complex[of u]
	+ by auto
	+ show "?P u (of_complex x)"
	+ using 1 2 \<open>x \<noteq> 0\<close> \<open>u = of_complex u'\<close>
	+ using poincare_between_rev[of u "0\<^sub>h" "of_complex x"]
	+ using poincare_between_x_axis_u0v[of x u'] \<open>is_real x\<close>
	+ apply (auto simp add: cmod_eq_Re)
	+ apply (rule_tac x="Re u' / Re x" in exI, simp add: divide_neg_pos sign_simps)
	+ using mult_neg_pos mult_pos_neg
	+ by blast
	+ qed
	+ qed fact+
	+ thus ?thesis
	+ using assms
	+ by auto
	+qed
	+
	+lemma poincare_between_u0v_polar_form:
	+ assumes "x \<in> unit_disc" and "y \<in> unit_disc" and "x \<noteq> 0\<^sub>h" and "y \<noteq> 0\<^sub>h" and
	+ "to_complex x = cor rx * cis \<phi>" "to_complex y = cor ry * cis \<phi>"
	+ shows "poincare_between x 0\<^sub>h y \<longleftrightarrow> rx * ry < 0" (is "?P x y rx ry")
	+proof-
	+ from assms have "rx \<noteq> 0" "ry \<noteq> 0"
	+ using inf_or_of_complex[of x] inf_or_of_complex[of y]
	+ by auto
	+
	+ have "(\<exists>k<0. cor rx = cor k * cor ry ) = (rx * ry < 0)"
	+ proof
	+ assume "\<exists>k<0. cor rx = cor k * cor ry"
	+ then obtain k where "k < 0" "cor rx = cor k * cor ry"
	+ by auto
	+ hence "rx = k * ry"
	+ using of_real_eq_iff
	+ by fastforce
	+ thus "rx * ry < 0"
	+ using \<open>k < 0\<close> \<open>rx \<noteq> 0\<close> \<open>ry \<noteq> 0\<close>
	+ by (smt divisors_zero mult_nonneg_nonpos mult_nonpos_nonpos zero_less_mult_pos2)
	+ next
	+ assume "rx * ry < 0"
	+ hence "rx = (rx/ry)*ry" "rx / ry < 0"
	+ using \<open>rx \<noteq> 0\<close> \<open>ry \<noteq> 0\<close>
	+ by (auto simp add: divide_less_0_iff sign_simps)
	+ thus "\<exists>k<0. cor rx = cor k * cor ry"
	+ using \<open>rx \<noteq> 0\<close> \<open>ry \<noteq> 0\<close>
	+ by (rule_tac x="rx / ry" in exI, simp)
	+ qed
	+ thus ?thesis
	+ using assms
	+ using poincare_between_u0v[OF assms(1-4)]
	+ by auto
	+qed
	+
	+lemma poincare_between_x_axis_0uv:
	+ fixes x y :: real
	+ assumes "-1 < x" and "x < 1" and "x \<noteq> 0"
	+ assumes "-1 < y" and "y < 1" and "y \<noteq> 0"
	+ shows "poincare_between 0\<^sub>h (of_complex x) (of_complex y) \<longleftrightarrow>
	+ (x < 0 \<and> y < 0 \<and> y \<le> x) \<or> (x > 0 \<and> y > 0 \<and> x \<le> y)" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof (cases "x = y")
	+ case True
	+ thus ?thesis
	+ using assms
	+ unfolding poincare_between_def
	+ by auto
	+next
	+ case False
	+ let ?x = "of_complex x" and ?y = "of_complex y"
	+
	+ have "?x \<in> unit_disc" "?y \<in> unit_disc"
	+ using assms
	+ by auto
	+
	+ have distinct: "distinct [0\<^sub>h, ?x, ?y, inversion ?x]"
	+ using \<open>x \<noteq> 0\<close> \<open>y \<noteq> 0\<close> \<open>x \<noteq> y\<close> \<open>?x \<in> unit_disc\<close> \<open>?y \<in> unit_disc\<close>
	+ using inversion_noteq_unit_disc[of ?x ?y]
	+ using inversion_noteq_unit_disc[of ?x ?x]
	+ using inversion_noteq_unit_disc[of ?x "0\<^sub>h"]
	+ using of_complex_inj[of x y]
	+ by (metis distinct_length_2_or_more distinct_singleton of_complex_zero_iff of_real_eq_0_iff of_real_eq_iff zero_in_unit_disc)
	+
	+ let ?cr = "cross_ratio 0\<^sub>h ?x ?y (inversion ?x)"
	+ have "Re (to_complex ?cr) = x\<^sup>2 * (xy - 1) / (x (y - x))"
	+ using \<open>x \<noteq> 0\<close> \<open>x \<noteq> y\<close>
	+ unfolding inversion_def
	+ by simp (transfer, transfer, auto simp add: vec_cnj_def power2_eq_square field_simps split: if_split_asm)
	+ moreover
	+ {
	+ fix a b :: real
	+ assume "b \<noteq> 0"
	+ hence "a < 0 \<longleftrightarrow> b\<^sup>2 * a < (0::real)"
	+ by (metis mult.commute mult_eq_0_iff mult_neg_pos mult_pos_pos not_less_iff_gr_or_eq not_real_square_gt_zero power2_eq_square)
	+ }
	+ hence "x\<^sup>2 * (x*y - 1) < 0"
	+ using assms
	+ by (smt minus_mult_minus mult_le_cancel_left1)
	+ moreover
	+ have "x * (y - x) > 0 \<longleftrightarrow> ?rhs"
	+ using \<open>x \<noteq> 0\<close> \<open>y \<noteq> 0\<close> \<open>x \<noteq> y\<close>
	+ by (smt mult_le_0_iff)
	+ ultimately
	+ have *: "Re (to_complex ?cr) < 0 \<longleftrightarrow> ?rhs"
	+ by (simp add: divide_less_0_iff)
	+
	+ show ?thesis
	+ proof
	+ assume ?lhs
	+ have "is_real (to_complex ?cr)" "Re (to_complex ?cr) < 0"
	+ using \<open>?lhs\<close> distinct
	+ unfolding poincare_between_def Let_def
	+ by auto
	+ thus ?rhs
	+ using *
	+ by simp
	+ next
	+ assume ?rhs
	+ hence "Re (to_complex ?cr) < 0"
	+ using *
	+ by simp
	+ moreover
	+ have "{0\<^sub>h, of_complex (cor x), of_complex (cor y), inversion (of_complex (cor x))} \<subseteq> circline_set x_axis"
	+ using \<open>x \<noteq> 0\<close> is_real_inversion[of "cor x"]
	+ using inf_or_of_complex[of "inversion ?x"]
	+ by (auto simp del: inversion_of_complex)
	+ hence "is_real (to_complex ?cr)"
	+ using four_points_on_circline_iff_cross_ratio_real[OF distinct]
	+ by auto
	+ ultimately
	+ show ?lhs
	+ using distinct
	+ unfolding poincare_between_def Let_def
	+ by auto
	+ qed
	+qed
	+
	+lemma poincare_between_0uv:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "u \<noteq> 0\<^sub>h" and "v \<noteq> 0\<^sub>h"
	+ shows "poincare_between 0\<^sub>h u v \<longleftrightarrow>
	+ (let u' = to_complex u; v' = to_complex v in arg u' = arg v' \<and> cmod u' \<le> cmod v')" (is "?P u v")
	+proof (cases "u = v")
	+ case True
	+ thus ?thesis
	+ by simp
	+next
	+ case False
	+ have "\<forall> v. v \<in> unit_disc \<and> v \<noteq> 0\<^sub>h \<and> v \<noteq> u \<longrightarrow> (poincare_between 0\<^sub>h u v \<longleftrightarrow> (let u' = to_complex u; v' = to_complex v in arg u' = arg v' \<and> cmod u' \<le> cmod v'))" (is "?P' u")
	+ proof (rule wlog_rotation_to_positive_x_axis)
	+ show "u \<in> unit_disc" "u \<noteq> 0\<^sub>h"
	+ by fact+
	+ next
	+ fix x
	+ assume *: "is_real x" "0 < Re x" "Re x < 1"
	+ hence "of_complex x \<in> unit_disc" "of_complex x \<noteq> 0\<^sub>h" "of_complex x \<in> circline_set x_axis"
	+ unfolding circline_set_x_axis
	+ by (auto simp add: cmod_eq_Re)
	+ show "?P' (of_complex x)"
	+ proof safe
	+ fix v
	+ assume "v \<in> unit_disc" "v \<noteq> 0\<^sub>h" "v \<noteq> of_complex x" "poincare_between 0\<^sub>h (of_complex x) v"
	+ hence "v \<in> circline_set x_axis"
	+ using poincare_between_poincare_line_uvz[of "0\<^sub>h" "of_complex x" v]
	+ using poincare_line_0_real_is_x_axis[of "of_complex x"]
	+ using \<open>of_complex x \<noteq> 0\<^sub>h\<close> \<open>v \<noteq> 0\<^sub>h\<close> \<open>v \<noteq> of_complex x\<close> \<open>of_complex x \<in> unit_disc\<close> \<open>of_complex x \<in> circline_set x_axis\<close>
	+ by auto
	+ obtain v' where "v = of_complex v'"
	+ using \<open>v \<in> unit_disc\<close>
	+ using inf_or_of_complex[of v]
	+ by auto
	+ hence **: "v = of_complex v'" "-1 < Re v'" "Re v' < 1" "Re v' \<noteq> 0" "is_real v'"
	+ using \<open>v \<in> unit_disc\<close> \<open>v \<noteq> 0\<^sub>h\<close> \<open>v \<in> circline_set x_axis\<close> of_complex_inj[of v']
	+ unfolding circline_set_x_axis
	+ by (auto simp add: cmod_eq_Re real_imag_0)
	+ show "let u' = to_complex (of_complex x); v' = to_complex v in arg u' = arg v' \<and> cmod u' \<le> cmod v'"
	+ using poincare_between_x_axis_0uv[of "Re x" "Re v'"] * **
	+ using \<open>poincare_between 0\<^sub>h (of_complex x) v\<close>
	+ using arg_complex_of_real_positive[of "Re x"] arg_complex_of_real_negative[of "Re x"]
	+ using arg_complex_of_real_positive[of "Re v'"] arg_complex_of_real_negative[of "Re v'"]
	+ by (auto simp add: cmod_eq_Re)
	+ next
	+ fix v
	+ assume "v \<in> unit_disc" "v \<noteq> 0\<^sub>h" "v \<noteq> of_complex x"
	+ then obtain v' where **: "v = of_complex v'" "v' \<noteq> 0" "v' \<noteq> x"
	+ using inf_or_of_complex[of v]
	+ by auto blast
	+ assume "let u' = to_complex (of_complex x); v' = to_complex v in arg u' = arg v' \<and> cmod u' \<le> cmod v'"
	+ hence ***: "Re x < 0 \<and> Re v' < 0 \<and> Re v' \<le> Re x \<or> 0 < Re x \<and> 0 < Re v' \<and> Re x \<le> Re v'" "is_real v'"
	+ using arg_pi_iff[of x] arg_pi_iff[of v']
	+ using arg_0_iff[of x] arg_0_iff[of v']
	+ using * **
	+ by (smt cmod_Re_le_iff to_complex_of_complex)+
	+ have "-1 < Re v'" "Re v' < 1" "Re v' \<noteq> 0" "is_real v'"
	+ using \<open>v \<in> unit_disc\<close> ** \<open>is_real v'\<close>
	+ by (auto simp add: cmod_eq_Re complex_eq_if_Re_eq)
	+ thus "poincare_between 0\<^sub>h (of_complex x) v"
	+ using poincare_between_x_axis_0uv[of "Re x" "Re v'"] * *
	+ by simp
	+ qed
	+ next
	+ fix \<phi> u
	+ assume "u \<in> unit_disc" "u \<noteq> 0\<^sub>h"
	+ let ?M = "moebius_rotation \<phi>"
	+ assume *: "?P' (moebius_pt ?M u)"
	+ show "?P' u"
	+ proof (rule allI, rule impI, (erule conjE)+)
	+ fix v
	+ assume "v \<in> unit_disc" "v \<noteq> 0\<^sub>h" "v \<noteq> u"
	+ have "moebius_pt ?M v \<noteq> moebius_pt ?M u"
	+ using \<open>v \<noteq> u\<close>
	+ by auto
	+ obtain u' v' where "v = of_complex v'" "u = of_complex u'" "v' \<noteq> 0" "u' \<noteq> 0"
	+ using inf_or_of_complex[of u] inf_or_of_complex[of v]
	+ using \<open>v \<in> unit_disc\<close> \<open>u \<in> unit_disc\<close> \<open>v \<noteq> 0\<^sub>h\<close> \<open>u \<noteq> 0\<^sub>h\<close>
	+ by auto
	+ thus "?P u v"
	+ using *[rule_format, of "moebius_pt ?M v"]
	+ using \<open>moebius_pt ?M v \<noteq> moebius_pt ?M u\<close>
	+ using unit_disc_fix_moebius_preserve_poincare_between[of ?M "0\<^sub>h" u v]
	+ using \<open>v \<in> unit_disc\<close> \<open>u \<in> unit_disc\<close> \<open>v \<noteq> 0\<^sub>h\<close> \<open>u \<noteq> 0\<^sub>h\<close>
	+ using arg_mult_eq[of "cis \<phi>" u' v']
	+ by simp (auto simp add: arg_mult)
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms False
	+ by auto
	+qed
	+
	+lemma poincare_between_y_axis_0uv:
	+ fixes x y :: real
	+ assumes "-1 < x" and "x < 1" and "x \<noteq> 0"
	+ assumes "-1 < y" and "y < 1" and "y \<noteq> 0"
	+ shows "poincare_between 0\<^sub>h (of_complex (\<i> * x)) (of_complex (\<i> * y)) \<longleftrightarrow>
	+ (x < 0 \<and> y < 0 \<and> y \<le> x) \<or> (x > 0 \<and> y > 0 \<and> x \<le> y)" (is "?lhs \<longleftrightarrow> ?rhs")
	+ using assms
	+ using poincare_between_0uv[of "of_complex (\<i> * x)" "of_complex (\<i> * y)"]
	+ using arg_pi2_iff[of "\<i> * cor x"] arg_pi2_iff[of "\<i> * cor y"]
	+ using arg_minus_pi2_iff[of "\<i> * cor x"] arg_minus_pi2_iff[of "\<i> * cor y"]
	+ apply simp
	+ apply (cases "x > 0")
	+ apply (cases "y > 0", simp, simp)
	+ apply (cases "y > 0")
	+ apply simp
	+ using pi_gt_zero apply linarith
	+ apply simp
	+ done
	+
	+lemma poincare_between_x_axis_uvw:
	+ fixes x y z :: real
	+ assumes "-1 < x" and "x < 1"
	+ assumes "-1 < y" and "y < 1" and "y \<noteq> x"
	+ assumes "-1 < z" and "z < 1" and "z \<noteq> x"
	+ shows "poincare_between (of_complex x) (of_complex y) (of_complex z) \<longleftrightarrow>
	+ (y < x \<and> z < x \<and> z \<le> y) \<or> (y > x \<and> z > x \<and> y \<le> z)" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof (cases "x = 0 \<or> y = 0 \<or> z = 0")
	+ case True
	+ thus ?thesis
	+ proof (cases "x = 0")
	+ case True
	+ thus ?thesis
	+ using poincare_between_x_axis_0uv assms
	+ by simp
	+ next
	+ case False
	+ show ?thesis
	+ proof (cases "z = 0")
	+ case True
	+ thus ?thesis
	+ using poincare_between_x_axis_0uv assms poincare_between_rev
	+ by (smt norm_of_real of_complex_zero of_real_0 poincare_between_nonstrict(2) unit_disc_iff_cmod_lt_1)
	+ next
	+ case False
	+ have "y = 0"
	+ using `x \<noteq> 0` `z \<noteq> 0` `x = 0 \<or> y = 0 \<or> z = 0`
	+ by simp
	+
	+ have "poincare_between (of_complex x) 0\<^sub>h (of_complex z) = (is_real z \<and> x * z < 0)"
	+ using `x \<noteq> 0` `z \<noteq> 0` poincare_between_x_axis_u0v
	+ by auto
	+ moreover
	+ have "x * z < 0 \<longleftrightarrow> ?rhs"
	+ using True \<open>x \<noteq> 0\<close> \<open>z \<noteq> 0\<close>
	+ by (smt zero_le_mult_iff)
	+ ultimately
	+ show ?thesis
	+ using `y = 0`
	+ by auto
	+ qed
	+ qed
	+next
	+ case False
	+ thus ?thesis
	+ proof (cases "z = y")
	+ case True
	+ thus ?thesis
	+ using assms
	+ unfolding poincare_between_def
	+ by auto
	+ next
	+ case False
	+ let ?x = "of_complex x" and ?y = "of_complex y" and ?z = "of_complex z"
	+
	+ have "?x \<in> unit_disc" "?y \<in> unit_disc" "?z \<in> unit_disc"
	+ using assms
	+ by auto
	+
	+ have distinct: "distinct [?x, ?y, ?z, inversion ?y]"
	+ using \<open>y \<noteq> x\<close> \<open>z \<noteq> x\<close> False \<open>?x \<in> unit_disc\<close> \<open>?y \<in> unit_disc\<close> \<open>?z \<in> unit_disc\<close>
	+ using inversion_noteq_unit_disc[of ?y ?y]
	+ using inversion_noteq_unit_disc[of ?y ?x]
	+ using inversion_noteq_unit_disc[of ?y ?z]
	+ using of_complex_inj[of x y] of_complex_inj[of y z] of_complex_inj[of x z]
	+ by auto
	+
	+ have "cor y * cor x \<noteq> 1"
	+ using assms
	+ by (smt minus_mult_minus mult_less_cancel_left2 mult_less_cancel_right2 of_real_1 of_real_eq_iff of_real_mult)
	+
	+ let ?cr = "cross_ratio ?x ?y ?z (inversion ?y)"
	+ have "Re (to_complex ?cr) = (x - y) * (zy - 1)/ ((xy - 1)*(z - y))"
	+ proof-
	+ have " \<And>y x z. \<lbrakk>y \<noteq> x; z \<noteq> x; z \<noteq> y; cor y * cor x \<noteq> 1; x \<noteq> 0; y \<noteq> 0; z \<noteq> 0\<rbrakk> \<Longrightarrow>
	+ (y * y + y * (y * (x * z)) - (y * x + y * (y * (y * z)))) /
	+ (y * y + y * (y * (x * z)) - (y * z + y * (y * (y * x)))) =
	+ (y + y * (x * z) - (x + y * (y * z))) / (y + y * (x * z) - (z + y * (y * x)))"
	+ by (metis (no_types, hide_lams) ab_group_add_class.ab_diff_conv_add_uminus distrib_left mult_divide_mult_cancel_left_if mult_minus_right)
	+ thus ?thesis
	+ using \<open>y \<noteq> x\<close> \<open>z \<noteq> x\<close> False \<open>\<not> (x = 0 \<or> y = 0 \<or> z = 0)\<close>
	+ using \<open>cor y * cor x \<noteq> 1\<close>
	+ unfolding inversion_def
	+ by (transfer, transfer, auto simp add: vec_cnj_def power2_eq_square field_simps split: if_split_asm)
	+ qed
	+
	+ moreover
	+ have "(x*y - 1) < 0"
	+ using assms
	+ by (smt minus_mult_minus mult_less_cancel_right2 zero_less_mult_iff)
	+ moreover
	+ have "(z*y - 1) < 0"
	+ using assms
	+ by (smt minus_mult_minus mult_less_cancel_right2 zero_less_mult_iff)
	+ moreover
	+ have "(x - y) / (z - y) < 0 \<longleftrightarrow> ?rhs"
	+ using \<open>y \<noteq> x\<close> \<open>z \<noteq> x\<close> False \<open>\<not> (x = 0 \<or> y = 0 \<or> z = 0)\<close>
	+ by (smt divide_less_cancel divide_nonneg_nonpos divide_nonneg_pos divide_nonpos_nonneg divide_nonpos_nonpos)
	+ ultimately
	+ have *: "Re (to_complex ?cr) < 0 \<longleftrightarrow> ?rhs"
	+ by (smt linordered_field_class.sign_simps(45) minus_divide_left zero_less_divide_iff zero_less_mult_iff)
	+
	+ show ?thesis
	+ proof
	+ assume ?lhs
	+ have "is_real (to_complex ?cr)" "Re (to_complex ?cr) < 0"
	+ using \<open>?lhs\<close> distinct
	+ unfolding poincare_between_def Let_def
	+ by auto
	+ thus ?rhs
	+ using *
	+ by simp
	+ next
	+ assume ?rhs
	+ hence "Re (to_complex ?cr) < 0"
	+ using *
	+ by simp
	+ moreover
	+ have "{of_complex (cor x), of_complex (cor y), of_complex (cor z), inversion (of_complex (cor y))} \<subseteq> circline_set x_axis"
	+ using \<open>\<not> (x = 0 \<or> y = 0 \<or> z = 0)\<close> is_real_inversion[of "cor y"]
	+ using inf_or_of_complex[of "inversion ?y"]
	+ by (auto simp del: inversion_of_complex)
	+ hence "is_real (to_complex ?cr)"
	+ using four_points_on_circline_iff_cross_ratio_real[OF distinct]
	+ by auto
	+ ultimately
	+ show ?lhs
	+ using distinct
	+ unfolding poincare_between_def Let_def
	+ by auto
	+ qed
	+ qed
	+qed
	+
	+subsubsection \<open>H-betweenness and h-collinearity\<close>
	+
	+text\<open>For three h-collinear points at least one of the three possible h-betweeness relations must
	+hold.\<close>
	+lemma poincare_collinear3_between:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "w \<in> unit_disc"
	+ assumes "poincare_collinear {u, v, w}"
	+ shows "poincare_between u v w \<or> poincare_between u w v \<or> poincare_between v u w" (is "?P' u v w")
	+proof (cases "u=v")
	+ case True
	+ thus ?thesis
	+ using assms
	+ by auto
	+next
	+ case False
	+ have "\<forall> w. w \<in> unit_disc \<and> poincare_collinear {u, v, w} \<longrightarrow> ?P' u v w" (is "?P u v")
	+ proof (rule wlog_positive_x_axis[where P="?P"])
	+ fix x
	+ assume x: "is_real x" "0 < Re x" "Re x < 1"
	+ hence "x \<noteq> 0"
	+ using complex.expand[of x 0]
	+ by auto
	+ hence *: "poincare_line 0\<^sub>h (of_complex x) = x_axis"
	+ using x poincare_line_0_real_is_x_axis[of "of_complex x"]
	+ unfolding circline_set_x_axis
	+ by auto
	+ have "of_complex x \<in> unit_disc"
	+ using x
	+ by (auto simp add: cmod_eq_Re)
	+ have "of_complex x \<noteq> 0\<^sub>h"
	+ using \<open>x \<noteq> 0\<close>
	+ by auto
	+ show "?P 0\<^sub>h (of_complex x)"
	+ proof safe
	+ fix w
	+ assume "w \<in> unit_disc"
	+ assume "poincare_collinear {0\<^sub>h, of_complex x, w}"
	+ hence "w \<in> circline_set x_axis"
	+ using * unique_poincare_line[of "0\<^sub>h" "of_complex x"] \<open>of_complex x \<in> unit_disc\<close> \<open>x \<noteq> 0\<close> \<open>of_complex x \<noteq> 0\<^sub>h\<close>
	+ unfolding poincare_collinear_def
	+ by auto
	+ then obtain w' where w': "w = of_complex w'" "is_real w'"
	+ using \<open>w \<in> unit_disc\<close>
	+ using inf_or_of_complex[of w]
	+ unfolding circline_set_x_axis
	+ by auto
	+ hence "-1 < Re w'" "Re w' < 1"
	+ using \<open>w \<in> unit_disc\<close>
	+ by (auto simp add: cmod_eq_Re)
	+ assume 1: "\<not> poincare_between (of_complex x) 0\<^sub>h w"
	+ hence "w \<noteq> 0\<^sub>h" "w' \<noteq> 0"
	+ using w'
	+ unfolding poincare_between_def
	+ by auto
	+ hence "Re w' \<noteq> 0"
	+ using w' complex.expand[of w' 0]
	+ by auto
	+
	+ have "Re w' \<ge> 0"
	+ using 1 poincare_between_x_axis_u0v[of x w'] \<open>Re x > 0\<close> \<open>is_real x\<close> \<open>x \<noteq> 0\<close> \<open>w' \<noteq> 0\<close> w'
	+ using mult_pos_neg
	+ by force
	+
	+ moreover
	+
	+ assume "\<not> poincare_between 0\<^sub>h (of_complex x) w"
	+ hence "Re w' < Re x"
	+ using poincare_between_x_axis_0uv[of "Re x" "Re w'"]
	+ using w' x \<open>-1 < Re w'\<close> \<open>Re w' < 1\<close> \<open>Re w' \<noteq> 0\<close>
	+ by auto
	+
	+ ultimately
	+ show "poincare_between 0\<^sub>h w (of_complex x)"
	+ using poincare_between_x_axis_0uv[of "Re w'" "Re x"]
	+ using w' x \<open>-1 < Re w'\<close> \<open>Re w' < 1\<close> \<open>Re w' \<noteq> 0\<close>
	+ by auto
	+ qed
	+ next
	+ show "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ by fact+
	+ next
	+ fix M u v
	+ assume 1: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ let ?Mu = "moebius_pt M u" and ?Mv = "moebius_pt M v"
	+ assume 2: "?P ?Mu ?Mv"
	+ show "?P u v"
	+ proof safe
	+ fix w
	+ assume "w \<in> unit_disc" "poincare_collinear {u, v, w}" "\<not> poincare_between u v w" "\<not> poincare_between v u w"
	+ thus "poincare_between u w v"
	+ using 1 2[rule_format, of "moebius_pt M w"]
	+ by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms
	+ by simp
	+qed
	+
	+lemma poincare_collinear3_iff:
	+ assumes "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
	+ shows "poincare_collinear {u, v, w} \<longleftrightarrow> poincare_between u v w \<or> poincare_between v u w \<or> poincare_between v w u"
	+ using assms
	+ by (metis poincare_collinear3_between insert_commute poincare_between_poincare_collinear poincare_between_rev)
	+
	+subsection \<open>Some properties of betweenness\<close>
	+
	+lemma poincare_between_transitivity:
	+ assumes "a \<in> unit_disc" and "x \<in> unit_disc" and "b \<in> unit_disc" and "y \<in> unit_disc" and
	+ "poincare_between a x b" and "poincare_between a b y"
	+ shows "poincare_between x b y"
	+proof(cases "a = b")
	+ case True
	+ thus ?thesis
	+ using assms
	+ using poincare_between_sandwich by blast
	+next
	+ case False
	+ have "\<forall> x. \<forall> y. poincare_between a x b \<and> poincare_between a b y \<and> x \<in> unit_disc
	+ \<and> y \<in> unit_disc \<longrightarrow> poincare_between x b y" (is "?P a b")
	+ proof (rule wlog_positive_x_axis[where P="?P"])
	+ show "a \<in> unit_disc"
	+ using assms by simp
	+ next
	+ show "b \<in> unit_disc"
	+ using assms by simp
	+ next
	+ show "a \<noteq> b"
	+ using False by simp
	+ next
	+ fix M u v
	+ assume *: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ "\<forall>x y. poincare_between (moebius_pt M u) x (moebius_pt M v) \<and>
	+ poincare_between (moebius_pt M u) (moebius_pt M v) y \<and>
	+ x \<in> unit_disc \<and> y \<in> unit_disc \<longrightarrow>
	+ poincare_between x (moebius_pt M v) y"
	+ show "\<forall>x y. poincare_between u x v \<and> poincare_between u v y \<and> x \<in> unit_disc \<and> y \<in> unit_disc
	+ \<longrightarrow> poincare_between x v y"
	+ proof safe
	+ fix x y
	+ assume "poincare_between u x v" "poincare_between u v y" " x \<in> unit_disc" "y \<in> unit_disc"
	+
	+ have "poincare_between (moebius_pt M u) (moebius_pt M x) (moebius_pt M v)"
	+ using \<open>poincare_between u x v\<close> \<open>unit_disc_fix M\<close> \<open>x \<in> unit_disc\<close> \<open>u \<in> unit_disc\<close> \<open>v \<in> unit_disc\<close>
	+ by simp
	+ moreover
	+ have "poincare_between (moebius_pt M u) (moebius_pt M v) (moebius_pt M y)"
	+ using \<open>poincare_between u v y\<close> \<open>unit_disc_fix M\<close> \<open>y \<in> unit_disc\<close> \<open>u \<in> unit_disc\<close> \<open>v \<in> unit_disc\<close>
	+ by simp
	+ moreover
	+ have "(moebius_pt M x) \<in> unit_disc"
	+ using \<open>unit_disc_fix M\<close> \<open>x \<in> unit_disc\<close> by simp
	+ moreover
	+ have "(moebius_pt M y) \<in> unit_disc"
	+ using \<open>unit_disc_fix M\<close> \<open>y \<in> unit_disc\<close> by simp
	+ ultimately
	+ have "poincare_between (moebius_pt M x) (moebius_pt M v) (moebius_pt M y)"
	+ using * by blast
	+ thus "poincare_between x v y"
	+ using \<open>y \<in> unit_disc\<close> * \<open>x \<in> unit_disc\<close> by simp
	+ qed
	+ next
	+ fix x
	+ assume xx: "is_real x" "0 < Re x" "Re x < 1"
	+ hence "of_complex x \<in> unit_disc"
	+ using cmod_eq_Re by auto
	+ hence "of_complex x \<noteq> \<infinity>\<^sub>h"
	+ by simp
	+ have " of_complex x \<noteq> 0\<^sub>h"
	+ using xx by auto
	+ have "of_complex x \<in> circline_set x_axis"
	+ using xx by simp
	+ show "\<forall>m n. poincare_between 0\<^sub>h m (of_complex x) \<and> poincare_between 0\<^sub>h (of_complex x) n \<and>
	+ m \<in> unit_disc \<and> n \<in> unit_disc \<longrightarrow> poincare_between m (of_complex x) n"
	+ proof safe
	+ fix m n
	+ assume **: "poincare_between 0\<^sub>h m (of_complex x)" "poincare_between 0\<^sub>h (of_complex x) n"
	+ "m \<in> unit_disc" " n \<in> unit_disc"
	+ show "poincare_between m (of_complex x) n"
	+ proof(cases "m = 0\<^sub>h")
	+ case True
	+ thus ?thesis
	+ using ** by auto
	+ next
	+ case False
	+ hence "m \<in> circline_set x_axis"
	+ using poincare_between_poincare_line_uzv[of "0\<^sub>h" "of_complex x" m]
	+ using poincare_line_0_real_is_x_axis[of "of_complex x"]
	+ using \<open>of_complex x \<in> unit_disc\<close> \<open>of_complex x \<noteq> \<infinity>\<^sub>h\<close> \<open>of_complex x \<noteq> 0\<^sub>h\<close>
	+ using \<open>of_complex x \<in> circline_set x_axis\<close> \<open>m \<in> unit_disc\<close> **(1)
	+ by simp
	+ then obtain m' where "m = of_complex m'" "is_real m'"
	+ using inf_or_of_complex[of m] \<open>m \<in> unit_disc\<close>
	+ unfolding circline_set_x_axis
	+ by auto
	+ hence "Re m' \<le> Re x"
	+ using \<open>poincare_between 0\<^sub>h m (of_complex x)\<close> xx \<open>of_complex x \<noteq> 0\<^sub>h\<close>
	+ using False ** \<open>of_complex x \<in> unit_disc\<close>
	+ using cmod_Re_le_iff poincare_between_0uv by auto
	+
	+ have "n \<noteq> 0\<^sub>h"
	+ using **(2, 4) \<open>of_complex x \<noteq> 0\<^sub>h\<close> \<open>of_complex x \<in> unit_disc\<close>
	+ using poincare_between_sandwich by fastforce
	+ have "n \<in> circline_set x_axis"
	+ using poincare_between_poincare_line_uvz[of "0\<^sub>h" "of_complex x" n]
	+ using poincare_line_0_real_is_x_axis[of "of_complex x"]
	+ using \<open>of_complex x \<in> unit_disc\<close> \<open>of_complex x \<noteq> \<infinity>\<^sub>h\<close> \<open>of_complex x \<noteq> 0\<^sub>h\<close>
	+ using \<open>of_complex x \<in> circline_set x_axis\<close> \<open>n \<in> unit_disc\<close> **(2)
	+ by simp
	+ then obtain n' where "n = of_complex n'" "is_real n'"
	+ using inf_or_of_complex[of n] \<open>n \<in> unit_disc\<close>
	+ unfolding circline_set_x_axis
	+ by auto
	+ hence "Re x \<le> Re n'"
	+ using \<open>poincare_between 0\<^sub>h (of_complex x) n\<close> xx \<open>of_complex x \<noteq> 0\<^sub>h\<close>
	+ using False ** \<open>of_complex x \<in> unit_disc\<close> \<open>n \<noteq> 0\<^sub>h\<close>
	+ using cmod_Re_le_iff poincare_between_0uv
	+ by (metis Re_complex_of_real arg_0_iff rcis_cmod_arg rcis_zero_arg to_complex_of_complex)
	+
	+ have "poincare_between (of_complex m') (of_complex x) (of_complex n')"
	+ using \<open>Re x \<le> Re n'\<close> \<open>Re m' \<le> Re x\<close>
	+ using poincare_between_x_axis_uvw[of "Re m'" "Re x" "Re n'"]
	+ using \<open>is_real n'\<close> \<open>is_real m'\<close> \<open>n \<in> unit_disc\<close> \<open>n = of_complex n'\<close>
	+ using xx \<open>m = of_complex m'\<close> \<open>m \<in> unit_disc\<close>
	+ by (smt complex_of_real_Re norm_of_real poincare_between_def unit_disc_iff_cmod_lt_1)
	+
	+ thus ?thesis
	+ using \<open>n = of_complex n'\<close> \<open>m = of_complex m'\<close>
	+ by auto
	+ qed
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms
	+ by blast
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Poincare between - sum distances\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>Another possible definition of the h-betweenness relation is given in terms of h-distances
	+between pairs of points. We prove it as a characterization equivalent to our cross-ratio based
	+definition.\<close>
	+
	+lemma poincare_between_sum_distances_x_axis_u0v:
	+ assumes "of_complex u' \<in> unit_disc" "of_complex v' \<in> unit_disc"
	+ assumes "is_real u'" "u' \<noteq> 0" "v' \<noteq> 0"
	+ shows "poincare_distance (of_complex u') 0\<^sub>h + poincare_distance 0\<^sub>h (of_complex v') = poincare_distance (of_complex u') (of_complex v') \<longleftrightarrow>
	+ is_real v' \<and> Re u' * Re v' < 0" (is "?P u' v' \<longleftrightarrow> ?Q u' v'")
	+proof-
	+ have "Re u' \<noteq> 0"
	+ using \<open>is_real u'\<close> \<open>u' \<noteq> 0\<close>
	+ using complex_eq_if_Re_eq
	+ by simp
	+
	+ let ?u = "cmod u'" and ?v = "cmod v'" and ?uv = "cmod (u' - v')"
	+ have disc: "?u\<^sup>2 < 1" "?v\<^sup>2 < 1"
	+ using unit_disc_cmod_square_lt_1[OF assms(1)]
	+ using unit_disc_cmod_square_lt_1[OF assms(2)]
	+ by auto
	+ have "poincare_distance (of_complex u') 0\<^sub>h + poincare_distance 0\<^sub>h (of_complex v') =
	+ arcosh (((1 + ?u\<^sup>2) * (1 + ?v\<^sup>2) + 4 * ?u * ?v) / ((1 - ?u\<^sup>2) * (1 - ?v\<^sup>2)))" (is "_ = arcosh ?r1")
	+ using poincare_distance_formula_zero_sum[OF assms(1-2)]
	+ by (simp add: Let_def)
	+ moreover
	+ have "poincare_distance (of_complex u') (of_complex v') =
	+ arcosh (((1 - ?u\<^sup>2) * (1 - ?v\<^sup>2) + 2 * ?uv\<^sup>2) / ((1 - ?u\<^sup>2) * (1 - ?v\<^sup>2)))" (is "_ = arcosh ?r2")
	+ using disc
	+ using poincare_distance_formula[OF assms(1-2)]
	+ by (subst add_divide_distrib) simp
	+ moreover
	+ have "arcosh ?r1 = arcosh ?r2 \<longleftrightarrow> ?Q u' v'"
	+ proof
	+ assume "arcosh ?r1 = arcosh ?r2"
	+ hence "?r1 = ?r2"
	+ proof (subst (asm) arcosh_eq_iff)
	+ show "?r1 \<ge> 1"
	+ proof-
	+ have "(1 - ?u\<^sup>2) * (1 - ?v\<^sup>2) \<le> (1 + ?u\<^sup>2) * (1 + ?v\<^sup>2) + 4 * ?u * ?v"
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using disc
	+ by simp
	+ qed
	+ next
	+ show "?r2 \<ge> 1"
	+ using disc
	+ by simp
	+ qed
	+ hence "(1 + ?u\<^sup>2) * (1 + ?v\<^sup>2) + 4 * ?u * ?v = (1 - ?u\<^sup>2) * (1 - ?v\<^sup>2) + 2 * ?uv\<^sup>2"
	+ using disc
	+ by auto
	+ hence "(cmod (u' - v'))\<^sup>2 = (cmod u' + cmod v')\<^sup>2"
	+ by (simp add: field_simps power2_eq_square)
	+ hence : "Re u' Re v' + \<bar>Re u'\<bar> * sqrt ((Im v')\<^sup>2 + (Re v')\<^sup>2) = 0"
	+ using \<open>is_real u'\<close>
	+ unfolding cmod_power2 cmod_def
	+ by (simp add: field_simps) (simp add: power2_eq_square field_simps)
	+ hence "sqrt ((Im v')\<^sup>2 + (Re v')\<^sup>2) = \<bar>Re v'\<bar>"
	+ using \<open>Re u' \<noteq> 0\<close> \<open>v' \<noteq> 0\<close>
	+ by (smt complex_neq_0 mult.commute mult_cancel_right mult_minus_left real_sqrt_gt_0_iff)
	+ hence "Im v' = 0"
	+ by (smt Im_eq_0 norm_complex_def)
	+ moreover
	+ hence "Re u' * Re v' = - \<bar>Re u'\<bar> * \<bar>Re v'\<bar>"
	+ using *
	+ by simp
	+ hence "Re u' * Re v' < 0"
	+ using \<open>Re u' \<noteq> 0\<close> \<open>v' \<noteq> 0\<close>
	+ by (simp add: \<open>is_real v'\<close> complex_eq_if_Re_eq)
	+ ultimately
	+ show "?Q u' v'"
	+ by simp
	+ next
	+ assume "?Q u' v'"
	+ hence "is_real v'" "Re u' * Re v' < 0"
	+ by auto
	+ have "?r1 = ?r2"
	+ proof (cases "Re u' > 0")
	+ case True
	+ hence "Re v' < 0"
	+ using \<open>Re u' * Re v' < 0\<close>
	+ by (smt zero_le_mult_iff)
	+ show ?thesis
	+ using disc \<open>is_real u'\<close> \<open>is_real v'\<close>
	+ using \<open>Re u' > 0\<close> \<open>Re v' < 0\<close>
	+ unfolding cmod_power2 cmod_def
	+ by simp (simp add: power2_eq_square field_simps)
	+ next
	+ case False
	+ hence "Re u' < 0"
	+ using \<open>Re u' \<noteq> 0\<close>
	+ by simp
	+ hence "Re v' > 0"
	+ using \<open>Re u' * Re v' < 0\<close>
	+ by (smt zero_le_mult_iff)
	+ show ?thesis
	+ using disc \<open>is_real u'\<close> \<open>is_real v'\<close>
	+ using \<open>Re u' < 0\<close> \<open>Re v' > 0\<close>
	+ unfolding cmod_power2 cmod_def
	+ by simp (simp add: power2_eq_square field_simps)
	+ qed
	+ thus "arcosh ?r1 = arcosh ?r2"
	+ by metis
	+ qed
	+ ultimately
	+ show ?thesis
	+ by simp
	+qed
	+
	+text\<open>
	+ Different proof of the previous theorem relying on the cross-ratio definition, and not the distance formula.
	+ We suppose that this could be also used to prove the triangle inequality.
	+\<close>
	+lemma poincare_between_sum_distances_x_axis_u0v_different_proof:
	+ assumes "of_complex u' \<in> unit_disc" "of_complex v' \<in> unit_disc"
	+ assumes "is_real u'" "u' \<noteq> 0" "v' \<noteq> 0" (* additional condition *) "is_real v'"
	+ shows "poincare_distance (of_complex u') 0\<^sub>h + poincare_distance 0\<^sub>h (of_complex v') = poincare_distance (of_complex u') (of_complex v') \<longleftrightarrow>
	+ Re u' * Re v' < 0" (is "?P u' v' \<longleftrightarrow> ?Q u' v'")
	+proof-
	+ have "-1 < Re u'" "Re u' < 1" "Re u' \<noteq> 0"
	+ using assms
	+ by (auto simp add: cmod_eq_Re complex_eq_if_Re_eq)
	+ have "-1 < Re v'" "Re v' < 1" "Re v' \<noteq> 0"
	+ using assms
	+ by (auto simp add: cmod_eq_Re complex_eq_if_Re_eq)
	+
	+ have "\<bar>ln (Re ((1 - u') / (1 + u')))\<bar> + \<bar>ln (Re ((1 - v') / (1 + v')))\<bar> =
	+ \<bar>ln (Re ((1 + u') * (1 - v') / ((1 - u') * (1 + v'))))\<bar> \<longleftrightarrow> Re u' * Re v' < 0" (is "\<bar>ln ?a1\<bar> + \<bar>ln ?a2\<bar> = \<bar>ln ?a3\<bar> \<longleftrightarrow> _")
	+ proof-
	+ have 1: "0 < ?a1" "ln ?a1 > 0 \<longleftrightarrow> Re u' < 0"
	+ using \<open>Re u' < 1\<close> \<open>Re u' > -1\<close> \<open>is_real u'\<close>
	+ using complex_is_Real_iff
	+ by auto
	+ have 2: "0 < ?a2" "ln ?a2 > 0 \<longleftrightarrow> Re v' < 0"
	+ using \<open>Re v' < 1\<close> \<open>Re v' > -1\<close> \<open>is_real v'\<close>
	+ using complex_is_Real_iff
	+ by auto
	+ have 3: "0 < ?a3" "ln ?a3 > 0 \<longleftrightarrow> Re v' < Re u'"
	+ using \<open>Re u' < 1\<close> \<open>Re u' > -1\<close> \<open>is_real u'\<close>
	+ using \<open>Re v' < 1\<close> \<open>Re v' > -1\<close> \<open>is_real v'\<close>
	+ using complex_is_Real_iff
	+ by auto (simp add: field_simps)+
	+ show ?thesis
	+ proof
	+ assume : "Re u' Re v' < 0"
	+ show "\<bar>ln ?a1\<bar> + \<bar>ln ?a2\<bar> = \<bar>ln ?a3\<bar>"
	+ proof (cases "Re u' > 0")
	+ case True
	+ hence "Re v' < 0"
	+ using *
	+ by (smt mult_nonneg_nonneg)
	+ show ?thesis
	+ using 1 2 3 \<open>Re u' > 0\<close> \<open>Re v' < 0\<close>
	+ using \<open>Re u' < 1\<close> \<open>Re u' > -1\<close> \<open>is_real u'\<close>
	+ using \<open>Re v' < 1\<close> \<open>Re v' > -1\<close> \<open>is_real v'\<close>
	+ using complex_is_Real_iff
	+ using ln_div ln_mult
	+ by simp
	+ next
	+ case False
	+ hence "Re v' > 0" "Re u' < 0"
	+ using *
	+ by (smt zero_le_mult_iff)+
	+ show ?thesis
	+ using 1 2 3 \<open>Re u' < 0\<close> \<open>Re v' > 0\<close>
	+ using \<open>Re u' < 1\<close> \<open>Re u' > -1\<close> \<open>is_real u'\<close>
	+ using \<open>Re v' < 1\<close> \<open>Re v' > -1\<close> \<open>is_real v'\<close>
	+ using complex_is_Real_iff
	+ using ln_div ln_mult
	+ by simp
	+ qed
	+ next
	+ assume *: "\<bar>ln ?a1\<bar> + \<bar>ln ?a2\<bar> = \<bar>ln ?a3\<bar>"
	+ {
	+ assume "Re u' > 0" "Re v' > 0"
	+ hence False
	+ using * 1 2 3
	+ using \<open>Re u' < 1\<close> \<open>Re u' > -1\<close> \<open>is_real u'\<close>
	+ using \<open>Re v' < 1\<close> \<open>Re v' > -1\<close> \<open>is_real v'\<close>
	+ using complex_is_Real_iff
	+ using ln_mult ln_div
	+ by (cases "Re v' < Re u'") auto
	+ }
	+ moreover
	+ {
	+ assume "Re u' < 0" "Re v' < 0"
	+ hence False
	+ using * 1 2 3
	+ using \<open>Re u' < 1\<close> \<open>Re u' > -1\<close> \<open>is_real u'\<close>
	+ using \<open>Re v' < 1\<close> \<open>Re v' > -1\<close> \<open>is_real v'\<close>
	+ using complex_is_Real_iff
	+ using ln_mult ln_div
	+ by (cases "Re v' < Re u'") auto
	+ }
	+ ultimately
	+ show "Re u' * Re v' < 0"
	+ using \<open>Re u' \<noteq> 0\<close> \<open>Re v' \<noteq> 0\<close>
	+ by (smt divisors_zero mult_le_0_iff)
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms
	+ apply (subst poincare_distance_sym, simp, simp)
	+ apply (subst poincare_distance_zero_x_axis, simp, simp add: circline_set_x_axis)
	+ apply (subst poincare_distance_zero_x_axis, simp, simp add: circline_set_x_axis)
	+ apply (subst poincare_distance_x_axis_x_axis, simp, simp, simp add: circline_set_x_axis, simp add: circline_set_x_axis)
	+ apply simp
	+ done
	+qed
	+
	+lemma poincare_between_sum_distances:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "w \<in> unit_disc"
	+ shows "poincare_between u v w \<longleftrightarrow>
	+ poincare_distance u v + poincare_distance v w = poincare_distance u w" (is "?P' u v w")
	+proof (cases "u = v")
	+ case True
	+ thus ?thesis
	+ using assms
	+ by simp
	+next
	+ case False
	+ have "\<forall> w. w \<in> unit_disc \<longrightarrow> (poincare_between u v w \<longleftrightarrow> poincare_distance u v + poincare_distance v w = poincare_distance u w)" (is "?P u v")
	+ proof (rule wlog_positive_x_axis)
	+ fix x
	+ assume "is_real x" "0 < Re x" "Re x < 1"
	+ have "of_complex x \<in> circline_set x_axis"
	+ using \<open>is_real x\<close>
	+ by (auto simp add: circline_set_x_axis)
	+
	+ have "of_complex x \<in> unit_disc"
	+ using \<open>is_real x\<close> \<open>0 < Re x\<close> \<open>Re x < 1\<close>
	+ by (simp add: cmod_eq_Re)
	+
	+ have "x \<noteq> 0"
	+ using \<open>is_real x\<close> \<open>Re x > 0\<close>
	+ by auto
	+
	+ show "?P (of_complex x) 0\<^sub>h"
	+ proof (rule allI, rule impI)
	+ fix w
	+ assume "w \<in> unit_disc"
	+ then obtain w' where "w = of_complex w'"
	+ using inf_or_of_complex[of w]
	+ by auto
	+
	+ show "?P' (of_complex x) 0\<^sub>h w"
	+ proof (cases "w = 0\<^sub>h")
	+ case True
	+ thus ?thesis
	+ by simp
	+ next
	+ case False
	+ hence "w' \<noteq> 0"
	+ using \<open>w = of_complex w'\<close>
	+ by auto
	+
	+ show ?thesis
	+ using \<open>is_real x\<close> \<open>x \<noteq> 0\<close> \<open>w = of_complex w'\<close> \<open>w' \<noteq> 0\<close>
	+ using \<open>of_complex x \<in> unit_disc\<close> \<open>w \<in> unit_disc\<close>
	+ apply simp
	+ apply (subst poincare_between_x_axis_u0v, simp_all)
	+ apply (subst poincare_between_sum_distances_x_axis_u0v, simp_all)
	+ done
	+ qed
	+ qed
	+ next
	+ show "v \<in> unit_disc" "u \<in> unit_disc"
	+ using assms
	+ by auto
	+ next
	+ show "v \<noteq> u"
	+ using \<open>u \<noteq> v\<close>
	+ by simp
	+ next
	+ fix M u v
	+ assume *: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v" and
	+ **: "?P (moebius_pt M v) (moebius_pt M u)"
	+ show "?P v u"
	+ proof (rule allI, rule impI)
	+ fix w
	+ assume "w \<in> unit_disc"
	+ hence "moebius_pt M w \<in> unit_disc"
	+ using \<open>unit_disc_fix M\<close>
	+ by auto
	+ thus "?P' v u w"
	+ using \<open>u \<in> unit_disc\<close> \<open>v \<in> unit_disc\<close> \<open>w \<in> unit_disc\<close> \<open>unit_disc_fix M\<close>
	+ using **[rule_format, of "moebius_pt M w"]
	+ by auto
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms
	+ by simp
	+qed
	+
	+subsection \<open>Some more properties of h-betweenness.\<close>
	+
	+text \<open>Some lemmas proved earlier are proved almost directly using the sum of distances characterization.\<close>
	+
	+lemma unit_disc_fix_moebius_preserve_poincare_between':
	+ assumes "unit_disc_fix M" and "u \<in> unit_disc" and "v \<in> unit_disc" and "w \<in> unit_disc"
	+ shows "poincare_between (moebius_pt M u) (moebius_pt M v) (moebius_pt M w) \<longleftrightarrow>
	+ poincare_between u v w"
	+ using assms
	+ using poincare_between_sum_distances
	+ by simp
	+
	+lemma conjugate_preserve_poincare_between':
	+ assumes "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
	+ shows "poincare_between (conjugate u) (conjugate v) (conjugate w) \<longleftrightarrow> poincare_between u v w"
	+ using assms
	+ using poincare_between_sum_distances
	+ by simp
	+
	+text \<open>There is a unique point on a ray on the given distance from the given starting point\<close>
	+lemma unique_poincare_distance_on_ray:
	+ assumes "d \<ge> 0" "u \<noteq> v" "u \<in> unit_disc" "v \<in> unit_disc"
	+ assumes "y \<in> unit_disc" "poincare_distance u y = d" "poincare_between u v y"
	+ assumes "z \<in> unit_disc" "poincare_distance u z = d" "poincare_between u v z"
	+ shows "y = z"
	+proof-
	+ have "\<forall> d y z. d \<ge> 0 \<and>
	+ y \<in> unit_disc \<and> poincare_distance u y = d \<and> poincare_between u v y \<and>
	+ z \<in> unit_disc \<and> poincare_distance u z = d \<and> poincare_between u v z \<longrightarrow> y = z" (is "?P u v")
	+ proof (rule wlog_positive_x_axis[where P="?P"])
	+ fix x
	+ assume x: "is_real x" "0 < Re x" "Re x < 1"
	+ hence "x \<noteq> 0"
	+ using complex.expand[of x 0]
	+ by auto
	+ hence *: "poincare_line 0\<^sub>h (of_complex x) = x_axis"
	+ using x poincare_line_0_real_is_x_axis[of "of_complex x"]
	+ unfolding circline_set_x_axis
	+ by auto
	+ have "of_complex x \<in> unit_disc"
	+ using x
	+ by (auto simp add: cmod_eq_Re)
	+ have "arg x = 0"
	+ using x
	+ using arg_0_iff by blast
	+ show "?P 0\<^sub>h (of_complex x)"
	+ proof safe
	+ fix y z
	+ assume "y \<in> unit_disc" "z \<in> unit_disc"
	+ then obtain y' z' where yz: "y = of_complex y'" "z = of_complex z'"
	+ using inf_or_of_complex[of y] inf_or_of_complex[of z]
	+ by auto
	+ assume betw: "poincare_between 0\<^sub>h (of_complex x) y" "poincare_between 0\<^sub>h (of_complex x) z"
	+ hence "y \<noteq> 0\<^sub>h" "z \<noteq> 0\<^sub>h"
	+ using \<open>x \<noteq> 0\<close> \<open>of_complex x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close>
	+ using poincare_between_sandwich[of "0\<^sub>h" "of_complex x"]
	+ using of_complex_zero_iff[of x]
	+ by force+
	+
	+ hence "arg y' = 0" "cmod y' \<ge> cmod x" "arg z' = 0" "cmod z' \<ge> cmod x"
	+ using poincare_between_0uv[of "of_complex x" y] poincare_between_0uv[of "of_complex x" z]
	+ using \<open>of_complex x \<in> unit_disc\<close> \<open>x \<noteq> 0\<close> \<open>arg x = 0\<close> \<open>y \<in> unit_disc\<close> \<open>z \<in> unit_disc\<close> betw yz
	+ by (simp_all add: Let_def)
	+ hence *: "is_real y'" "is_real z'" "Re y' > 0" "Re z' > 0"
	+ using arg_0_iff[of y'] arg_0_iff[of z'] x \<open>y \<noteq> 0\<^sub>h\<close> \<open>z \<noteq> 0\<^sub>h\<close> yz
	+ by auto
	+ assume "poincare_distance 0\<^sub>h z = poincare_distance 0\<^sub>h y" "0 \<le> poincare_distance 0\<^sub>h y"
	+ thus "y = z"
	+ using * yz \<open>y \<in> unit_disc\<close> \<open>z \<in> unit_disc\<close>
	+ using unique_x_axis_poincare_distance_positive[of "poincare_distance 0\<^sub>h y"]
	+ by (auto simp add: cmod_eq_Re unit_disc_to_complex_inj)
	+ qed
	+ next
	+ show "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ by fact+
	+ next
	+ fix M u v
	+ assume *: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ assume **: "?P (moebius_pt M u) (moebius_pt M v)"
	+ show "?P u v"
	+ proof safe
	+ fix d y z
	+ assume ***: "0 \<le> poincare_distance u y"
	+ "y \<in> unit_disc" "poincare_between u v y"
	+ "z \<in> unit_disc" "poincare_between u v z"
	+ "poincare_distance u z = poincare_distance u y"
	+ let ?Mu = "moebius_pt M u" and ?Mv = "moebius_pt M v" and ?My = "moebius_pt M y" and ?Mz = "moebius_pt M z"
	+ have "?Mu \<in> unit_disc" "?Mv \<in> unit_disc" "?My \<in> unit_disc" "?Mz \<in> unit_disc"
	+ using \<open>u \<in> unit_disc\<close> \<open>v \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close> \<open>z \<in> unit_disc\<close>
	+ using \<open>unit_disc_fix M\<close>
	+ by auto
	+ hence "?My = ?Mz"
	+ using * ***
	+ using **[rule_format, of "poincare_distance ?Mu ?My" ?My ?Mz]
	+ by simp
	+ thus "y = z"
	+ using bij_moebius_pt[of M]
	+ unfolding bij_def inj_on_def
	+ by blast
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms
	+ by auto
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Poincare_Disc/Poincare_Circles.thy b/thys/Poincare_Disc/Poincare_Circles.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Poincare_Circles.thy
	@@ -0,0 +1,618 @@
	+theory Poincare_Circles
	+ imports Poincare_Distance
	+begin
	+(* -------------------------------------------------------------------------- *)
	+section\<open>H-circles in the Poincar\'e model\<close>
	+(* -------------------------------------------------------------------------- *)
	+
	+text\<open>Circles consist of points that are at the same distance from the center.\<close>
	+definition poincare_circle :: "complex_homo \<Rightarrow> real \<Rightarrow> complex_homo set" where
	+ "poincare_circle z r = {z'. z' \<in> unit_disc \<and> poincare_distance z z' = r}"
	+
	+text\<open>Each h-circle in the Poincar\'e model is represented by an Euclidean circle in the model ---
	+the center and radius of that euclidean circle are determined by the following formulas.\<close>
	+definition poincare_circle_euclidean :: "complex_homo \<Rightarrow> real \<Rightarrow> euclidean_circle" where
	+ "poincare_circle_euclidean z r =
	+ (let R = (cosh r - 1) / 2;
	+ z' = to_complex z;
	+ cz = 1 - (cmod z')\<^sup>2;
	+ k = cz * R + 1
	+ in (z' / k, cz * sqrt(R * (R + 1)) / k))"
	+
	+text\<open>That Euclidean circle has a positive radius and is always fully within the disc.\<close>
	+lemma poincare_circle_in_disc:
	+ assumes "r > 0" and "z \<in> unit_disc" and "(ze, re) = poincare_circle_euclidean z r"
	+ shows "cmod ze < 1" "re > 0" "\<forall> x \<in> circle ze re. cmod x < 1"
	+proof-
	+ let ?R = "(cosh r - 1) / 2"
	+ let ?z' = "to_complex z"
	+ let ?cz = "1 - (cmod ?z')\<^sup>2"
	+ let ?k = "?cz * ?R + 1"
	+ let ?ze = "?z' / ?k"
	+ let ?re = "?cz * sqrt(?R * (?R + 1)) / ?k"
	+
	+ from \<open>z \<in> unit_disc\<close>
	+ obtain z' where z': "z = of_complex z'"
	+ using inf_or_of_complex[of z]
	+ by auto
	+
	+ hence "z' = ?z'"
	+ by simp
	+
	+ obtain cz where cz: "cz = (1 - (cmod z')\<^sup>2)"
	+ by auto
	+
	+ have "cz > 0" "cz \<le> 1"
	+ using \<open>z \<in> unit_disc\<close> z' cz
	+ using unit_disc_cmod_square_lt_1
	+ by fastforce+
	+
	+ obtain R where R: "R = ?R"
	+ by blast
	+
	+ have "R > 0"
	+ using cosh_gt_1[of r] \<open>r > 0\<close>
	+ by (subst R) simp
	+
	+ obtain k where k: "k = cz * R + 1"
	+ by auto
	+
	+ have "k > 1"
	+ using k \<open>R > 0\<close> \<open>cz > 0\<close>
	+ by simp
	+
	+ hence "cmod k = k"
	+ by simp
	+
	+ let ?RR = "cz * sqrt(R * (R + 1)) / k"
	+
	+ have "cmod z' + cz * sqrt(R * (R + 1)) < k"
	+ proof-
	+ have "((R+1)-R)\<^sup>2 > 0"
	+ by simp
	+ hence "(R+1)\<^sup>2 - 2R(R+1) + R\<^sup>2 > 0"
	+ unfolding power2_diff
	+ by (simp add: field_simps)
	+ hence "(R+1)\<^sup>2 + 2R(R+1) + R\<^sup>2 - 4R(R+1) > 0"
	+ by simp
	+ hence "(2R+1)\<^sup>2 / 4 > R(R+1)"
	+ using power2_sum[of "R+1" R]
	+ by (simp add: field_simps)
	+ hence "sqrt(R(R+1)) < (2R+1) / 2"
	+ using \<open>R > 0\<close>
	+ by (smt arith_geo_mean_sqrt linordered_field_class.sign_simps(45) power_divide real_sqrt_four real_sqrt_pow2)
	+ hence "sqrt(R*(R+1)) - R < 1/2"
	+ by (simp add: field_simps)
	+ hence "(1 + (cmod z')) * (sqrt(R(R+1)) - R) < (1 + (cmod z')) (1 / 2)"
	+ by (subst mult_strict_left_mono, simp, smt norm_not_less_zero, simp)
	+ also have "... < 1"
	+ using \<open>z \<in> unit_disc\<close> z'
	+ by auto
	+ finally have "(1 - cmod z') * ((1 + cmod z') * (sqrt(R(R+1)) - R)) < (1 - cmod z') 1"
	+ using \<open>z \<in> unit_disc\<close> z'
	+ by (subst mult_strict_left_mono, simp_all)
	+ hence "cz * (sqrt (R*(R+1)) - R) < 1 - cmod z'"
	+ using square_diff_square_factored[of 1 "cmod z'"]
	+ by (subst cz, subst (asm) mult.assoc[symmetric], simp add: power2_eq_square field_simps)
	+ hence "cmod z' + cz * sqrt(R(R+1)) < 1 + R cz"
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using k
	+ by (simp add: field_simps)
	+ qed
	+ hence "cmod z' / k + cz * sqrt(R * (R + 1)) / k < 1"
	+ using \<open>k > 1\<close>
	+ unfolding add_divide_distrib[symmetric]
	+ by simp
	+ hence "cmod (z' / k) + cz * sqrt(R * (R + 1)) / k < 1"
	+ using \<open>k > 1\<close>
	+ by simp
	+ hence "cmod ?ze + ?re < 1"
	+ using k cz \<open>R = ?R\<close> z'
	+ by simp
	+
	+ moreover
	+
	+ have "cz * sqrt(R * (R + 1)) / k > 0"
	+ using \<open>cz > 0\<close> \<open>R > 0\<close> \<open>k > 1\<close>
	+ by auto
	+ hence "?re > 0"
	+ using k cz \<open>R = ?R\<close> z'
	+ by simp
	+
	+ moreover
	+
	+ have "cmod ?ze < 1"
	+ using \<open>cmod ?ze + ?re < 1\<close> \<open>?re > 0\<close>
	+ by simp
	+
	+ moreover
	+
	+ have "ze = ?ze" "re = ?re"
	+ using \<open>(ze, re) = poincare_circle_euclidean z r\<close>
	+ unfolding poincare_circle_euclidean_def Let_def
	+ by simp_all
	+
	+ moreover
	+
	+ have "\<forall> x \<in> circle ze re. cmod x \<le> cmod ze + re"
	+ using norm_triangle_ineq2[of _ ze]
	+ unfolding circle_def
	+ by (smt mem_Collect_eq)
	+
	+ ultimately
	+
	+ show "cmod ze < 1" "re > 0" "\<forall> x \<in> circle ze re. cmod x < 1"
	+ by auto
	+qed
	+
	+text\<open>The connection between the points on the h-circle and its corresponding Euclidean circle.\<close>
	+lemma poincare_circle_is_euclidean_circle:
	+ assumes "z \<in> unit_disc" and "r > 0"
	+ shows "let (Ze, Re) = poincare_circle_euclidean z r
	+ in of_complex ` (circle Ze Re) = poincare_circle z r"
	+proof-
	+ {
	+ fix x
	+ let ?z = "to_complex z"
	+
	+ from assms obtain z' where z': "z = of_complex z'" "cmod z' < 1"
	+ using inf_or_of_complex[of z]
	+ by auto
	+
	+ have *: "\<And> x. cmod x < 1 \<Longrightarrow> 1 - (cmod x)\<^sup>2 > 0"
	+ by (metis less_iff_diff_less_0 minus_diff_eq mult.left_neutral neg_less_0_iff_less norm_mult_less norm_power power2_eq_square)
	+
	+ let ?R = "(cosh r - 1) / 2"
	+ obtain R where R: "R = ?R"
	+ by blast
	+
	+ let ?cx = "1 - (cmod x)\<^sup>2" and ?cz = "1 - (cmod z')\<^sup>2" and ?czx = "(cmod (z' - x))\<^sup>2"
	+
	+ let ?k = "1 + R * ?cz"
	+ obtain k where k: "k = ?k"
	+ by blast
	+ have "R > 0"
	+ using R cosh_gt_1[OF \<open>r > 0\<close>]
	+ by simp
	+
	+ hence "k > 1"
	+ using assms z' k *[of z']
	+ by auto
	+ hence **: "cor k \<noteq> 0"
	+ by (smt of_real_eq_0_iff)
	+
	+
	+ have "of_complex x \<in> poincare_circle z r \<longleftrightarrow> cmod x < 1 \<and> poincare_distance z (of_complex x) = r"
	+ unfolding poincare_circle_def
	+ by auto
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> poincare_distance_formula' ?z x = cosh r"
	+ using poincare_distance_formula[of z "of_complex x"] cosh_dist[of z "of_complex x"]
	+ unfolding poincare_distance_formula_def
	+ using assms
	+ using arcosh_cosh_real
	+ by auto
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> ?czx / (?cz * ?cx) = ?R"
	+ using z'
	+ by (simp add: field_simps)
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> ?czx = ?R * ?cx * ?cz"
	+ using assms z' [of z'] [of x]
	+ using nonzero_divide_eq_eq[of "(1 - (cmod x)\<^sup>2) * (1 - (cmod z')\<^sup>2)" "(cmod (z' - x))\<^sup>2" ?R]
	+ by (auto, simp add: field_simps)
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> (z' - x) * (cnj z' - cnj x) = R * ?cz * (1 - x * cnj x)" (is "_ \<longleftrightarrow> _ \<and> ?l = ?r")
	+ proof-
	+ let ?l = "(z' - x) * (cnj z' - cnj x)" and ?r = "R * (1 - Re (z' * cnj z')) * (1 - x * cnj x)"
	+ have "is_real ?l"
	+ using eq_cnj_iff_real[of "?l"]
	+ by simp
	+ moreover
	+ have "is_real ?r"
	+ using eq_cnj_iff_real[of "1 - x * cnj x"]
	+ using Im_complex_of_real[of "R * (1 - Re (z' * cnj z'))"]
	+ by simp
	+ ultimately
	+ show ?thesis
	+ apply (subst R[symmetric])
	+ apply (subst cmod_square)+
	+ apply (subst complex_eq_if_Re_eq, simp_all add: field_simps)
	+ done
	+ qed
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> z' * cnj z' - x * cnj z' - cnj x * z' + x * cnj x = R * ?cz - R * ?cz * x * cnj x"
	+ unfolding right_diff_distrib left_diff_distrib
	+ by (simp add: field_simps)
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> k * (x * cnj x) - x * cnj z' - cnj x * z' + z' * cnj z' = R * ?cz" (is "_ \<longleftrightarrow> _ \<and> ?lhs = ?rhs")
	+ by (subst k) (auto simp add: field_simps)
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> (k * x * cnj x - x * cnj z' - cnj x * z' + z' * cnj z') / k = (R * ?cz) / k"
	+ using **
	+ by (auto simp add: Groups.mult_ac(1))
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> x * cnj x - x * cnj z' / k - cnj x * z' / k + z' * cnj z' / k = (R * ?cz) / k"
	+ using **
	+ unfolding add_divide_distrib diff_divide_distrib
	+ by auto
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> (x - z'/k) * cnj(x - z'/k) = (R * ?cz) / k + (z' / k) * cnj(z' / k) - z' * cnj z' / k"
	+ by (auto simp add: field_simps diff_divide_distrib)
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> (cmod (x - z'/k))\<^sup>2 = (R * ?cz) / k + (cmod z')\<^sup>2 / k\<^sup>2 - (cmod z')\<^sup>2 / k"
	+ apply (subst complex_mult_cnj_cmod)+
	+ apply (subst complex_eq_if_Re_eq)
	+ apply (simp_all add: power_divide)
	+ done
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> (cmod (x - z'/k))\<^sup>2 = (R * ?cz * k + (cmod z')\<^sup>2 - (cmod z')\<^sup>2 * k) / k\<^sup>2"
	+ using **
	+ unfolding add_divide_distrib diff_divide_distrib
	+ by (simp add: power2_eq_square)
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> (cmod (x - z'/k))\<^sup>2 = ?cz\<^sup>2 * R * (R + 1) / k\<^sup>2" (is "_ \<longleftrightarrow> _ \<and> ?a\<^sup>2 = ?b")
	+ proof-
	+ have : "R (1 - (cmod z')\<^sup>2) * k + (cmod z')\<^sup>2 - (cmod z')\<^sup>2 * k = (1 - (cmod z')\<^sup>2)\<^sup>2 * R * (R + 1)"
	+ by (subst k)+ (simp add: field_simps power2_diff)
	+ thus ?thesis
	+ by (subst *, simp)
	+ qed
	+ also have "... \<longleftrightarrow> cmod x < 1 \<and> cmod (x - z'/k) = ?cz * sqrt (R * (R + 1)) / k"
	+ using \<open>R > 0\<close> [of z'] * \<open>k > 1\<close> \<open>z \<in> unit_disc\<close> z'
	+ using real_sqrt_unique[of ?a ?b, symmetric]
	+ by (auto simp add: real_sqrt_divide real_sqrt_mult power_divide power_mult_distrib)
	+ finally
	+ have "of_complex x \<in> poincare_circle z r \<longleftrightarrow> cmod x < 1 \<and> x \<in> circle (z'/k) (?cz * sqrt(R * (R+1)) / k)"
	+ unfolding circle_def z' k R
	+ by simp
	+ hence "of_complex x \<in> poincare_circle z r \<longleftrightarrow> (let (Ze, Re) = poincare_circle_euclidean z r in cmod x < 1 \<and> x \<in> circle Ze Re)"
	+ unfolding poincare_circle_euclidean_def Let_def circle_def
	+ using z' R k
	+ by (simp add: field_simps)
	+ hence "of_complex x \<in> poincare_circle z r \<longleftrightarrow> (let (Ze, Re) = poincare_circle_euclidean z r in x \<in> circle Ze Re)"
	+ using poincare_circle_in_disc[OF \<open>r > 0\<close> \<open>z \<in> unit_disc\<close>]
	+ by auto
	+ } note * = this
	+ show ?thesis
	+ unfolding Let_def
	+ proof safe
	+ fix Ze Re x
	+ assume "poincare_circle_euclidean z r = (Ze, Re)" "x \<in> circle Ze Re"
	+ thus "of_complex x \<in> poincare_circle z r"
	+ using *[of x]
	+ by simp
	+ next
	+ fix Ze Re x
	+ assume **: "poincare_circle_euclidean z r = (Ze, Re)" "x \<in> poincare_circle z r"
	+ then obtain x' where x': "x = of_complex x'"
	+ unfolding poincare_circle_def
	+ using inf_or_of_complex[of x]
	+ by auto
	+ hence "x' \<in> circle Ze Re"
	+ using [of x'] *
	+ by simp
	+ thus "x \<in> of_complex ` circle Ze Re"
	+ using x'
	+ by auto
	+ qed
	+qed
	+
	+subsection \<open>Intersection of circles in special positions\<close>
	+
	+text \<open>Two h-circles centered at the x-axis intersect at mutually conjugate points\<close>
	+lemma intersect_poincare_circles_x_axis:
	+ assumes z: "is_real z1" and "is_real z2" and "r1 > 0" and "r2 > 0" and
	+ "-1 < Re z1" and "Re z1 < 1" and "-1 < Re z2" and "Re z2 < 1" and
	+ "z1 \<noteq> z2"
	+ assumes x1: "x1 \<in> poincare_circle (of_complex z1) r1 \<inter> poincare_circle (of_complex z2) r2" and
	+ x2: "x2 \<in> poincare_circle (of_complex z1) r1 \<inter> poincare_circle (of_complex z2) r2" and
	+ "x1 \<noteq> x2"
	+ shows "x1 = conjugate x2"
	+proof-
	+ have in_disc: "of_complex z1 \<in> unit_disc" "of_complex z2 \<in> unit_disc"
	+ using assms
	+ by (auto simp add: cmod_eq_Re)
	+
	+ obtain x1' x2' where x': "x1 = of_complex x1'" "x2 = of_complex x2'"
	+ using x1 x2
	+ using inf_or_of_complex[of x1] inf_or_of_complex[of x2]
	+ unfolding poincare_circle_def
	+ by auto
	+
	+ obtain Ze1 Re1 where 1: "(Ze1, Re1) = poincare_circle_euclidean (of_complex z1) r1"
	+ by (metis poincare_circle_euclidean_def)
	+ obtain Ze2 Re2 where 2: "(Ze2, Re2) = poincare_circle_euclidean (of_complex z2) r2"
	+ by (metis poincare_circle_euclidean_def)
	+ have circle: "x1' \<in> circle Ze1 Re1 \<inter> circle Ze2 Re2" "x2' \<in> circle Ze1 Re1 \<inter> circle Ze2 Re2"
	+ using poincare_circle_is_euclidean_circle[of "of_complex z1" r1]
	+ using poincare_circle_is_euclidean_circle[of "of_complex z2" r2]
	+ using assms 1 2 \<open>of_complex z1 \<in> unit_disc\<close> \<open>of_complex z2 \<in> unit_disc\<close> x'
	+ by auto (metis image_iff of_complex_inj)+
	+
	+ have "is_real Ze1" "is_real Ze2"
	+ using 1 2 \<open>is_real z1\<close> \<open>is_real z2\<close>
	+ by (simp_all add: poincare_circle_euclidean_def Let_def)
	+
	+ have "Re1 > 0" "Re2 > 0"
	+ using 1 2 in_disc \<open>r1 > 0\<close> \<open>r2 > 0\<close>
	+ using poincare_circle_in_disc(2)[of r1 "of_complex z1" Ze1 Re1]
	+ using poincare_circle_in_disc(2)[of r2 "of_complex z2" Ze2 Re2]
	+ by auto
	+
	+ have "Ze1 \<noteq> Ze2"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence eq: "Ze1 = Ze2" "Re1 = Re2"
	+ using circle(1)
	+ unfolding circle_def
	+ by auto
	+
	+ let ?A = "Ze1 - Re1" and ?B = "Ze1 + Re1"
	+ have "?A \<in> circle Ze1 Re1" "?B \<in> circle Ze1 Re1"
	+ using \<open>Re1 > 0\<close>
	+ unfolding circle_def
	+ by simp_all
	+ hence "of_complex ?A \<in> poincare_circle (of_complex z1) r1" "of_complex ?B \<in> poincare_circle (of_complex z1) r1"
	+ "of_complex ?A \<in> poincare_circle (of_complex z2) r2" "of_complex ?B \<in> poincare_circle (of_complex z2) r2"
	+ using eq
	+ using poincare_circle_is_euclidean_circle[OF \<open>of_complex z1 \<in> unit_disc\<close> \<open>r1 > 0\<close>]
	+ using poincare_circle_is_euclidean_circle[OF \<open>of_complex z2 \<in> unit_disc\<close> \<open>r2 > 0\<close>]
	+ using 1 2
	+ by auto blast+
	+ hence "poincare_distance (of_complex z1) (of_complex ?A) = poincare_distance (of_complex z1) (of_complex ?B)"
	+ "poincare_distance (of_complex z2) (of_complex ?A) = poincare_distance (of_complex z2) (of_complex ?B)"
	+ "-1 < Re (Ze1 - Re1)" "Re (Ze1 - Re1) < 1" "-1 < Re (Ze1 + Re1)" "Re (Ze1 + Re1) < 1"
	+ using \<open>is_real Ze1\<close> \<open>is_real Ze2\<close>
	+ unfolding poincare_circle_def
	+ by (auto simp add: cmod_eq_Re)
	+ hence "z1 = z2"
	+ using unique_midpoint_x_axis[of "Ze1 - Re1" "Ze1 + Re1"]
	+ using \<open>is_real Ze1\<close> \<open>is_real z1\<close> \<open>is_real z2\<close> \<open>Re1 > 0\<close> \<open>-1 < Re z1\<close> \<open>Re z1 < 1\<close> \<open>-1 < Re z2\<close> \<open>Re z2 < 1\<close>
	+ by auto
	+ thus False
	+ using \<open>z1 \<noteq> z2\<close>
	+ by simp
	+ qed
	+
	+ hence : "(Re x1')\<^sup>2 + (Im x1')\<^sup>2 - 2 Re x1' * Ze1 + Ze1 * Ze1 - cor (Re1 * Re1) = 0"
	+ "(Re x1')\<^sup>2 + (Im x1')\<^sup>2 - 2 * Re x1' * Ze2 + Ze2 * Ze2 - cor (Re2 * Re2) = 0"
	+ "(Re x2')\<^sup>2 + (Im x2')\<^sup>2 - 2 * Re x2' * Ze1 + Ze1 * Ze1 - cor (Re1 * Re1) = 0"
	+ "(Re x2')\<^sup>2 + (Im x2')\<^sup>2 - 2 * Re x2' * Ze2 + Ze2 * Ze2 - cor (Re2 * Re2) = 0"
	+ using circle_equation[of Re1 Ze1] circle_equation[of Re2 Ze2] circle
	+ using eq_cnj_iff_real[of Ze1] \<open>is_real Ze1\<close> \<open>Re1 > 0\<close>
	+ using eq_cnj_iff_real[of Ze2] \<open>is_real Ze2\<close> \<open>Re2 > 0\<close>
	+ using complex_add_cnj[of x1'] complex_add_cnj[of x2']
	+ using distrib_left[of Ze1 x1' "cnj x1'"] distrib_left[of Ze2 x1' "cnj x1'"]
	+ using distrib_left[of Ze1 x2' "cnj x2'"] distrib_left[of Ze2 x2' "cnj x2'"]
	+ by (auto simp add: complex_mult_cnj power2_eq_square field_simps)
	+
	+ hence "- 2 * Re x1' * Ze1 + Ze1 * Ze1 - cor (Re1 * Re1) = - 2 * Re x1' * Ze2 + Ze2 * Ze2 - cor (Re2 * Re2)"
	+ "- 2 * Re x2' * Ze1 + Ze1 * Ze1 - cor (Re1 * Re1) = - 2 * Re x2' * Ze2 + Ze2 * Ze2 - cor (Re2 * Re2)"
	+ by (smt add_diff_cancel_right' add_diff_eq eq_iff_diff_eq_0 minus_diff_eq mult_minus_left of_real_minus)+
	+ hence "2 * Re x1' * (Ze2 - Ze1) = (Ze2 * Ze2 - cor (Re2 * Re2)) - (Ze1 * Ze1 - cor (Re1 * Re1))"
	+ "2 * Re x2' * (Ze2 - Ze1) = (Ze2 * Ze2 - cor (Re2 * Re2)) - (Ze1 * Ze1 - cor (Re1 * Re1))"
	+ by simp_all (simp add: field_simps)+
	+ hence "2 * Re x1' * (Ze2 - Ze1) = 2 * Re x2' * (Ze2 - Ze1)"
	+ by simp
	+ hence "Re x1' = Re x2'"
	+ using \<open>Ze1 \<noteq> Ze2\<close>
	+ by simp
	+ moreover
	+ hence "(Im x1')\<^sup>2 = (Im x2')\<^sup>2"
	+ using (1) (3)
	+ by (simp add: \<open>is_real Ze1\<close> complex_eq_if_Re_eq)
	+ hence "Im x1' = Im x2' \<or> Im x1' = -Im x2'"
	+ using power2_eq_iff
	+ by blast
	+ ultimately
	+ show ?thesis
	+ using x' `x1 \<noteq> x2`
	+ using complex.expand
	+ by (metis cnj.code complex_surj conjugate_of_complex)
	+qed
	+
	+
	+text \<open>Two h-circles of the same radius centered at mutually conjugate points intersect at the x-axis\<close>
	+lemma intersect_poincare_circles_conjugate_centers:
	+ assumes in_disc: "z1 \<in> unit_disc" "z2 \<in> unit_disc" and
	+ "z1 \<noteq> z2" and "z1 = conjugate z2" and "r > 0" and
	+ u: "u \<in> poincare_circle z1 r \<inter> poincare_circle z2 r"
	+ shows "is_real (to_complex u)"
	+proof-
	+ obtain z1e r1e z2e r2e where
	+ euclidean: "(z1e, r1e) = poincare_circle_euclidean z1 r"
	+ "(z2e, r2e) = poincare_circle_euclidean z2 r"
	+ by (metis poincare_circle_euclidean_def)
	+ obtain z1' z2' where z': "z1 = of_complex z1'" "z2 = of_complex z2'"
	+ using inf_or_of_complex[of z1] inf_or_of_complex[of z2] in_disc
	+ by auto
	+ obtain u' where u': "u = of_complex u'"
	+ using u inf_or_of_complex[of u]
	+ by (auto simp add: poincare_circle_def)
	+ have "z1' = cnj z2'"
	+ using \<open>z1 = conjugate z2\<close> z'
	+ by (auto simp add: of_complex_inj)
	+ moreover
	+ let ?cz = "1 - (cmod z2')\<^sup>2"
	+ let ?den = "?cz * (cosh r - 1) / 2 + 1"
	+ have "?cz > 0"
	+ using in_disc z'
	+ by (simp add: cmod_def)
	+ hence "?den \<ge> 1"
	+ using cosh_gt_1[OF \<open>r > 0\<close>]
	+ by auto
	+ hence "?den \<noteq> 0"
	+ by simp
	+ hence "cor ?den \<noteq> 0"
	+ using of_real_eq_0_iff
	+ by blast
	+ ultimately
	+ have "r1e = r2e" "z1e = cnj z2e" "z1e \<noteq> z2e"
	+ using z' euclidean \<open>z1 \<noteq> z2\<close>
	+ unfolding poincare_circle_euclidean_def Let_def
	+ by simp_all metis
	+
	+ hence "u' \<in> circle (cnj z2e) r2e \<inter> circle z2e r2e" "z2e \<noteq> cnj z2e"
	+ using euclidean u u'
	+ using poincare_circle_is_euclidean_circle[of z1 r]
	+ using poincare_circle_is_euclidean_circle[of z2 r]
	+ using in_disc \<open>r > 0\<close>
	+ by auto (metis image_iff of_complex_inj)+
	+ hence "(cmod (u' - z2e))\<^sup>2 = (cmod(u' - cnj z2e))\<^sup>2"
	+ by (simp add: circle_def)
	+ hence "(u' - z2e) * (cnj u' - cnj z2e) = (u' - cnj z2e) * (cnj u' - z2e)"
	+ by (metis complex_cnj_cnj complex_cnj_diff complex_norm_square)
	+ hence "(z2e - cnj z2e) * (u' - cnj u') = 0"
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using u' \<open>z2e \<noteq> cnj z2e\<close> eq_cnj_iff_real[of u']
	+ by simp
	+qed
	+
	+subsection \<open>Congruent triangles\<close>
	+
	+text\<open>For every pair of triangles such that its three pairs of sides are pairwise equal there is an
	+h-isometry (a unit disc preserving Möbius transform, eventually composed with a conjugation) that
	+maps one triangle onto the other.\<close>
	+lemma unit_disc_fix_f_congruent_triangles:
	+ assumes
	+ in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc" and
	+ in_disc': "u' \<in> unit_disc" "v' \<in> unit_disc" "w' \<in> unit_disc" and
	+ d: "poincare_distance u v = poincare_distance u' v'"
	+ "poincare_distance v w = poincare_distance v' w'"
	+ "poincare_distance u w = poincare_distance u' w'"
	+ shows
	+ "\<exists> M. unit_disc_fix_f M \<and> M u = u' \<and> M v = v' \<and> M w = w'"
	+proof (cases "u = v \<or> u = w \<or> v = w")
	+ case True
	+ thus ?thesis
	+ using assms
	+ using poincare_distance_eq_0_iff[of u' v']
	+ using poincare_distance_eq_0_iff[of v' w']
	+ using poincare_distance_eq_0_iff[of u' w']
	+ using poincare_distance_eq_ex_moebius[of v w v' w']
	+ using poincare_distance_eq_ex_moebius[of u w u' w']
	+ using poincare_distance_eq_ex_moebius[of u v u' v']
	+ by (metis unit_disc_fix_f_def)
	+next
	+ case False
	+
	+ have "\<forall> w u' v' w'. w \<in> unit_disc \<and> u' \<in> unit_disc \<and> v' \<in> unit_disc \<and> w' \<in> unit_disc \<and> w \<noteq> u \<and> w \<noteq> v \<and>
	+ poincare_distance u v = poincare_distance u' v' \<and>
	+ poincare_distance v w = poincare_distance v' w' \<and>
	+ poincare_distance u w = poincare_distance u' w' \<longrightarrow>
	+ (\<exists> M. unit_disc_fix_f M \<and> M u = u' \<and> M v = v' \<and> M w = w')" (is "?P u v")
	+ proof (rule wlog_positive_x_axis[where P="?P"])
	+ show "v \<in> unit_disc" "u \<in> unit_disc"
	+ by fact+
	+ next
	+ show "u \<noteq> v"
	+ using False
	+ by simp
	+ next
	+ fix x
	+ assume x: "is_real x" "0 < Re x" "Re x < 1"
	+
	+ hence "of_complex x \<noteq> 0\<^sub>h"
	+ using of_complex_zero_iff[of x]
	+ by (auto simp add: complex.expand)
	+
	+ show "?P 0\<^sub>h (of_complex x)"
	+ proof safe
	+ fix w u' v' w'
	+ assume in_disc: "w \<in> unit_disc" "u' \<in> unit_disc" "v' \<in> unit_disc" "w' \<in> unit_disc"
	+ assume "poincare_distance 0\<^sub>h (of_complex x) = poincare_distance u' v'"
	+ then obtain M' where M': "unit_disc_fix M'" "moebius_pt M' u' = 0\<^sub>h" "moebius_pt M' v' = (of_complex x)"
	+ using poincare_distance_eq_ex_moebius[of u' v' "0\<^sub>h" "of_complex x"] in_disc x
	+ by (auto simp add: cmod_eq_Re)
	+
	+ let ?w = "moebius_pt M' w'"
	+ have "?w \<in> unit_disc"
	+ using \<open>unit_disc_fix M'\<close> \<open>w' \<in> unit_disc\<close>
	+ by simp
	+
	+ assume "w \<noteq> 0\<^sub>h" "w \<noteq> of_complex x"
	+ hence dist_gt_0: "poincare_distance 0\<^sub>h w > 0" "poincare_distance (of_complex x) w > 0"
	+ using poincare_distance_eq_0_iff[of "0\<^sub>h" w] in_disc poincare_distance_ge0[of "0\<^sub>h" w]
	+ using poincare_distance_eq_0_iff[of "of_complex x" w] in_disc poincare_distance_ge0[of "of_complex x" w]
	+ using x
	+ by (simp_all add: cmod_eq_Re)
	+
	+ assume "poincare_distance (of_complex x) w = poincare_distance v' w'"
	+ "poincare_distance 0\<^sub>h w = poincare_distance u' w'"
	+ hence "poincare_distance 0\<^sub>h ?w = poincare_distance 0\<^sub>h w"
	+ "poincare_distance (of_complex x) ?w = poincare_distance (of_complex x) w"
	+ using M'(1) M'(2)[symmetric] M'(3)[symmetric] in_disc
	+ using unit_disc_fix_preserve_poincare_distance[of M' u' w']
	+ using unit_disc_fix_preserve_poincare_distance[of M' v' w']
	+ by simp_all
	+ hence "?w \<in> poincare_circle 0\<^sub>h (poincare_distance 0\<^sub>h w) \<inter> poincare_circle (of_complex x) (poincare_distance (of_complex x) w)"
	+ "w \<in> poincare_circle 0\<^sub>h (poincare_distance 0\<^sub>h w) \<inter> poincare_circle (of_complex x) (poincare_distance (of_complex x) w)"
	+ using \<open>?w \<in> unit_disc\<close> \<open>w \<in> unit_disc\<close>
	+ unfolding poincare_circle_def
	+ by simp_all
	+ hence "?w = w \<or> ?w = conjugate w"
	+ using intersect_poincare_circles_x_axis[of 0 x "poincare_distance 0\<^sub>h w" "poincare_distance (of_complex x) w" ?w w] x
	+ using \<open>of_complex x \<noteq> 0\<^sub>h\<close> dist_gt_0
	+ using poincare_distance_eq_0_iff
	+ by auto
	+ thus "\<exists>M. unit_disc_fix_f M \<and> M 0\<^sub>h = u' \<and> M (of_complex x) = v' \<and> M w = w'"
	+ proof
	+ assume "moebius_pt M' w' = w"
	+ thus ?thesis
	+ using M'
	+ using moebius_pt_invert[of M' u' "0\<^sub>h"]
	+ using moebius_pt_invert[of M' v' "of_complex x"]
	+ using moebius_pt_invert[of M' w' "w"]
	+ apply (rule_tac x="moebius_pt (-M')" in exI)
	+ apply (simp add: unit_disc_fix_f_def)
	+ apply (rule_tac x="-M'" in exI, simp)
	+ done
	+ next
	+ let ?M = "moebius_pt (-M') \<circ> conjugate"
	+ assume "moebius_pt M' w' = conjugate w"
	+ hence "?M w = w'"
	+ using moebius_pt_invert[of M' w' "conjugate w"]
	+ by simp
	+ moreover
	+ have "?M 0\<^sub>h = u'" "?M (of_complex x) = v'"
	+ using moebius_pt_invert[of M' u' "0\<^sub>h"]
	+ using moebius_pt_invert[of M' v' "of_complex x"]
	+ using M' \<open>is_real x\<close> eq_cnj_iff_real[of x]
	+ by simp_all
	+ moreover
	+ have "unit_disc_fix_f ?M"
	+ using \<open>unit_disc_fix M'\<close>
	+ unfolding unit_disc_fix_f_def
	+ by (rule_tac x="-M'" in exI, simp)
	+ ultimately
	+ show ?thesis
	+ by blast
	+ qed
	+ qed
	+ next
	+ fix M u v
	+ assume 1: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc"
	+ let ?Mu = "moebius_pt M u" and ?Mv = "moebius_pt M v"
	+ assume 2: "?P ?Mu ?Mv"
	+ show "?P u v"
	+ proof safe
	+ fix w u' v' w'
	+ let ?Mw = "moebius_pt M w" and ?Mu' = "moebius_pt M u'" and ?Mv' = "moebius_pt M v'" and ?Mw' = "moebius_pt M w'"
	+ assume "w \<in> unit_disc" "u' \<in> unit_disc" "v' \<in> unit_disc" "w' \<in> unit_disc" "w \<noteq> u" "w \<noteq> v"
	+ "poincare_distance u v = poincare_distance u' v'"
	+ "poincare_distance v w = poincare_distance v' w'"
	+ "poincare_distance u w = poincare_distance u' w'"
	+ then obtain M' where M': "unit_disc_fix_f M'" "M' ?Mu = ?Mu'" "M' ?Mv = ?Mv'" "M' ?Mw = ?Mw'"
	+ using 1 2[rule_format, of ?Mw ?Mu' ?Mv' ?Mw']
	+ by auto
	+
	+ let ?M = "moebius_pt (-M) \<circ> M' \<circ> moebius_pt M"
	+ show "\<exists>M. unit_disc_fix_f M \<and> M u = u' \<and> M v = v' \<and> M w = w'"
	+ proof (rule_tac x="?M" in exI, safe)
	+ show "unit_disc_fix_f ?M"
	+ using M'(1) \<open>unit_disc_fix M\<close>
	+ by (subst unit_disc_fix_f_comp, subst unit_disc_fix_f_comp, simp_all)
	+ next
	+ show "?M u = u'" "?M v = v'" "?M w = w'"
	+ using M'
	+ by auto
	+ qed
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms False
	+ by auto
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Poincare_Disc/Poincare_Distance.thy b/thys/Poincare_Disc/Poincare_Distance.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Poincare_Distance.thy
	@@ -0,0 +1,1567 @@
	+theory Poincare_Distance
	+ imports Poincare_Lines_Ideal_Points Hyperbolic_Functions
	+begin
	+
	+(* ------------------------------------------------------------------ *)
	+section \<open>H-distance in the Poincar\'e model\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>Informally, the \emph{h-distance} between the two h-points is defined as the absolute value of
	+the logarithm of the cross ratio between those two points and the two ideal points.\<close>
	+
	+abbreviation Re_cross_ratio where "Re_cross_ratio z u v w \<equiv> Re (to_complex (cross_ratio z u v w))"
	+
	+definition calc_poincare_distance :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo \<Rightarrow> real" where
	+ [simp]: "calc_poincare_distance u i1 v i2 = abs (ln (Re_cross_ratio u i1 v i2))"
	+
	+definition poincare_distance_pred :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> real \<Rightarrow> bool" where
	+ [simp]: "poincare_distance_pred u v d \<longleftrightarrow>
	+ (u = v \<and> d = 0) \<or> (u \<noteq> v \<and> (\<forall> i1 i2. ideal_points (poincare_line u v) = {i1, i2} \<longrightarrow> d = calc_poincare_distance u i1 v i2))"
	+
	+definition poincare_distance :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> real" where
	+ "poincare_distance u v = (THE d. poincare_distance_pred u v d)"
	+
	+text\<open>We shown that the described cross-ratio is always finite,
	+positive real number.\<close>
	+lemma distance_cross_ratio_real_positive:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "u \<noteq> v"
	+ shows "\<forall> i1 i2. ideal_points (poincare_line u v) = {i1, i2} \<longrightarrow>
	+ cross_ratio u i1 v i2 \<noteq> \<infinity>\<^sub>h \<and> is_real (to_complex (cross_ratio u i1 v i2)) \<and> Re_cross_ratio u i1 v i2 > 0" (is "?P u v")
	+proof (rule wlog_positive_x_axis[OF assms])
	+ fix x
	+ assume *: "is_real x" "0 < Re x" "Re x < 1"
	+ hence "x \<noteq> -1" "x \<noteq> 1"
	+ by auto
	+ hence **: "of_complex x \<noteq> \<infinity>\<^sub>h" "of_complex x \<noteq> 0\<^sub>h" "of_complex x \<noteq> of_complex (-1)" "of_complex 1 \<noteq> of_complex x"
	+ "of_complex x \<in> circline_set x_axis"
	+ using *
	+ unfolding circline_set_x_axis
	+ by (auto simp add: of_complex_inj)
	+
	+ have ***: "0\<^sub>h \<noteq> of_complex (-1)" "0\<^sub>h \<noteq> of_complex 1"
	+ by (metis of_complex_zero_iff zero_neq_neg_one, simp)
	+
	+ have ****: "- x - 1 \<noteq> 0" "x - 1 \<noteq> 0"
	+ using \<open>x \<noteq> -1\<close> \<open>x \<noteq> 1\<close>
	+ by (metis add.inverse_inverse eq_iff_diff_eq_0, simp)
	+
	+ have "poincare_line 0\<^sub>h (of_complex x) = x_axis"
	+ using **
	+ by (simp add: poincare_line_0_real_is_x_axis)
	+ thus "?P 0\<^sub>h (of_complex x)"
	+ using * * ****
	+ using cross_ratio_not_inf[of "0\<^sub>h" "of_complex 1" "of_complex (-1)" "of_complex x"]
	+ using cross_ratio_not_inf[of "0\<^sub>h" "of_complex (-1)" "of_complex 1" "of_complex x"]
	+ using cross_ratio_real[of 0 "-1" x 1] cross_ratio_real[of 0 1 x "-1"]
	+ apply (auto simp add: poincare_line_0_real_is_x_axis doubleton_eq_iff circline_set_x_axis)
	+ apply (subst cross_ratio, simp_all, subst Re_complex_div_gt_0, simp, subst mult_neg_neg, simp_all)+
	+ done
	+next
	+ fix M u v
	+ let ?Mu = "moebius_pt M u" and ?Mv = "moebius_pt M v"
	+ assume *: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ "?P ?Mu ?Mv"
	+ show "?P u v"
	+ proof safe
	+ fix i1 i2
	+ let ?cr = "cross_ratio u i1 v i2"
	+ assume **: "ideal_points (poincare_line u v) = {i1, i2}"
	+ have "i1 \<noteq> u" "i1 \<noteq> v" "i2 \<noteq> u" "i2 \<noteq> v" "i1 \<noteq> i2"
	+ using ideal_points_different[OF (2-3), of i1 i2] * \<open>u \<noteq> v\<close>
	+ by auto
	+ hence "0 < Re (to_complex ?cr) \<and> is_real (to_complex ?cr) \<and> ?cr \<noteq> \<infinity>\<^sub>h"
	+ using * **
	+ apply (erule_tac x="moebius_pt M i1" in allE)
	+ apply (erule_tac x="moebius_pt M i2" in allE)
	+ apply (subst (asm) ideal_points_poincare_line_moebius[of M u v i1 i2], simp_all)
	+ done
	+ thus "0 < Re (to_complex ?cr)" "is_real (to_complex ?cr)" "?cr = \<infinity>\<^sub>h \<Longrightarrow> False"
	+ by simp_all
	+ qed
	+qed
	+
	+text\<open>Next we can show that for every different points from the unit disc there is exactly one number
	+that satisfies the h-distance predicate.\<close>
	+lemma distance_unique:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "\<exists>! d. poincare_distance_pred u v d"
	+proof (cases "u = v")
	+ case True
	+ thus ?thesis
	+ by auto
	+next
	+ case False
	+ obtain i1 i2 where *: "i1 \<noteq> i2" "ideal_points (poincare_line u v) = {i1, i2}"
	+ using obtain_ideal_points[OF is_poincare_line_poincare_line] \<open>u \<noteq> v\<close>
	+ by blast
	+ let ?d = "calc_poincare_distance u i1 v i2"
	+ show ?thesis
	+ proof (rule ex1I)
	+ show "poincare_distance_pred u v ?d"
	+ using * \<open>u \<noteq> v\<close>
	+ proof (simp del: calc_poincare_distance_def, safe)
	+ fix i1' i2'
	+ assume "{i1, i2} = {i1', i2'}"
	+ hence **: "(i1' = i1 \<and> i2' = i2) \<or> (i1' = i2 \<and> i2' = i1)"
	+ using doubleton_eq_iff[of i1 i2 i1' i2']
	+ by blast
	+ have all_different: "u \<noteq> i1" "u \<noteq> i2" "v \<noteq> i1" "v \<noteq> i2" "u \<noteq> i1'" "u \<noteq> i2'" "v \<noteq> i1'" "v \<noteq> i2'" "i1 \<noteq> i2"
	+ using ideal_points_different[OF assms, of i1 i2] * ** \<open>u \<noteq> v\<close>
	+ by auto
	+
	+ show "calc_poincare_distance u i1 v i2 = calc_poincare_distance u i1' v i2'"
	+ proof-
	+ let ?cr = "cross_ratio u i1 v i2"
	+ let ?cr' = "cross_ratio u i1' v i2'"
	+
	+ have "Re (to_complex ?cr) > 0" "is_real (to_complex ?cr)"
	+ "Re (to_complex ?cr') > 0" "is_real (to_complex ?cr')"
	+ using False distance_cross_ratio_real_positive[OF assms(1-2)] * **
	+ by auto
	+
	+ thus ?thesis
	+ using **
	+ using cross_ratio_not_zero cross_ratio_not_inf all_different
	+ by auto (subst cross_ratio_commute_24, subst reciprocal_real, simp_all add: ln_div)
	+ qed
	+ qed
	+ next
	+ fix d
	+ assume "poincare_distance_pred u v d"
	+ thus "d = ?d"
	+ using * \<open>u \<noteq> v\<close>
	+ by auto
	+ qed
	+qed
	+
	+lemma poincare_distance_satisfies_pred [simp]:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "poincare_distance_pred u v (poincare_distance u v)"
	+ using distance_unique[OF assms] theI'[of "poincare_distance_pred u v"]
	+ unfolding poincare_distance_def
	+ by blast
	+
	+lemma poincare_distance_I:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "u \<noteq> v" and "ideal_points (poincare_line u v) = {i1, i2}"
	+ shows "poincare_distance u v = calc_poincare_distance u i1 v i2"
	+ using assms
	+ using poincare_distance_satisfies_pred[OF assms(1-2)]
	+ by simp
	+
	+lemma poincare_distance_refl [simp]:
	+ assumes "u \<in> unit_disc"
	+ shows "poincare_distance u u = 0"
	+ using assms
	+ using poincare_distance_satisfies_pred[OF assms assms]
	+ by simp
	+
	+text\<open>Unit disc preserving Möbius transformations preserve h-distance. \<close>
	+lemma unit_disc_fix_preserve_poincare_distance [simp]:
	+ assumes "unit_disc_fix M" and "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "poincare_distance (moebius_pt M u) (moebius_pt M v) = poincare_distance u v"
	+proof (cases "u = v")
	+ case True
	+ have "moebius_pt M u \<in> unit_disc" "moebius_pt M v \<in> unit_disc"
	+ using unit_disc_fix_iff[OF assms(1), symmetric] assms
	+ by blast+
	+ thus ?thesis
	+ using assms \<open>u = v\<close>
	+ by simp
	+next
	+ case False
	+ obtain i1 i2 where *: "ideal_points (poincare_line u v) = {i1, i2}"
	+ using \<open>u \<noteq> v\<close>
	+ by (rule obtain_ideal_points[OF is_poincare_line_poincare_line[of u v]])
	+ let ?Mu = "moebius_pt M u" and ?Mv = "moebius_pt M v" and ?Mi1 = "moebius_pt M i1" and ?Mi2 = "moebius_pt M i2"
	+
	+ have **: "?Mu \<in> unit_disc" "?Mv \<in> unit_disc"
	+ using assms
	+ using unit_disc_fix_iff
	+ by blast+
	+
	+ have ***: "?Mu \<noteq> ?Mv"
	+ using \<open>u \<noteq> v\<close>
	+ by simp
	+
	+ have "poincare_distance u v = calc_poincare_distance u i1 v i2"
	+ using poincare_distance_I[OF assms(2-3) \<open>u \<noteq> v\<close> *]
	+ by auto
	+ moreover
	+ have "unit_circle_fix M"
	+ using assms
	+ by simp
	+ hence ++: "ideal_points (poincare_line ?Mu ?Mv) = {?Mi1, ?Mi2}"
	+ using \<open>u \<noteq> v\<close> assms *
	+ by simp
	+ have "poincare_distance ?Mu ?Mv = calc_poincare_distance ?Mu ?Mi1 ?Mv ?Mi2"
	+ by (rule poincare_distance_I[OF * ++])
	+ moreover
	+ have "calc_poincare_distance ?Mu ?Mi1 ?Mv ?Mi2 = calc_poincare_distance u i1 v i2"
	+ using ideal_points_different[OF assms(2-3) \<open>u \<noteq> v\<close> *]
	+ unfolding calc_poincare_distance_def
	+ by (subst moebius_preserve_cross_ratio[symmetric], simp_all)
	+ ultimately
	+ show ?thesis
	+ by simp
	+qed
	+
	+
	+text\<open>Knowing ideal points for x-axis, we can easily explicitly calculate distances.\<close>
	+lemma poincare_distance_x_axis_x_axis:
	+ assumes "x \<in> unit_disc" and "y \<in> unit_disc" and "x \<in> circline_set x_axis" and "y \<in> circline_set x_axis"
	+ shows "poincare_distance x y =
	+ (let x' = to_complex x; y' = to_complex y
	+ in abs (ln (Re (((1 + x') * (1 - y')) / ((1 - x') * (1 + y'))))))"
	+proof-
	+ obtain x' y' where *: "x = of_complex x'" "y = of_complex y'"
	+ using inf_or_of_complex[of x] inf_or_of_complex[of y] \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close>
	+ by auto
	+
	+ have "cmod x' < 1" "cmod y' < 1"
	+ using \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close> *
	+ by (metis unit_disc_iff_cmod_lt_1)+
	+ hence **: "x' \<noteq> 1" "x' \<noteq> 1" "y' \<noteq> -1" "y' \<noteq> 1"
	+ by auto
	+
	+ have "1 + y' \<noteq> 0"
	+ using **
	+ by (metis add.left_cancel add_neg_numeral_special(7))
	+
	+ show ?thesis
	+ proof (cases "x = y")
	+ case True
	+ thus ?thesis
	+ using assms(1-2)
	+ using unit_disc_iff_cmod_lt_1[of "to_complex x"] * ** `1 + y' \<noteq> 0`
	+ by auto
	+
	+ next
	+ case False
	+ hence "poincare_line x y = x_axis"
	+ using poincare_line_x_axis[OF assms]
	+ by simp
	+ hence "ideal_points (poincare_line x y) = {of_complex (-1), of_complex 1}"
	+ by simp
	+ hence "poincare_distance x y = calc_poincare_distance x (of_complex (-1)) y (of_complex 1)"
	+ using poincare_distance_I assms \<open>x \<noteq> y\<close>
	+ by auto
	+ also have "... = abs (ln (Re (((x' + 1) * (y' - 1)) / ((x' - 1) * (y' + 1)))))"
	+ using * \<open>cmod x' < 1\<close> \<open>cmod y' < 1\<close>
	+ by (simp, transfer, transfer, auto)
	+ finally
	+ show ?thesis
	+ using *
	+ by (metis (no_types, lifting) add.commute minus_diff_eq minus_divide_divide mult_minus_left mult_minus_right to_complex_of_complex)
	+ qed
	+qed
	+
	+lemma poincare_distance_zero_x_axis:
	+ assumes "x \<in> unit_disc" and "x \<in> circline_set x_axis"
	+ shows "poincare_distance 0\<^sub>h x = (let x' = to_complex x in abs (ln (Re ((1 - x') / (1 + x')))))"
	+ using assms
	+ using poincare_distance_x_axis_x_axis[of "0\<^sub>h" x]
	+ by (simp add: Let_def)
	+
	+lemma poincare_distance_zero:
	+ assumes "x \<in> unit_disc"
	+ shows "poincare_distance 0\<^sub>h x = (let x' = to_complex x in abs (ln (Re ((1 - cmod x') / (1 + cmod x')))))" (is "?P x")
	+proof (cases "x = 0\<^sub>h")
	+ case True
	+ thus ?thesis
	+ by auto
	+next
	+ case False
	+ show ?thesis
	+ proof (rule wlog_rotation_to_positive_x_axis)
	+ show "x \<in> unit_disc" "x \<noteq> 0\<^sub>h" by fact+
	+ next
	+ fix \<phi> u
	+ assume "u \<in> unit_disc" "u \<noteq> 0\<^sub>h" "?P (moebius_pt (moebius_rotation \<phi>) u)"
	+ thus "?P u"
	+ using unit_disc_fix_preserve_poincare_distance[of "moebius_rotation \<phi>" "0\<^sub>h" u]
	+ by (cases "u = \<infinity>\<^sub>h") (simp_all add: Let_def)
	+ next
	+ fix x
	+ assume "is_real x" "0 < Re x" "Re x < 1"
	+ thus "?P (of_complex x)"
	+ using poincare_distance_zero_x_axis[of "of_complex x"]
	+ by simp (auto simp add: circline_set_x_axis cmod_eq_Re complex_is_Real_iff)
	+ qed
	+qed
	+
	+lemma poincare_distance_zero_opposite [simp]:
	+ assumes "of_complex z \<in> unit_disc"
	+ shows "poincare_distance 0\<^sub>h (of_complex (- z)) = poincare_distance 0\<^sub>h (of_complex z)"
	+proof-
	+ have *: "of_complex (-z) \<in> unit_disc"
	+ using assms
	+ by auto
	+ show ?thesis
	+ using poincare_distance_zero[OF assms]
	+ using poincare_distance_zero[OF *]
	+ by simp
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Distance explicit formula\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>Instead of the h-distance itself, very frequently its hyperbolic cosine is analyzed.\<close>
	+
	+abbreviation "cosh_dist u v \<equiv> cosh (poincare_distance u v)"
	+
	+lemma cosh_poincare_distance_cross_ratio_average:
	+ assumes "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v" "ideal_points (poincare_line u v) = {i1, i2}"
	+ shows "cosh_dist u v =
	+ ((Re_cross_ratio u i1 v i2) + (Re_cross_ratio v i1 u i2)) / 2"
	+proof-
	+ let ?cr = "cross_ratio u i1 v i2"
	+ let ?crRe = "Re (to_complex ?cr)"
	+ have "?cr \<noteq> \<infinity>\<^sub>h" "is_real (to_complex ?cr)" "?crRe > 0"
	+ using distance_cross_ratio_real_positive[OF assms(1-3)] assms(4)
	+ by simp_all
	+ then obtain cr where *: "cross_ratio u i1 v i2 = of_complex cr" "cr \<noteq> 0" "is_real cr" "Re cr > 0"
	+ using inf_or_of_complex[of "cross_ratio u i1 v i2"]
	+ by (smt to_complex_of_complex zero_complex.simps(1))
	+ thus ?thesis
	+ using *
	+ using assms cross_ratio_commute_13[of v i1 u i2]
	+ unfolding poincare_distance_I[OF assms] calc_poincare_distance_def cosh_def
	+ by (cases "Re cr \<ge> 1")
	+ (auto simp add: ln_div[of 0] exp_minus field_simps Re_divide power2_eq_square complex.expand)
	+qed
	+
	+definition poincare_distance_formula' :: "complex \<Rightarrow> complex \<Rightarrow> real" where
	+[simp]: "poincare_distance_formula' u v = 1 + 2 * ((cmod (u - v))\<^sup>2 / ((1 - (cmod u)\<^sup>2) * (1 - (cmod v)\<^sup>2)))"
	+
	+text\<open>Next we show that the following formula expresses h-distance between any two h-points (note
	+that the ideal points do not figure anymore).\<close>
	+
	+definition poincare_distance_formula :: "complex \<Rightarrow> complex \<Rightarrow> real" where
	+ [simp]: "poincare_distance_formula u v = arcosh (poincare_distance_formula' u v)"
	+
	+lemma blaschke_preserve_distance_formula [simp]:
	+ assumes "of_complex k \<in> unit_disc" "u \<in> unit_disc" "v \<in> unit_disc"
	+ shows "poincare_distance_formula (to_complex (moebius_pt (blaschke k) u)) (to_complex (moebius_pt (blaschke k) v)) =
	+ poincare_distance_formula (to_complex u) (to_complex v)"
	+proof (cases "k = 0")
	+ case True
	+ thus ?thesis
	+ by simp
	+next
	+ case False
	+ obtain u' v' where *: "u' = to_complex u" "v' = to_complex v"
	+ by auto
	+
	+ have "cmod u' < 1" "cmod v' < 1" "cmod k < 1"
	+ using assms *
	+ using inf_or_of_complex[of u] inf_or_of_complex[of v]
	+ by auto
	+
	+ obtain nu du nv dv d kk ddu ddv where
	+ *: "nu = u' - k" "du = 1 - cnj k u'" "nv = v' - k" "dv = 1 - cnj k * v'"
	+ "d = u' - v'" "ddu = 1 - u'cnj u'" "ddv = 1 - v'cnj v'" "kk = 1 - k*cnj k"
	+ by auto
	+
	+ have d: "nudv - nvdu = d*kk"
	+ by (subst **)+ (simp add: field_simps)
	+ have ddu: "ducnj du - nucnj nu = ddu*kk"
	+ by (subst **)+ (simp add: field_simps)
	+ have ddv: "dvcnj dv - nvcnj nv = ddv*kk"
	+ by (subst **)+ (simp add: field_simps)
	+
	+ have "du \<noteq> 0"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "cmod (1 - cnj k * u') = 0"
	+ using \<open>du = 1 - cnj k * u'\<close>
	+ by auto
	+ hence "cmod (cnj k * u') = 1"
	+ by auto
	+ hence "cmod k * cmod u' = 1"
	+ by auto
	+ thus False
	+ using \<open>cmod k < 1\<close> \<open>cmod u' < 1\<close>
	+ using mult_strict_mono[of "cmod k" 1 "cmod u'" 1]
	+ by simp
	+ qed
	+
	+ have "dv \<noteq> 0"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "cmod (1 - cnj k * v') = 0"
	+ using \<open>dv = 1 - cnj k * v'\<close>
	+ by auto
	+ hence "cmod (cnj k * v') = 1"
	+ by auto
	+ hence "cmod k * cmod v' = 1"
	+ by auto
	+ thus False
	+ using \<open>cmod k < 1\<close> \<open>cmod v' < 1\<close>
	+ using mult_strict_mono[of "cmod k" 1 "cmod v'" 1]
	+ by simp
	+ qed
	+
	+ have "kk \<noteq> 0"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "cmod (1 - k * cnj k) = 0"
	+ using \<open>kk = 1 - k * cnj k\<close>
	+ by auto
	+ hence "cmod (k * cnj k) = 1"
	+ by auto
	+ hence "cmod k * cmod k = 1"
	+ by auto
	+ thus False
	+ using \<open>cmod k < 1\<close>
	+ using mult_strict_mono[of "cmod k" 1 "cmod k" 1]
	+ by simp
	+ qed
	+
	+ note nz = \<open>du \<noteq> 0\<close> \<open>dv \<noteq> 0\<close> \<open>kk \<noteq> 0\<close>
	+
	+
	+ have "nu / du - nv / dv = (nudv - nvdu) / (du * dv)"
	+ using nz
	+ by (simp add: field_simps)
	+ hence "(cmod (nu/du - nv/dv))\<^sup>2 = cmod ((dkk) / (dudv) * (cnj ((dkk) / (dudv))))" (is "?lhs = _")
	+ unfolding complex_mod_mult_cnj[symmetric]
	+ by (subst (asm) d) simp
	+ also have "... = cmod ((dcnj dkkkk) / (ducnj dudvcnj dv))"
	+ by (simp add: field_simps)
	+ finally have 1: "?lhs = cmod ((dcnj dkkkk) / (ducnj dudvcnj dv))"
	+ .
	+
	+ have "(1 - ((cmod nu) / (cmod du))\<^sup>2)*(1 - ((cmod nv) / (cmod dv))\<^sup>2) =
	+ (1 - cmod((nu * cnj nu) / (du * cnj du)))(1 - cmod((nv cnj nv) / (dv * cnj dv)))" (is "?rhs = _")
	+ by (metis cmod_divide complex_mod_mult_cnj power_divide)
	+ also have "... = cmod(((ducnj du - nucnj nu) / (du * cnj du)) * ((dvcnj dv - nvcnj nv) / (dv * cnj dv)))"
	+ proof-
	+ have "u' \<noteq> 1 / cnj k" "v' \<noteq> 1 / cnj k"
	+ using \<open>cmod u' < 1\<close> \<open>cmod v' < 1\<close> \<open>cmod k < 1\<close>
	+ by (auto simp add: False)
	+ moreover
	+ have "cmod k \<noteq> 1"
	+ using \<open>cmod k < 1\<close>
	+ by linarith
	+ ultimately
	+ have "cmod (nu/du) < 1" "cmod (nv/dv) < 1"
	+ using **(1-4)
	+ using unit_disc_fix_discI[OF blaschke_unit_disc_fix[OF \<open>cmod k < 1\<close>] \<open>u \<in> unit_disc\<close>] \<open>u' = to_complex u\<close>
	+ using unit_disc_fix_discI[OF blaschke_unit_disc_fix[OF \<open>cmod k < 1\<close>] \<open>v \<in> unit_disc\<close>] \<open>v' = to_complex v\<close>
	+ using inf_or_of_complex[of u] \<open>u \<in> unit_disc\<close> inf_or_of_complex[of v] \<open>v \<in> unit_disc\<close>
	+ using moebius_pt_blaschke[of k u'] using moebius_pt_blaschke[of k v']
	+ by auto
	+ hence "(cmod (nu/du))\<^sup>2 < 1" "(cmod (nv/dv))\<^sup>2 < 1"
	+ by (simp_all add: cmod_def)
	+ hence "cmod (nu * cnj nu / (du * cnj du)) < 1" "cmod (nv * cnj nv / (dv * cnj dv)) < 1"
	+ by (metis complex_mod_mult_cnj norm_divide power_divide)+
	+ moreover
	+ have "is_real (nu * cnj nu / (du * cnj du))" "is_real (nv * cnj nv / (dv * cnj dv))"
	+ using eq_cnj_iff_real[of "nu * cnj nu / (du * cnj du)"]
	+ using eq_cnj_iff_real[of "nv * cnj nv / (dv * cnj dv)"]
	+ by (auto simp add: mult.commute)
	+ moreover
	+ have "Re (nu * cnj nu / (du * cnj du)) \<ge> 0" "Re (nv * cnj nv / (dv * cnj dv)) \<ge> 0"
	+ using \<open>du \<noteq> 0\<close> \<open>dv \<noteq> 0\<close>
	+ unfolding complex_mult_cnj_cmod
	+ by simp_all
	+ ultimately
	+ have "1 - cmod (nu * cnj nu / (du * cnj du)) = cmod (1 - nu * cnj nu / (du * cnj du))"
	+ "1 - cmod (nv * cnj nv / (dv * cnj dv)) = cmod (1 - nv * cnj nv / (dv * cnj dv))"
	+ by (simp_all add: cmod_def)
	+ thus ?thesis
	+ using nz
	+ apply simp
	+ apply (subst diff_divide_eq_iff, simp, simp)
	+ apply (subst diff_divide_eq_iff, simp, simp)
	+ done
	+ qed
	+ also have "... = cmod(((ddu * kk) / (du * cnj du)) * ((ddv * kk) / (dv * cnj dv)))"
	+ by (subst ddu, subst ddv, simp)
	+ also have "... = cmod((dduddvkkkk) / (ducnj dudvcnj dv))"
	+ by (simp add: field_simps)
	+ finally have 2: "?rhs = cmod((dduddvkkkk) / (ducnj dudvcnj dv))"
	+ .
	+
	+ have "?lhs / ?rhs =
	+ cmod ((dcnj dkkkk) / (ducnj dudvcnj dv)) / cmod((dduddvkkkk) / (ducnj dudvcnj dv))"
	+ by (subst 1, subst 2, simp)
	+ also have "... = cmod ((dcnj d)/(dduddv))"
	+ using nz
	+ by simp
	+ also have "... = (cmod d)\<^sup>2 / ((1 - (cmod u')\<^sup>2)*(1 - (cmod v')\<^sup>2))"
	+ proof-
	+ have "(cmod u')\<^sup>2 < 1" "(cmod v')\<^sup>2 < 1"
	+ using \<open>cmod u' < 1\<close> \<open>cmod v' < 1\<close>
	+ by (simp_all add: cmod_def)
	+ hence "cmod (1 - u' * cnj u') = 1 - (cmod u')\<^sup>2" "cmod (1 - v' * cnj v') = 1 - (cmod v')\<^sup>2"
	+ by (auto simp add: cmod_eq_Re cmod_power2 power2_eq_square[symmetric])
	+ thus ?thesis
	+ using nz
	+ apply (subst **)+
	+ unfolding complex_mod_mult_cnj[symmetric]
	+ by simp
	+ qed
	+ finally
	+ have 3: "?lhs / ?rhs = (cmod d)\<^sup>2 / ((1 - (cmod u')\<^sup>2)*(1 - (cmod v')\<^sup>2))"
	+ .
	+
	+ have "cmod k \<noteq> 1" "u' \<noteq> 1 / cnj k" "v' \<noteq> 1 / cnj k" "u \<noteq> \<infinity>\<^sub>h" "v \<noteq> \<infinity>\<^sub>h"
	+ using \<open>cmod k < 1\<close> \<open>u \<in> unit_disc\<close> \<open>v \<in> unit_disc\<close> * \<open>k \<noteq> 0\<close> ** \<open>kk \<noteq> 0\<close> nz
	+ by auto
	+ thus ?thesis using assms
	+ using * ** 3
	+ using moebius_pt_blaschke[of k u']
	+ using moebius_pt_blaschke[of k v']
	+ by simp
	+qed
	+
	+text \<open>To prove the equivalence between the h-distance definition and the distance formula, we shall
	+employ the without loss of generality principle. Therefore, we must show that the distance formula
	+is preserved by h-isometries.\<close>
	+
	+text\<open>Rotation preserve @{term poincare_distance_formula}.\<close>
	+lemma rotation_preserve_distance_formula [simp]:
	+ assumes "u \<in> unit_disc" "v \<in> unit_disc"
	+ shows "poincare_distance_formula (to_complex (moebius_pt (moebius_rotation \<phi>) u)) (to_complex (moebius_pt (moebius_rotation \<phi>) v)) =
	+ poincare_distance_formula (to_complex u) (to_complex v)"
	+ using assms
	+ using inf_or_of_complex[of u] inf_or_of_complex[of v]
	+ by auto
	+
	+text\<open>Unit disc fixing Möbius preserve @{term poincare_distance_formula}.\<close>
	+lemma unit_disc_fix_preserve_distance_formula [simp]:
	+ assumes "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc"
	+ shows "poincare_distance_formula (to_complex (moebius_pt M u)) (to_complex (moebius_pt M v)) =
	+ poincare_distance_formula (to_complex u) (to_complex v)" (is "?P' u v M")
	+proof-
	+ have "\<forall> u \<in> unit_disc. \<forall> v \<in> unit_disc. ?P' u v M" (is "?P M")
	+ proof (rule wlog_unit_disc_fix[OF assms(1)])
	+ fix k
	+ assume "cmod k < 1"
	+ hence "of_complex k \<in> unit_disc"
	+ by simp
	+ thus "?P (blaschke k)"
	+ using blaschke_preserve_distance_formula
	+ by simp
	+ next
	+ fix \<phi>
	+ show "?P (moebius_rotation \<phi>)"
	+ using rotation_preserve_distance_formula
	+ by simp
	+ next
	+ fix M1 M2
	+ assume : "?P M1" and *: "?P M2" and u11: "unit_disc_fix M1" "unit_disc_fix M2"
	+ thus "?P (M1 + M2)"
	+ by (auto simp del: poincare_distance_formula_def)
	+ qed
	+ thus ?thesis
	+ using assms
	+ by simp
	+qed
	+
	+text\<open>The equivalence between the two h-distance representations.\<close>
	+lemma poincare_distance_formula:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "poincare_distance u v = poincare_distance_formula (to_complex u) (to_complex v)" (is "?P u v")
	+proof (rule wlog_x_axis)
	+ fix x
	+ assume *: "is_real x" "0 \<le> Re x" "Re x < 1"
	+ show "?P 0\<^sub>h (of_complex x)" (is "?lhs = ?rhs")
	+ proof-
	+ have "of_complex x \<in> unit_disc" "of_complex x \<in> circline_set x_axis" "cmod x < 1"
	+ using * cmod_eq_Re
	+ by (auto simp add: circline_set_x_axis)
	+ hence "?lhs = \<bar>ln (Re ((1 - x) / (1 + x)))\<bar>"
	+ using poincare_distance_zero_x_axis[of "of_complex x"]
	+ by simp
	+ moreover
	+ have "?rhs = \<bar>ln (Re ((1 - x) / (1 + x)))\<bar>"
	+ proof-
	+ let ?x = "1 + 2 * (cmod x)\<^sup>2 / (1 - (cmod x)\<^sup>2)"
	+ have "0 \<le> 2 * (cmod x)\<^sup>2 / (1 - (cmod x)\<^sup>2)"
	+ by (smt \<open>cmod x < 1\<close> divide_nonneg_nonneg norm_ge_zero power_le_one zero_le_power2)
	+ hence arcosh_real_gt: "1 \<le> ?x"
	+ by auto
	+ have "?rhs = arcosh ?x"
	+ by simp
	+ also have "... = ln ((1 + (cmod x)\<^sup>2) / (1 - (cmod x)\<^sup>2) + 2 * (cmod x) / (1 - (cmod x)\<^sup>2))"
	+ proof-
	+ have "1 - (cmod x)\<^sup>2 > 0"
	+ using \<open>cmod x < 1\<close>
	+ by (smt norm_not_less_zero one_power2 power2_eq_imp_eq power_mono)
	+ hence 1: "?x = (1 + (cmod x)\<^sup>2) / (1 - (cmod x)\<^sup>2)"
	+ by (simp add: field_simps)
	+ have 2: "?x\<^sup>2 - 1 = (4 * (cmod x)\<^sup>2) / (1 - (cmod x)\<^sup>2)\<^sup>2"
	+ using \<open>1 - (cmod x)\<^sup>2 > 0\<close>
	+ apply (subst 1)
	+ unfolding power_divide
	+ by (subst divide_diff_eq_iff, simp, simp add: power2_eq_square field_simps)
	+ show ?thesis
	+ using \<open>1 - (cmod x)\<^sup>2 > 0\<close>
	+ apply (subst arcosh_real_def[OF arcosh_real_gt])
	+ apply (subst 2)
	+ apply (subst 1)
	+ apply (subst real_sqrt_divide)
	+ apply (subst real_sqrt_mult)
	+ apply simp
	+ done
	+ qed
	+ also have "... = ln (((1 + (cmod x))\<^sup>2) / (1 - (cmod x)\<^sup>2))"
	+ apply (subst add_divide_distrib[symmetric])
	+ apply (simp add: field_simps power2_eq_square)
	+ done
	+ also have "... = ln ((1 + cmod x) / (1 - (cmod x)))"
	+ using \<open>cmod x < 1\<close>
	+ using square_diff_square_factored[of 1 "cmod x"]
	+ by (simp add: power2_eq_square)
	+ also have "... = \<bar>ln (Re ((1 - x) / (1 + x)))\<bar>"
	+ proof-
	+ have *: "Re ((1 - x) / (1 + x)) \<le> 1" "Re ((1 - x) / (1 + x)) > 0"
	+ using \<open>is_real x\<close> \<open>Re x \<ge> 0\<close> \<open>Re x < 1\<close>
	+ using complex_is_Real_iff
	+ by auto
	+ hence "\<bar>ln (Re ((1 - x) / (1 + x)))\<bar> = - ln (Re ((1 - x) / (1 + x)))"
	+ by auto
	+ hence "\<bar>ln (Re ((1 - x) / (1 + x)))\<bar> = ln (Re ((1 + x) / (1 - x)))"
	+ using ln_div[of 1 "Re ((1 - x)/(1 + x))"] * \<open>is_real x\<close>
	+ by (simp add: complex_is_Real_iff)
	+ moreover
	+ have "ln ((1 + cmod x) / (1 - cmod x)) = ln ((1 + Re x) / (1 - Re x))"
	+ using \<open>Re x \<ge> 0\<close> \<open>is_real x\<close>
	+ using cmod_eq_Re by auto
	+ moreover
	+ have "(1 + Re x) / (1 - Re x) = Re ((1 + x) / (1 - x))"
	+ using \<open>is_real x\<close> \<open>Re x < 1\<close>
	+ by (smt Re_divide_real eq_iff_diff_eq_0 minus_complex.simps one_complex.simps plus_complex.simps)
	+ ultimately
	+ show ?thesis
	+ by simp
	+ qed
	+ finally
	+ show ?thesis
	+ .
	+ qed
	+ ultimately
	+ show ?thesis
	+ by simp
	+ qed
	+next
	+ fix M u v
	+ assume *: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc"
	+ assume "?P (moebius_pt M u) (moebius_pt M v)"
	+ thus "?P u v"
	+ using *(1-3)
	+ by (simp del: poincare_distance_formula_def)
	+next
	+ show "u \<in> unit_disc" "v \<in> unit_disc"
	+ by fact+
	+qed
	+
	+text\<open>Some additional properties proved easily using the distance formula.\<close>
	+
	+
	+text \<open>@{term poincare_distance} is symmetric.\<close>
	+lemma poincare_distance_sym:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "poincare_distance u v = poincare_distance v u"
	+ using assms
	+ using poincare_distance_formula[OF assms(1) assms(2)]
	+ using poincare_distance_formula[OF assms(2) assms(1)]
	+ by (simp add: mult.commute norm_minus_commute)
	+
	+lemma poincare_distance_formula'_ge_1:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "1 \<le> poincare_distance_formula' (to_complex u) (to_complex v)"
	+ using unit_disc_cmod_square_lt_1[OF assms(1)] unit_disc_cmod_square_lt_1[OF assms(2)]
	+ by auto
	+
	+text\<open>@{term poincare_distance} is non-negative.\<close>
	+lemma poincare_distance_ge0:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "poincare_distance u v \<ge> 0"
	+ using poincare_distance_formula'_ge_1
	+ unfolding poincare_distance_formula[OF assms(1) assms(2)]
	+ unfolding poincare_distance_formula_def
	+ unfolding poincare_distance_formula'_def
	+ by (rule arcosh_ge_0, simp_all add: assms)
	+
	+lemma cosh_dist:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "cosh_dist u v = poincare_distance_formula' (to_complex u) (to_complex v)"
	+ using poincare_distance_formula[OF assms] poincare_distance_formula'_ge_1[OF assms]
	+ by simp
	+
	+text\<open>@{term poincare_distance} is zero only if the two points are equal.\<close>
	+lemma poincare_distance_eq_0_iff:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "poincare_distance u v = 0 \<longleftrightarrow> u = v"
	+ using assms
	+ apply auto
	+ using poincare_distance_formula'_ge_1[OF assms]
	+ using unit_disc_cmod_square_lt_1[OF assms(1)] unit_disc_cmod_square_lt_1[OF assms(2)]
	+ unfolding poincare_distance_formula[OF assms(1) assms(2)]
	+ unfolding poincare_distance_formula_def
	+ unfolding poincare_distance_formula'_def
	+ apply (subst (asm) arcosh_eq_0_iff)
	+ apply assumption
	+ apply (simp add: unit_disc_to_complex_inj)
	+ done
	+
	+text\<open>Conjugate preserve @{term poincare_distance_formula}.\<close>
	+lemma conjugate_preserve_poincare_distance [simp]:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "poincare_distance (conjugate u) (conjugate v) = poincare_distance u v"
	+proof-
	+ obtain u' v' where *: "u = of_complex u'" "v = of_complex v'"
	+ using assms inf_or_of_complex[of u] inf_or_of_complex[of v]
	+ by auto
	+
	+ have **: "conjugate u \<in> unit_disc" "conjugate v \<in> unit_disc"
	+ using * assms
	+ by auto
	+
	+ show ?thesis
	+ using *
	+ using poincare_distance_formula[OF assms]
	+ using poincare_distance_formula[OF **]
	+ by (metis complex_cnj_diff complex_mod_cnj conjugate_of_complex poincare_distance_def poincare_distance_formula'_def poincare_distance_formula_def to_complex_of_complex)
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Existence and uniqueness of points with a given distance\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lemma ex_x_axis_poincare_distance_negative':
	+ fixes d :: real
	+ assumes "d \<ge> 0"
	+ shows "let z = (1 - exp d) / (1 + exp d)
	+ in is_real z \<and> Re z \<le> 0 \<and> Re z > -1 \<and>
	+ of_complex z \<in> unit_disc \<and> of_complex z \<in> circline_set x_axis \<and>
	+ poincare_distance 0\<^sub>h (of_complex z) = d"
	+proof-
	+ have "exp d \<ge> 1"
	+ using assms
	+ using one_le_exp_iff[of d, symmetric]
	+ by blast
	+
	+ hence "1 + exp d \<noteq> 0"
	+ by linarith
	+
	+ let ?z = "(1 - exp d) / (1 + exp d)"
	+
	+ have "?z \<le> 0"
	+ using \<open>exp d \<ge> 1\<close>
	+ by (simp add: divide_nonpos_nonneg)
	+
	+ moreover
	+
	+ have "?z > -1"
	+ using exp_gt_zero[of d]
	+ by (smt divide_less_eq_1_neg nonzero_minus_divide_right)
	+
	+ moreover
	+
	+ hence "abs ?z < 1"
	+ using \<open>?z \<le> 0\<close>
	+ by simp
	+ hence "cmod ?z < 1"
	+ by (metis norm_of_real)
	+ hence "of_complex ?z \<in> unit_disc"
	+ by simp
	+
	+ moreover
	+ have "of_complex ?z \<in> circline_set x_axis"
	+ unfolding circline_set_x_axis
	+ by simp
	+
	+ moreover
	+ have "(1 - ?z) / (1 + ?z) = exp d"
	+ proof-
	+ have "1 + ?z = 2 / (1 + exp d)"
	+ using \<open>1 + exp d \<noteq> 0\<close>
	+ by (subst add_divide_eq_iff, auto)
	+ moreover
	+ have "1 - ?z = 2 * exp d / (1 + exp d)"
	+ using \<open>1 + exp d \<noteq> 0\<close>
	+ by (subst diff_divide_eq_iff, auto)
	+ ultimately
	+ show ?thesis
	+ using \<open>1 + exp d \<noteq> 0\<close>
	+ by simp
	+ qed
	+
	+ ultimately
	+ show ?thesis
	+ using poincare_distance_zero_x_axis[of "of_complex ?z"]
	+ using \<open>d \<ge> 0\<close> \<open>exp d \<ge> 1\<close>
	+ by simp (simp add: cmod_eq_Re)
	+qed
	+
	+lemma ex_x_axis_poincare_distance_negative:
	+ assumes "d \<ge> 0"
	+ shows "\<exists> z. is_real z \<and> Re z \<le> 0 \<and> Re z > -1 \<and>
	+ of_complex z \<in> unit_disc \<and> of_complex z \<in> circline_set x_axis \<and>
	+ poincare_distance 0\<^sub>h (of_complex z) = d" (is "\<exists> z. ?P z")
	+ using ex_x_axis_poincare_distance_negative'[OF assms]
	+ unfolding Let_def
	+ by blast
	+
	+text\<open>For each real number $d$ there is exactly one point on the positive x-axis such that h-distance
	+between 0 and that point is $d$.\<close>
	+lemma unique_x_axis_poincare_distance_negative:
	+ assumes "d \<ge> 0"
	+ shows "\<exists>! z. is_real z \<and> Re z \<le> 0 \<and> Re z > -1 \<and>
	+ poincare_distance 0\<^sub>h (of_complex z) = d" (is "\<exists>! z. ?P z")
	+proof-
	+ let ?z = "(1 - exp d) / (1 + exp d)"
	+
	+ have "?P ?z"
	+ using ex_x_axis_poincare_distance_negative'[OF assms]
	+ unfolding Let_def
	+ by blast
	+
	+ moreover
	+
	+ have "\<forall> z'. ?P z' \<longrightarrow> z' = ?z"
	+ proof-
	+ let ?g = "\<lambda> x'. \<bar>ln (Re ((1 - x') / (1 + x')))\<bar>"
	+ let ?A = "{x. is_real x \<and> Re x > -1 \<and> Re x \<le> 0}"
	+ have "inj_on (poincare_distance 0\<^sub>h \<circ> of_complex) ?A"
	+ proof (rule comp_inj_on)
	+ show "inj_on of_complex ?A"
	+ using of_complex_inj
	+ unfolding inj_on_def
	+ by blast
	+ next
	+ show "inj_on (poincare_distance 0\<^sub>h) (of_complex ` ?A)" (is "inj_on ?f (of_complex ` ?A)")
	+ proof (subst inj_on_cong)
	+ have *: "of_complex ` ?A =
	+ {z. z \<in> unit_disc \<and> z \<in> circline_set x_axis \<and> Re (to_complex z) \<le> 0}" (is "_ = ?B")
	+ by (auto simp add: cmod_eq_Re circline_set_x_axis)
	+
	+ fix x
	+ assume "x \<in> of_complex ` ?A"
	+ hence "x \<in> ?B"
	+ using *
	+ by simp
	+ thus "poincare_distance 0\<^sub>h x = (?g \<circ> to_complex) x"
	+ using poincare_distance_zero_x_axis
	+ by (simp add: Let_def)
	+ next
	+ have *: "to_complex ` of_complex ` ?A = ?A"
	+ by (auto simp add: image_iff)
	+
	+ show "inj_on (?g \<circ> to_complex) (of_complex ` ?A)"
	+ proof (rule comp_inj_on)
	+ show "inj_on to_complex (of_complex ` ?A)"
	+ unfolding inj_on_def
	+ by auto
	+ next
	+ have "inj_on ?g ?A"
	+ unfolding inj_on_def
	+ proof(safe)
	+ fix x y
	+ assume hh: "is_real x" "is_real y" "- 1 < Re x" "Re x \<le> 0"
	+ "- 1 < Re y" "Re y \<le> 0" "\<bar>ln (Re ((1 - x) / (1 + x)))\<bar> = \<bar>ln (Re ((1 - y) / (1 + y)))\<bar>"
	+
	+ have "is_real ((1 - x)/(1 + x))"
	+ using \<open>is_real x\<close> div_reals[of "1-x" "1+x"]
	+ by auto
	+ have "is_real ((1 - y)/(1 + y))"
	+ using \<open>is_real y\<close> div_reals[of "1-y" "1+y"]
	+ by auto
	+
	+ have "Re (1 + x) > 0"
	+ using \<open>- 1 < Re x\<close> by auto
	+ hence "1 + x \<noteq> 0"
	+ by force
	+ have "Re (1 - x) \<ge> 0"
	+ using \<open>Re x \<le> 0\<close> by auto
	+ hence "Re ((1 - x)/(1 + x)) > 0"
	+ using Re_divide_real \<open>0 < Re (1 + x)\<close> complex_eq_if_Re_eq hh(1) hh(4) by auto
	+ have "Re(1 - x) \<ge> Re ( 1 + x)"
	+ using hh by auto
	+ hence "Re ((1 - x)/(1 + x)) \<ge> 1"
	+ using \<open>Re (1 + x) > 0\<close> \<open>is_real ((1 - x)/(1 + x))\<close>
	+ by (smt Re_divide_real arg_0_iff hh(1) le_divide_eq_1_pos one_complex.simps(2) plus_complex.simps(2))
	+
	+ have "Re (1 + y) > 0"
	+ using \<open>- 1 < Re y\<close> by auto
	+ hence "1 + y \<noteq> 0"
	+ by force
	+ have "Re (1 - y) \<ge> 0"
	+ using \<open>Re y \<le> 0\<close> by auto
	+ hence "Re ((1 - y)/(1 + y)) > 0"
	+ using Re_divide_real \<open>0 < Re (1 + y)\<close> complex_eq_if_Re_eq hh by auto
	+ have "Re(1 - y) \<ge> Re ( 1 + y)"
	+ using hh by auto
	+ hence "Re ((1 - y)/(1 + y)) \<ge> 1"
	+ using \<open>Re (1 + y) > 0\<close> \<open>is_real ((1 - y)/(1 + y))\<close>
	+ by (smt Re_divide_real arg_0_iff hh le_divide_eq_1_pos one_complex.simps(2) plus_complex.simps(2))
	+
	+ have "ln (Re ((1 - x) / (1 + x))) = ln (Re ((1 - y) / (1 + y)))"
	+ using \<open>Re ((1 - y)/(1 + y)) \<ge> 1\<close> \<open>Re ((1 - x)/(1 + x)) \<ge> 1\<close> hh
	+ by auto
	+ hence "Re ((1 - x) / (1 + x)) = Re ((1 - y) / (1 + y))"
	+ using \<open>Re ((1 - y)/(1 + y)) > 0\<close> \<open>Re ((1 - x)/(1 + x)) > 0\<close>
	+ by auto
	+ hence "(1 - x) / (1 + x) = (1 - y) / (1 + y)"
	+ using \<open>is_real ((1 - y)/(1 + y))\<close> \<open>is_real ((1 - x)/(1 + x))\<close>
	+ using complex_eq_if_Re_eq by blast
	+ hence "(1 - x) * (1 + y) = (1 - y) * (1 + x)"
	+ using \<open>1 + y \<noteq> 0\<close> \<open>1 + x \<noteq> 0\<close>
	+ by (simp add:field_simps)
	+ thus "x = y"
	+ by (simp add:field_simps)
	+ qed
	+ thus "inj_on ?g (to_complex ` of_complex ` ?A)"
	+ using *
	+ by simp
	+ qed
	+ qed
	+ qed
	+ thus ?thesis
	+ using \<open>?P ?z\<close>
	+ unfolding inj_on_def
	+ by auto
	+ qed
	+ ultimately
	+ show ?thesis
	+ by blast
	+qed
	+
	+lemma ex_x_axis_poincare_distance_positive:
	+ assumes "d \<ge> 0"
	+ shows "\<exists> z. is_real z \<and> Re z \<ge> 0 \<and> Re z < 1 \<and>
	+ of_complex z \<in> unit_disc \<and> of_complex z \<in> circline_set x_axis \<and>
	+ poincare_distance 0\<^sub>h (of_complex z) = d" (is "\<exists> z. is_real z \<and> Re z \<ge> 0 \<and> Re z < 1 \<and> ?P z")
	+proof-
	+ obtain z where *: "is_real z" "Re z \<le> 0" "Re z > -1" "?P z"
	+ using ex_x_axis_poincare_distance_negative[OF assms]
	+ by auto
	+ hence **: "of_complex z \<in> unit_disc" "of_complex z \<in> circline_set x_axis"
	+ by (auto simp add: cmod_eq_Re)
	+ have "is_real (-z) \<and> Re (-z) \<ge> 0 \<and> Re (-z) < 1 \<and> ?P (-z)"
	+ using * **
	+ by (simp add: circline_set_x_axis)
	+ thus ?thesis
	+ by blast
	+qed
	+
	+lemma unique_x_axis_poincare_distance_positive:
	+ assumes "d \<ge> 0"
	+ shows "\<exists>! z. is_real z \<and> Re z \<ge> 0 \<and> Re z < 1 \<and>
	+ poincare_distance 0\<^sub>h (of_complex z) = d" (is "\<exists>! z. is_real z \<and> Re z \<ge> 0 \<and> Re z < 1 \<and> ?P z")
	+proof-
	+ obtain z where *: "is_real z" "Re z \<le> 0" "Re z > -1" "?P z"
	+ using unique_x_axis_poincare_distance_negative[OF assms]
	+ by auto
	+ hence **: "of_complex z \<in> unit_disc" "of_complex z \<in> circline_set x_axis"
	+ by (auto simp add: cmod_eq_Re circline_set_x_axis)
	+ show ?thesis
	+ proof
	+ show "is_real (-z) \<and> Re (-z) \<ge> 0 \<and> Re (-z) < 1 \<and> ?P (-z)"
	+ using * **
	+ by simp
	+ next
	+ fix z'
	+ assume "is_real z' \<and> Re z' \<ge> 0 \<and> Re z' < 1 \<and> ?P z'"
	+ hence "is_real (-z') \<and> Re (-z') \<le> 0 \<and> Re (-z') > -1 \<and> ?P (-z')"
	+ by (auto simp add: circline_set_x_axis cmod_eq_Re)
	+ hence "-z' = z"
	+ using unique_x_axis_poincare_distance_negative[OF assms] *
	+ by blast
	+ thus "z' = -z"
	+ by auto
	+ qed
	+qed
	+
	+text\<open>Equal distance implies that segments are isometric - this means that congruence could be
	+defined either by two segments having the same distance or by requiring existence of an isometry
	+that maps one segment to the other.\<close>
	+lemma poincare_distance_eq_ex_moebius:
	+ assumes in_disc: "u \<in> unit_disc" and "v \<in> unit_disc" and "u' \<in> unit_disc" and "v' \<in> unit_disc"
	+ assumes "poincare_distance u v = poincare_distance u' v'"
	+ shows "\<exists> M. unit_disc_fix M \<and> moebius_pt M u = u' \<and> moebius_pt M v = v'" (is "?P' u v u' v'")
	+proof (cases "u = v")
	+ case True
	+ thus ?thesis
	+ using assms poincare_distance_eq_0_iff[of u' v']
	+ by (simp add: unit_disc_fix_transitive)
	+next
	+ case False
	+ have "\<forall> u' v'. u \<noteq> v \<and> u' \<in> unit_disc \<and> v' \<in> unit_disc \<and> poincare_distance u v = poincare_distance u' v' \<longrightarrow>
	+ ?P' u' v' u v" (is "?P u v")
	+ proof (rule wlog_positive_x_axis[where P="?P"])
	+ fix x
	+ assume "is_real x" "0 < Re x" "Re x < 1"
	+ hence "of_complex x \<in> unit_disc" "of_complex x \<in> circline_set x_axis"
	+ unfolding circline_set_x_axis
	+ by (auto simp add: cmod_eq_Re)
	+
	+ show "?P 0\<^sub>h (of_complex x)"
	+ proof safe
	+ fix u' v'
	+ assume "0\<^sub>h \<noteq> of_complex x" and in_disc: "u' \<in> unit_disc" "v' \<in> unit_disc" and
	+ "poincare_distance 0\<^sub>h (of_complex x) = poincare_distance u' v'"
	+ hence "u' \<noteq> v'" "poincare_distance u' v' > 0"
	+ using poincare_distance_eq_0_iff[of "0\<^sub>h" "of_complex x"] \<open>of_complex x \<in> unit_disc\<close>
	+ using poincare_distance_ge0[of "0\<^sub>h" "of_complex x"]
	+ by auto
	+ then obtain M where M: "unit_disc_fix M" "moebius_pt M u' = 0\<^sub>h" "moebius_pt M v' \<in> positive_x_axis"
	+ using ex_unit_disc_fix_to_zero_positive_x_axis[of u' v'] in_disc
	+ by auto
	+
	+ then obtain Mv' where Mv': "moebius_pt M v' = of_complex Mv'"
	+ using inf_or_of_complex[of "moebius_pt M v'"] in_disc unit_disc_fix_iff[of M]
	+ by (metis image_eqI inf_notin_unit_disc)
	+
	+ have "moebius_pt M v' \<in> unit_disc"
	+ using M(1) \<open>v' \<in> unit_disc\<close>
	+ by auto
	+
	+ have "Re Mv' > 0" "is_real Mv'" "Re Mv' < 1"
	+ using M Mv' of_complex_inj \<open>moebius_pt M v' \<in> unit_disc\<close>
	+ unfolding positive_x_axis_def circline_set_x_axis
	+ using cmod_eq_Re
	+ by auto fastforce
	+
	+ have "poincare_distance 0\<^sub>h (moebius_pt M v') = poincare_distance u' v'"
	+ using M(1)
	+ using in_disc
	+ by (subst M(2)[symmetric], simp)
	+
	+ have "Mv' = x"
	+ using \<open>poincare_distance 0\<^sub>h (moebius_pt M v') = poincare_distance u' v'\<close> Mv'
	+ using \<open>poincare_distance 0\<^sub>h (of_complex x) = poincare_distance u' v'\<close>
	+ using unique_x_axis_poincare_distance_positive[of "poincare_distance u' v'"]
	+ \<open>poincare_distance u' v' > 0\<close>
	+ using \<open>Re Mv' > 0\<close> \<open>Re Mv' < 1\<close> \<open>is_real Mv'\<close>
	+ using \<open>is_real x\<close> \<open>Re x > 0\<close> \<open>Re x < 1\<close>
	+ unfolding positive_x_axis_def
	+ by auto
	+
	+ thus "?P' u' v' 0\<^sub>h (of_complex x)"
	+ using M Mv'
	+ by auto
	+ qed
	+ next
	+ show "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ by fact+
	+ next
	+ fix M u v
	+ let ?Mu = "moebius_pt M u" and ?Mv = "moebius_pt M v"
	+ assume 1: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ hence 2: "?Mu \<noteq> ?Mv" "?Mu \<in> unit_disc" "?Mv \<in> unit_disc"
	+ by auto
	+ assume 3: "?P (moebius_pt M u) (moebius_pt M v)"
	+ show "?P u v"
	+ proof safe
	+ fix u' v'
	+ assume 4: "u' \<in> unit_disc" "v' \<in> unit_disc" "poincare_distance u v = poincare_distance u' v'"
	+ hence "poincare_distance ?Mu ?Mv = poincare_distance u v"
	+ using 1
	+ by simp
	+ then obtain M' where 5: "unit_disc_fix M'" "moebius_pt M' u' = ?Mu" "moebius_pt M' v' = ?Mv"
	+ using 2 3 4
	+ by auto
	+ let ?M = "(-M) + M'"
	+ have "unit_disc_fix ?M \<and> moebius_pt ?M u' = u \<and> moebius_pt ?M v' = v"
	+ using 5 \<open>unit_disc_fix M\<close>
	+ using unit_disc_fix_moebius_comp[of "-M" "M'"]
	+ using unit_disc_fix_moebius_inv[of M]
	+ by simp
	+ thus "\<exists>M. unit_disc_fix M \<and> moebius_pt M u' = u \<and> moebius_pt M v' = v"
	+ by blast
	+ qed
	+ qed
	+ then obtain M where "unit_disc_fix M \<and> moebius_pt M u' = u \<and> moebius_pt M v' = v"
	+ using assms \<open>u \<noteq> v\<close>
	+ by blast
	+ hence "unit_disc_fix (-M) \<and> moebius_pt (-M) u = u' \<and> moebius_pt (-M) v = v'"
	+ using unit_disc_fix_moebius_inv[of M]
	+ by auto
	+ thus ?thesis
	+ by blast
	+qed
	+
	+lemma unique_midpoint_x_axis:
	+ assumes x: "is_real x" "-1 < Re x" "Re x < 1" and
	+ y: "is_real y" "-1 < Re y" "Re y < 1" and
	+ "x \<noteq> y"
	+ shows "\<exists>! z. -1 < Re z \<and> Re z < 1 \<and> is_real z \<and> poincare_distance (of_complex z) (of_complex x) = poincare_distance (of_complex z) (of_complex y)" (is "\<exists>! z. ?R z (of_complex x) (of_complex y)")
	+proof-
	+ let ?x = "of_complex x" and ?y = "of_complex y"
	+ let ?P = "\<lambda> x y. \<exists>! z. ?R z x y"
	+ have "\<forall> x. -1 < Re x \<and> Re x < 1 \<and> is_real x \<and> of_complex x \<noteq> ?y \<longrightarrow> ?P (of_complex x) ?y" (is "?Q (of_complex y)")
	+ proof (rule wlog_real_zero)
	+ show "?y \<in> unit_disc"
	+ using y
	+ by (simp add: cmod_eq_Re)
	+ next
	+ show "is_real (to_complex ?y)"
	+ using y
	+ by simp
	+ next
	+ show "?Q 0\<^sub>h"
	+ proof (rule allI, rule impI, (erule conjE)+)
	+ fix x
	+ assume x: "-1 < Re x" "Re x < 1" "is_real x"
	+ let ?x = "of_complex x"
	+ assume "?x \<noteq> 0\<^sub>h"
	+ hence "x \<noteq> 0"
	+ by auto
	+ hence "Re x \<noteq> 0"
	+ using x
	+ using complex_neq_0
	+ by auto
	+
	+ have *: "\<forall> a. -1 < a \<and> a < 1 \<longrightarrow>
	+ (poincare_distance (of_complex (cor a)) ?x = poincare_distance (of_complex (cor a)) 0\<^sub>h \<longleftrightarrow>
	+ (Re x) * a * a - 2 * a + Re x = 0)"
	+ proof (rule allI, rule impI)
	+ fix a :: real
	+ assume "-1 < a \<and> a < 1"
	+ hence "of_complex (cor a) \<in> unit_disc"
	+ by auto
	+ moreover
	+ have "(a - Re x)\<^sup>2 / ((1 - a\<^sup>2) * (1 - (Re x)\<^sup>2)) = a\<^sup>2 / (1 - a\<^sup>2) \<longleftrightarrow>
	+ (Re x) * a * a - 2 * a + Re x = 0" (is "?lhs \<longleftrightarrow> ?rhs")
	+ proof-
	+ have "1 - a\<^sup>2 \<noteq> 0"
	+ using \<open>-1 < a \<and> a < 1\<close>
	+ by (metis cancel_comm_monoid_add_class.diff_cancel diff_eq_diff_less less_numeral_extra(4) power2_eq_1_iff right_minus_eq)
	+ hence "?lhs \<longleftrightarrow> (a - Re x)\<^sup>2 / (1 - (Re x)\<^sup>2) = a\<^sup>2"
	+ by (smt divide_cancel_right divide_divide_eq_left mult.commute)
	+ also have "... \<longleftrightarrow> (a - Re x)\<^sup>2 = a\<^sup>2 * (1 - (Re x)\<^sup>2)"
	+ proof-
	+ have "1 - (Re x)\<^sup>2 \<noteq> 0"
	+ using x
	+ by (smt power2_eq_1_iff)
	+ thus ?thesis
	+ by (simp add: divide_eq_eq)
	+ qed
	+ also have "... \<longleftrightarrow> a\<^sup>2 * (Re x)\<^sup>2 - 2aRe x + (Re x)\<^sup>2 = 0"
	+ by (simp add: power2_diff field_simps)
	+ also have "... \<longleftrightarrow> Re x * (a\<^sup>2 * Re x - 2 * a + Re x) = 0"
	+ by (simp add: power2_eq_square field_simps)
	+ also have "... \<longleftrightarrow> ?rhs"
	+ using \<open>Re x \<noteq> 0\<close>
	+ by (simp add: mult.commute mult.left_commute power2_eq_square)
	+ finally
	+ show ?thesis
	+ .
	+ qed
	+ moreover
	+ have "arcosh (1 + 2 * ((a - Re x)\<^sup>2 / ((1 - a\<^sup>2) * (1 - (Re x)\<^sup>2)))) = arcosh (1 + 2 * a\<^sup>2 / (1 - a\<^sup>2)) \<longleftrightarrow> ?lhs"
	+ using \<open>-1 < a \<and> a < 1\<close> x mult_left_cancel[of "2::real" "(a - Re x)\<^sup>2 / ((1 - a\<^sup>2) * (1 - (Re x)\<^sup>2))" "a\<^sup>2 / (1 - a\<^sup>2)"]
	+ by (subst arcosh_eq_iff, simp_all add: square_le_1)
	+ ultimately
	+ show "poincare_distance (of_complex (cor a)) (of_complex x) = poincare_distance (of_complex (cor a)) 0\<^sub>h \<longleftrightarrow>
	+ (Re x) * a * a - 2 * a + Re x = 0"
	+ using x
	+ by (auto simp add: poincare_distance_formula cmod_eq_Re)
	+ qed
	+
	+ show "?P ?x 0\<^sub>h"
	+ proof
	+ let ?a = "(1 - sqrt(1 - (Re x)\<^sup>2)) / (Re x)"
	+ let ?b = "(1 + sqrt(1 - (Re x)\<^sup>2)) / (Re x)"
	+
	+ have "is_real ?a"
	+ by simp
	+ moreover
	+ have "1 - (Re x)\<^sup>2 > 0"
	+ using x
	+ by (smt power2_eq_1_iff square_le_1)
	+ have "\<bar>?a\<bar> < 1"
	+ proof (cases "Re x > 0")
	+ case True
	+ have "(1 - Re x)\<^sup>2 < 1 - (Re x)\<^sup>2"
	+ using \<open>Re x > 0\<close> x
	+ by (simp add: power2_eq_square field_simps)
	+ hence "1 - Re x < sqrt (1 - (Re x)\<^sup>2)"
	+ using real_less_rsqrt by fastforce
	+ thus ?thesis
	+ using \<open>1 - (Re x)\<^sup>2 > 0\<close> \<open>Re x > 0\<close>
	+ by simp
	+ next
	+ case False
	+ hence "Re x < 0"
	+ using \<open>Re x \<noteq> 0\<close>
	+ by simp
	+
	+ have "1 + Re x > 0"
	+ using \<open>Re x > -1\<close>
	+ by simp
	+ hence "2Re x + 2Re x*Re x < 0"
	+ using \<open>Re x < 0\<close>
	+ by (metis comm_semiring_class.distrib mult.commute mult_2_right mult_less_0_iff one_add_one zero_less_double_add_iff_zero_less_single_add)
	+ hence "(1 + Re x)\<^sup>2 < 1 - (Re x)\<^sup>2"
	+ by (simp add: power2_eq_square field_simps)
	+ hence "1 + Re x < sqrt (1 - (Re x)\<^sup>2)"
	+ using \<open>1 - (Re x)\<^sup>2 > 0\<close>
	+ using real_less_rsqrt by blast
	+ thus ?thesis
	+ using \<open>Re x < 0\<close>
	+ by (simp add: field_simps)
	+ qed
	+ hence "-1 < ?a" "?a < 1"
	+ by linarith+
	+ moreover
	+ have "(Re x) * ?a * ?a - 2 * ?a + Re x = 0"
	+ using \<open>Re x \<noteq> 0\<close> \<open>1 - (Re x)\<^sup>2 > 0\<close>
	+ by (simp add: field_simps power2_eq_square)
	+ ultimately
	+ show "-1 < Re (cor ?a) \<and> Re (cor ?a) < 1 \<and> is_real ?a \<and> poincare_distance (of_complex ?a) (of_complex x) = poincare_distance (of_complex ?a) 0\<^sub>h"
	+ using *
	+ by auto
	+
	+ fix z
	+ assume **: "- 1 < Re z \<and> Re z < 1 \<and> is_real z \<and>
	+ poincare_distance (of_complex z) (of_complex x) = poincare_distance (of_complex z) 0\<^sub>h"
	+ hence "Re x * Re z * Re z - 2 * Re z + Re x = 0"
	+ using *[rule_format, of "Re z"] x
	+ by auto
	+ moreover
	+ have "sqrt (4 - 4 * Re x * Re x) = 2 * sqrt(1 - Re x * Re x)"
	+ proof-
	+ have "sqrt (4 - 4 * Re x * Re x) = sqrt(4 * (1 - Re x * Re x))"
	+ by simp
	+ thus ?thesis
	+ by (simp only: real_sqrt_mult, simp)
	+ qed
	+ moreover
	+ have "(2 - 2 * sqrt (1 - Re x * Re x)) / (2 * Re x) = ?a"
	+ proof-
	+ have "(2 - 2 * sqrt (1 - Re x * Re x)) / (2 * Re x) =
	+ (2 * (1 - sqrt (1 - Re x * Re x))) / (2 * Re x)"
	+ by simp
	+ thus ?thesis
	+ by (subst (asm) mult_divide_mult_cancel_left) (auto simp add: power2_eq_square)
	+ qed
	+ moreover
	+ have "(2 + 2 * sqrt (1 - Re x * Re x)) / (2 * Re x) = ?b"
	+ proof-
	+ have "(2 + 2 * sqrt (1 - Re x * Re x)) / (2 * Re x) =
	+ (2 * (1 + sqrt (1 - Re x * Re x))) / (2 * Re x)"
	+ by simp
	+ thus ?thesis
	+ by (subst (asm) mult_divide_mult_cancel_left) (auto simp add: power2_eq_square)
	+ qed
	+ ultimately
	+ have "Re z = ?a \<or> Re z = ?b"
	+ using discriminant_nonneg[of "Re x" "-2" "Re x" "Re z"] discrim_def[of "Re x" "-2" "Re x"]
	+ using \<open>Re x \<noteq> 0\<close> \<open>-1 < Re x\<close> \<open>Re x < 1\<close> \<open>1 - (Re x)\<^sup>2 > 0\<close>
	+ by (auto simp add:power2_eq_square)
	+ have "\<bar>?b\<bar> > 1"
	+ proof (cases "Re x > 0")
	+ case True
	+ have "(Re x - 1)\<^sup>2 < 1 - (Re x)\<^sup>2"
	+ using \<open>Re x > 0\<close> x
	+ by (simp add: power2_eq_square field_simps)
	+ hence "Re x - 1 < sqrt (1 - (Re x)\<^sup>2)"
	+ using real_less_rsqrt
	+ by simp
	+ thus ?thesis
	+ using \<open>1 - (Re x)\<^sup>2 > 0\<close> \<open>Re x > 0\<close>
	+ by simp
	+ next
	+ case False
	+ hence "Re x < 0"
	+ using \<open>Re x \<noteq> 0\<close>
	+ by simp
	+ have "1 + Re x > 0"
	+ using \<open>Re x > -1\<close>
	+ by simp
	+ hence "2Re x + 2Re x*Re x < 0"
	+ using \<open>Re x < 0\<close>
	+ by (metis comm_semiring_class.distrib mult.commute mult_2_right mult_less_0_iff one_add_one zero_less_double_add_iff_zero_less_single_add)
	+ hence "1 - (Re x)\<^sup>2 > (- 1 - (Re x))\<^sup>2"
	+ by (simp add: field_simps power2_eq_square)
	+ hence "sqrt (1 - (Re x)\<^sup>2) > -1 - Re x"
	+ using real_less_rsqrt
	+ by simp
	+ thus ?thesis
	+ using \<open>Re x < 0\<close>
	+ by (simp add: field_simps)
	+ qed
	+ hence "?b < -1 \<or> ?b > 1"
	+ by auto
	+
	+ hence "Re z = ?a"
	+ using \<open>Re z = ?a \<or> Re z = ?b\<close> **
	+ by auto
	+ thus "z = ?a"
	+ using ** complex_of_real_Re
	+ by fastforce
	+ qed
	+ qed
	+ next
	+ fix a u
	+ let ?M = "moebius_pt (blaschke a)"
	+ let ?Mu = "?M u"
	+ assume "u \<in> unit_disc" "is_real a" "cmod a < 1"
	+ assume *: "?Q ?Mu"
	+ show "?Q u"
	+ proof (rule allI, rule impI, (erule conjE)+)
	+ fix x
	+ assume x: "-1 < Re x" "Re x < 1" "is_real x" "of_complex x \<noteq> u"
	+ let ?Mx = "?M (of_complex x)"
	+ have "of_complex x \<in> unit_disc"
	+ using x cmod_eq_Re
	+ by auto
	+ hence "?Mx \<in> unit_disc"
	+ using \<open>is_real a\<close> \<open>cmod a < 1\<close> blaschke_unit_disc_fix[of a]
	+ using unit_disc_fix_discI
	+ by blast
	+ hence "?Mx \<noteq> \<infinity>\<^sub>h"
	+ by auto
	+ moreover
	+ have "of_complex x \<in> circline_set x_axis"
	+ using x
	+ by auto
	+ hence "?Mx \<in> circline_set x_axis"
	+ using blaschke_real_preserve_x_axis[OF \<open>is_real a\<close> \<open>cmod a < 1\<close>, of "of_complex x"]
	+ by auto
	+ hence "-1 < Re (to_complex ?Mx) \<and> Re (to_complex ?Mx) < 1 \<and> is_real (to_complex ?Mx)"
	+ using \<open>?Mx \<noteq> \<infinity>\<^sub>h\<close> \<open>?Mx \<in> unit_disc\<close>
	+ unfolding circline_set_x_axis
	+ by (auto simp add: cmod_eq_Re)
	+ moreover
	+ have "?Mx \<noteq> ?Mu"
	+ using \<open>of_complex x \<noteq> u\<close>
	+ by simp
	+ ultimately
	+ have "?P ?Mx ?Mu"
	+ using *[rule_format, of "to_complex ?Mx"] \<open>?Mx \<noteq> \<infinity>\<^sub>h\<close>
	+ by simp
	+ then obtain Mz where
	+ "?R Mz ?Mx ?Mu"
	+ by blast
	+ have "of_complex Mz \<in> unit_disc" "of_complex Mz \<in> circline_set x_axis"
	+ using \<open>?R Mz ?Mx ?Mu\<close>
	+ using cmod_eq_Re
	+ by auto
	+
	+ let ?Minv = "- (blaschke a)"
	+ let ?z = "moebius_pt ?Minv (of_complex Mz)"
	+ have "?z \<in> unit_disc"
	+ using \<open>of_complex Mz \<in> unit_disc\<close> \<open>cmod a < 1\<close>
	+ by auto
	+ moreover
	+ have "?z \<in> circline_set x_axis"
	+ using \<open>of_complex Mz \<in> circline_set x_axis\<close>
	+ using blaschke_real_preserve_x_axis \<open>is_real a\<close> \<open>cmod a < 1\<close>
	+ by fastforce
	+ ultimately
	+ have z1: "-1 < Re (to_complex ?z)" "Re (to_complex ?z) < 1" "is_real (to_complex ?z)"
	+ using inf_or_of_complex[of "?z"]
	+ unfolding circline_set_x_axis
	+ by (auto simp add: cmod_eq_Re)
	+
	+ have z2: "poincare_distance ?z (of_complex x) = poincare_distance ?z u"
	+ using \<open>?R Mz ?Mx ?Mu\<close> \<open>cmod a < 1\<close> \<open>?z \<in> unit_disc\<close> \<open>of_complex x \<in> unit_disc\<close> \<open>u \<in> unit_disc\<close>
	+ by (metis blaschke_preserve_distance_formula blaschke_unit_disc_fix moebius_pt_comp_inv_right poincare_distance_formula uminus_moebius_def unit_disc_fix_discI unit_disc_iff_cmod_lt_1)
	+ show "?P (of_complex x) u"
	+ proof
	+ show "?R (to_complex ?z) (of_complex x) u"
	+ using z1 z2 \<open>?z \<in> unit_disc\<close> inf_or_of_complex[of ?z]
	+ by auto
	+ next
	+ fix z'
	+ assume "?R z' (of_complex x) u"
	+ hence "of_complex z' \<in> unit_disc" "of_complex z' \<in> circline_set x_axis"
	+ by (auto simp add: cmod_eq_Re)
	+ let ?Mz' = "?M (of_complex z')"
	+ have "?Mz' \<in> unit_disc" "?Mz' \<in> circline_set x_axis"
	+ using \<open>of_complex z' \<in> unit_disc\<close> \<open>of_complex z' \<in> circline_set x_axis\<close> \<open>cmod a < 1\<close> \<open>is_real a\<close>
	+ using blaschke_unit_disc_fix unit_disc_fix_discI
	+ using blaschke_real_preserve_x_axis circline_set_x_axis
	+ by blast+
	+ hence "-1 < Re (to_complex ?Mz')" "Re (to_complex ?Mz') < 1" "is_real (to_complex ?Mz')"
	+ unfolding circline_set_x_axis
	+ by (auto simp add: cmod_eq_Re)
	+ moreover
	+ have "poincare_distance ?Mz' ?Mx = poincare_distance ?Mz' ?Mu"
	+ using \<open>?R z' (of_complex x) u\<close>
	+ using \<open>cmod a < 1\<close> \<open>of_complex x \<in> unit_disc\<close> \<open>of_complex z' \<in> unit_disc\<close> \<open>u \<in> unit_disc\<close>
	+ by auto
	+ ultimately
	+ have "?R (to_complex ?Mz') ?Mx ?Mu"
	+ using \<open>?Mz' \<in> unit_disc\<close> inf_or_of_complex[of ?Mz']
	+ by auto
	+ hence "?Mz' = of_complex Mz"
	+ using \<open>?P ?Mx ?Mu\<close> \<open>?R Mz ?Mx ?Mu\<close>
	+ by (metis \<open>moebius_pt (blaschke a) (of_complex z') \<in> unit_disc\<close> \<open>of_complex Mz \<in> unit_disc\<close> to_complex_of_complex unit_disc_to_complex_inj)
	+ thus "z' = to_complex ?z"
	+ using moebius_pt_invert by auto
	+ qed
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms
	+ by (metis to_complex_of_complex)
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Triangle inequality\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lemma poincare_distance_formula_zero_sum:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc"
	+ shows "poincare_distance u 0\<^sub>h + poincare_distance 0\<^sub>h v =
	+ (let u' = cmod (to_complex u); v' = cmod (to_complex v)
	+ in arcosh (((1 + u'\<^sup>2) * (1 + v'\<^sup>2) + 4 * u' * v') / ((1 - u'\<^sup>2) * (1 - v'\<^sup>2))))"
	+proof-
	+ obtain u' v' where uv: "u' = to_complex u" "v' = to_complex v"
	+ by auto
	+ have uv': "u = of_complex u'" "v = of_complex v'"
	+ using uv assms inf_or_of_complex[of u] inf_or_of_complex[of v]
	+ by auto
	+
	+ let ?u' = "cmod u'" and ?v' = "cmod v'"
	+
	+ have disc: "?u'\<^sup>2 < 1" "?v'\<^sup>2 < 1"
	+ using unit_disc_cmod_square_lt_1[OF \<open>u \<in> unit_disc\<close>]
	+ using unit_disc_cmod_square_lt_1[OF \<open>v \<in> unit_disc\<close>] uv
	+ by auto
	+ thm arcosh_add
	+ have "arcosh (1 + 2 * ?u'\<^sup>2 / (1 - ?u'\<^sup>2)) + arcosh (1 + 2 * ?v'\<^sup>2 / (1 - ?v'\<^sup>2)) =
	+ arcosh (((1 + ?u'\<^sup>2) * (1 + ?v'\<^sup>2) + 4 * ?u' * ?v') / ((1 - ?u'\<^sup>2) * (1 - ?v'\<^sup>2)))" (is "arcosh ?ll + arcosh ?rr = arcosh ?r")
	+ proof (subst arcosh_add)
	+ show "?ll \<ge> 1" "?rr \<ge> 1"
	+ using disc
	+ by auto
	+ next
	+ show "arcosh ((1 + 2 * ?u'\<^sup>2 / (1 - ?u'\<^sup>2)) * (1 + 2 * ?v'\<^sup>2 / (1 - ?v'\<^sup>2)) +
	+ sqrt (((1 + 2 * ?u'\<^sup>2 / (1 - ?u'\<^sup>2))\<^sup>2 - 1) * ((1 + 2 * ?v'\<^sup>2 / (1 - ?v'\<^sup>2))\<^sup>2 - 1))) =
	+ arcosh ?r" (is "arcosh ?l = _")
	+ proof-
	+ have "1 + 2 * ?u'\<^sup>2 / (1 - ?u'\<^sup>2) = (1 + ?u'\<^sup>2) / (1 - ?u'\<^sup>2)"
	+ using disc
	+ by (subst add_divide_eq_iff, simp_all)
	+ moreover
	+ have "1 + 2 * ?v'\<^sup>2 / (1 - ?v'\<^sup>2) = (1 + ?v'\<^sup>2) / (1 - ?v'\<^sup>2)"
	+ using disc
	+ by (subst add_divide_eq_iff, simp_all)
	+ moreover
	+ have "sqrt (((1 + 2 * ?u'\<^sup>2 / (1 - ?u'\<^sup>2))\<^sup>2 - 1) * ((1 + 2 * ?v'\<^sup>2 / (1 - ?v'\<^sup>2))\<^sup>2 - 1)) =
	+ (4 * ?u' * ?v') / ((1 - ?u'\<^sup>2) * (1 - ?v'\<^sup>2))" (is "sqrt ?s = ?t")
	+ proof-
	+ have "?s = ?t\<^sup>2"
	+ using disc
	+ apply (subst add_divide_eq_iff, simp)+
	+ apply (subst power_divide)+
	+ apply simp
	+ apply (subst divide_diff_eq_iff, simp)+
	+ apply (simp add: power2_eq_square field_simps)
	+ done
	+ thus ?thesis
	+ using disc
	+ by simp
	+ qed
	+ ultimately
	+ have "?l = ?r"
	+ using disc
	+ by simp (subst add_divide_distrib, simp)
	+ thus ?thesis
	+ by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using uv' assms
	+ using poincare_distance_formula
	+ by (simp add: Let_def)
	+qed
	+
	+lemma poincare_distance_triangle_inequality:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "w \<in> unit_disc"
	+ shows "poincare_distance u v + poincare_distance v w \<ge> poincare_distance u w" (is "?P' u v w")
	+proof-
	+ have "\<forall> w. w \<in> unit_disc \<longrightarrow> ?P' u v w" (is "?P v u")
	+ proof (rule wlog_x_axis[where P="?P"])
	+ fix x
	+ assume "is_real x" "0 \<le> Re x" "Re x < 1"
	+ hence "of_complex x \<in> unit_disc"
	+ by (simp add: cmod_eq_Re)
	+
	+ show "?P 0\<^sub>h (of_complex x)"
	+ proof safe
	+ fix w
	+ assume "w \<in> unit_disc"
	+ then obtain w' where w: "w = of_complex w'"
	+ using inf_or_of_complex[of w]
	+ by auto
	+
	+ let ?x = "cmod x" and ?w = "cmod w'" and ?xw = "cmod (x - w')"
	+
	+ have disc: "?x\<^sup>2 < 1" "?w\<^sup>2 < 1"
	+ using unit_disc_cmod_square_lt_1[OF \<open>of_complex x \<in> unit_disc\<close>]
	+ using unit_disc_cmod_square_lt_1[OF \<open>w \<in> unit_disc\<close>] w
	+ by auto
	+
	+ have "poincare_distance (of_complex x) 0\<^sub>h + poincare_distance 0\<^sub>h w =
	+ arcosh (((1 + ?x\<^sup>2) * (1 + ?w\<^sup>2) + 4 * ?x * ?w) / ((1 - ?x\<^sup>2) * (1 - ?w\<^sup>2)))" (is "_ = arcosh ?r1")
	+ using poincare_distance_formula_zero_sum[OF \<open>of_complex x \<in> unit_disc\<close> \<open>w \<in> unit_disc\<close>] w
	+ by (simp add: Let_def)
	+ moreover
	+ have "poincare_distance (of_complex x) (of_complex w') =
	+ arcosh (((1 - ?x\<^sup>2) * (1 - ?w\<^sup>2) + 2 * ?xw\<^sup>2) / ((1 - ?x\<^sup>2) * (1 - ?w\<^sup>2)))" (is "_ = arcosh ?r2")
	+ using disc
	+ using poincare_distance_formula[OF \<open>of_complex x \<in> unit_disc\<close> \<open>w \<in> unit_disc\<close>] w
	+ by (subst add_divide_distrib) simp
	+ moreover
	+ have : "(1 - ?x\<^sup>2) (1 - ?w\<^sup>2) + 2 * ?xw\<^sup>2 \<le> (1 + ?x\<^sup>2) * (1 + ?w\<^sup>2) + 4 * ?x * ?w"
	+ proof-
	+ have "(cmod (x - w'))\<^sup>2 \<le> (cmod x + cmod w')\<^sup>2"
	+ using norm_triangle_ineq4[of x w']
	+ by (simp add: power_mono)
	+ thus ?thesis
	+ by (simp add: field_simps power2_sum)
	+ qed
	+ have "arcosh ?r1 \<ge> arcosh ?r2"
	+ proof (subst arcosh_mono)
	+ show "?r1 \<ge> 1"
	+ using disc
	+ by (smt "*" le_divide_eq_1_pos mult_pos_pos zero_le_power2)
	+ next
	+ show "?r2 \<ge> 1"
	+ using disc
	+ by simp
	+ next
	+ show "?r1 \<ge> ?r2"
	+ using disc
	+ using *
	+ by (subst divide_right_mono, simp_all)
	+ qed
	+ ultimately
	+ show "poincare_distance (of_complex x) w \<le> poincare_distance (of_complex x) 0\<^sub>h + poincare_distance 0\<^sub>h w"
	+ using \<open>of_complex x \<in> unit_disc\<close> \<open>w \<in> unit_disc\<close> w
	+ using poincare_distance_formula
	+ by simp
	+ qed
	+ next
	+ show "v \<in> unit_disc" "u \<in> unit_disc"
	+ by fact+
	+ next
	+ fix M u v
	+ assume *: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc"
	+ assume **: "?P (moebius_pt M u) (moebius_pt M v)"
	+ show "?P u v"
	+ proof safe
	+ fix w
	+ assume "w \<in> unit_disc"
	+ thus "?P' v u w"
	+ using * **[rule_format, of "moebius_pt M w"]
	+ by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms
	+ by auto
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Poincare_Disc/Poincare_Lines.thy b/thys/Poincare_Disc/Poincare_Lines.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Poincare_Lines.thy
	@@ -0,0 +1,1878 @@
	+(* ------------------------------------------------------------------ *)
	+section \<open>H-lines in the Poincar\'e model\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+theory Poincare_Lines
	+ imports Complex_Geometry.Unit_Circle_Preserving_Moebius Complex_Geometry.Circlines_Angle
	+begin
	+
	+
	+(* ------------------------------------------------------------------ *)
	+subsection \<open>Definition and basic properties of h-lines\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text \<open>H-lines in the Poincar\'e model are either line segments passing trough the origin or
	+segments (within the unit disc) of circles that are perpendicular to the unit circle. Algebraically
	+these are circlines that are represented by Hermitean matrices of
	+the form
	+$$H = \left(
	+ \begin{array}{cc}
	+ A & B\\
	+ \overline{B} & A
	+ \end{array}
	+\right),$$
	+for $A \in \mathbb{R}$, and $B \in \mathbb{C}$, and $\|B\|^2 > A^2$,
	+where the circline equation is the usual one: $z^*Hz = 0$, for homogenous coordinates $z$.\<close>
	+
	+definition is_poincare_line_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "is_poincare_line_cmat H \<longleftrightarrow>
	+ (let (A, B, C, D) = H
	+ in hermitean (A, B, C, D) \<and> A = D \<and> (cmod B)\<^sup>2 > (cmod A)\<^sup>2)"
	+
	+lift_definition is_poincare_line_clmat :: "circline_mat \<Rightarrow> bool" is is_poincare_line_cmat
	+ done
	+
	+text \<open>We introduce the predicate that checks if a given complex matrix is a matrix of a h-line in
	+the Poincar\'e model, and then by means of the lifting package lift it to the type of non-zero
	+Hermitean matrices, and then to circlines (that are equivalence classes of such matrices).\<close>
	+
	+lift_definition is_poincare_line :: "circline \<Rightarrow> bool" is is_poincare_line_clmat
	+proof (transfer, transfer)
	+ fix H1 H2 :: complex_mat
	+ assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ assume "circline_eq_cmat H1 H2"
	+ thus "is_poincare_line_cmat H1 \<longleftrightarrow> is_poincare_line_cmat H2"
	+ using hh
	+ by (cases H1, cases H2) (auto simp add: power_mult_distrib)
	+qed
	+
	+lemma is_poincare_line_mk_circline:
	+ assumes "(A, B, C, D) \<in> hermitean_nonzero"
	+ shows "is_poincare_line (mk_circline A B C D) \<longleftrightarrow> (cmod B)\<^sup>2 > (cmod A)\<^sup>2 \<and> A = D"
	+ using assms
	+ by (transfer, transfer, auto simp add: Let_def)
	+
	+
	+text\<open>Abstract characterisation of @{term is_poincare_line} predicate: H-lines in the Poincar\'e
	+model are real circlines (circlines with the negative determinant) perpendicular to the unit
	+circle.\<close>
	+
	+lemma is_poincare_line_iff:
	+ shows "is_poincare_line H \<longleftrightarrow> circline_type H = -1 \<and> perpendicular H unit_circle"
	+ unfolding perpendicular_def
	+proof (simp, transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where *: "H = (A, B, C, D)"
	+ by (cases H, auto)
	+ have **: "is_real A" "is_real D" "C = cnj B"
	+ using hh * hermitean_elems
	+ by auto
	+ hence "(Re A = Re D \<and> cmod A * cmod A < cmod B * cmod B) =
	+ (Re A * Re D < Re B * Re B + Im B * Im B \<and> (Re D = Re A \<or> Re A * Re D = Re B * Re B + Im B * Im B))"
	+ using *
	+ by (smt cmod_power2 power2_eq_square zero_power2)+
	+ thus "is_poincare_line_cmat H \<longleftrightarrow>
	+ circline_type_cmat H = - 1 \<and> cos_angle_cmat (of_circline_cmat H) unit_circle_cmat = 0"
	+ using * **
	+ by (auto simp add: sgn_1_neg complex_eq_if_Re_eq cmod_square power2_eq_square simp del: pos_oriented_cmat_def)
	+qed
	+
	+text\<open>The @{term x_axis} is an h-line.\<close>
	+lemma is_poincare_line_x_axis [simp]:
	+ shows "is_poincare_line x_axis"
	+ by (transfer, transfer) (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+
	+text\<open>The @{term unit_circle} is not an h-line.\<close>
	+lemma not_is_poincare_line_unit_circle [simp]:
	+ shows "\<not> is_poincare_line unit_circle"
	+ by (transfer, transfer, simp)
	+
	+(* ------------------------------------------------------------------ *)
	+subsubsection \<open>Collinear points\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>Points are collinear if they all belong to an h-line. \<close>
	+definition poincare_collinear :: "complex_homo set \<Rightarrow> bool" where
	+ "poincare_collinear S \<longleftrightarrow> (\<exists> p. is_poincare_line p \<and> S \<subseteq> circline_set p)"
	+
	+(* ------------------------------------------------------------------ *)
	+subsubsection \<open>H-lines and inversion\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>Every h-line in the Poincar\'e model contains the inverse (wrt.~the unit circle) of each of its
	+points (note that at most one of them belongs to the unit disc).\<close>
	+lemma is_poincare_line_inverse_point:
	+ assumes "is_poincare_line H" "u \<in> circline_set H"
	+ shows "inversion u \<in> circline_set H"
	+ using assms
	+ unfolding is_poincare_line_iff circline_set_def perpendicular_def inversion_def
	+ apply simp
	+proof (transfer, transfer)
	+ fix u H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero" "u \<noteq> vec_zero" and
	+ aa: "circline_type_cmat H = - 1 \<and> cos_angle_cmat (of_circline_cmat H) unit_circle_cmat = 0" "on_circline_cmat_cvec H u"
	+ obtain A B C D u1 u2 where *: "H = (A, B, C, D)" "u = (u1, u2)"
	+ by (cases H, cases u, auto)
	+ have "is_real A" "is_real D" "C = cnj B"
	+ using * hh hermitean_elems
	+ by auto
	+ moreover
	+ have "A = D"
	+ using aa(1) * \<open>is_real A\<close> \<open>is_real D\<close>
	+ by (auto simp del: pos_oriented_cmat_def simp add: complex.expand split: if_split_asm)
	+ thus "on_circline_cmat_cvec H (conjugate_cvec (reciprocal_cvec u))"
	+ using aa(2) *
	+ by (simp add: vec_cnj_def field_simps)
	+qed
	+
	+text\<open>Every h-line in the Poincar\'e model and is invariant under unit circle inversion.\<close>
	+
	+lemma circline_inversion_poincare_line:
	+ assumes "is_poincare_line H"
	+ shows "circline_inversion H = H"
	+proof-
	+ obtain u v w where *: "u \<noteq> v" "v \<noteq> w" "u \<noteq> w" "{u, v, w} \<subseteq> circline_set H"
	+ using assms is_poincare_line_iff[of H]
	+ using circline_type_neg_card_gt3[of H]
	+ by auto
	+ hence "{inversion u, inversion v, inversion w} \<subseteq> circline_set (circline_inversion H)"
	+ "{inversion u, inversion v, inversion w} \<subseteq> circline_set H"
	+ using is_poincare_line_inverse_point[OF assms]
	+ by auto
	+ thus ?thesis
	+ using * unique_circline_set[of "inversion u" "inversion v" "inversion w"]
	+ by (metis insert_subset inversion_involution)
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsubsection \<open>Classification of h-lines into Euclidean segments and circles\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>If an h-line contains zero, than it also contains infinity (the inverse point of zero) and is by
	+definition an Euclidean line.\<close>
	+lemma is_poincare_line_trough_zero_trough_infty [simp]:
	+ assumes "is_poincare_line l" and "0\<^sub>h \<in> circline_set l"
	+ shows "\<infinity>\<^sub>h \<in> circline_set l"
	+ using is_poincare_line_inverse_point[OF assms]
	+ by simp
	+
	+lemma is_poincare_line_trough_zero_is_line:
	+ assumes "is_poincare_line l" and "0\<^sub>h \<in> circline_set l"
	+ shows "is_line l"
	+ using assms
	+ using inf_in_circline_set is_poincare_line_trough_zero_trough_infty
	+ by blast
	+
	+text\<open>If an h-line does not contain zero, than it also does not contain infinity (the inverse point of
	+zero) and is by definition an Euclidean circle.\<close>
	+lemma is_poincare_line_not_trough_zero_not_trough_infty [simp]:
	+ assumes "is_poincare_line l"
	+ assumes "0\<^sub>h \<notin> circline_set l"
	+ shows "\<infinity>\<^sub>h \<notin> circline_set l"
	+ using assms
	+ using is_poincare_line_inverse_point[OF assms(1), of "\<infinity>\<^sub>h"]
	+ by auto
	+
	+lemma is_poincare_line_not_trough_zero_is_circle:
	+ assumes "is_poincare_line l" "0\<^sub>h \<notin> circline_set l"
	+ shows "is_circle l"
	+ using assms
	+ using inf_in_circline_set is_poincare_line_not_trough_zero_not_trough_infty
	+ by auto
	+
	+(* ------------------------------------------------------------------ *)
	+subsubsection\<open>Points on h-line\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>Each h-line in the Poincar\'e model contains at least two different points within the unit
	+disc.\<close>
	+
	+text\<open>First we prove an auxiliary lemma.\<close>
	+lemma ex_is_poincare_line_points':
	+ assumes i12: "i1 \<in> circline_set H \<inter> unit_circle_set"
	+ "i2 \<in> circline_set H \<inter> unit_circle_set"
	+ "i1 \<noteq> i2"
	+ assumes a: "a \<in> circline_set H" "a \<notin> unit_circle_set"
	+ shows "\<exists> b. b \<noteq> i1 \<and> b \<noteq> i2 \<and> b \<noteq> a \<and> b \<noteq> inversion a \<and> b \<in> circline_set H"
	+proof-
	+ have "inversion a \<notin> unit_circle_set"
	+ using \<open>a \<notin> unit_circle_set\<close>
	+ unfolding unit_circle_set_def circline_set_def
	+ by (metis inversion_id_iff_on_unit_circle inversion_involution mem_Collect_eq)
	+
	+ have "a \<noteq> inversion a"
	+ using \<open>a \<notin> unit_circle_set\<close> inversion_id_iff_on_unit_circle[of a]
	+ unfolding unit_circle_set_def circline_set_def
	+ by auto
	+
	+ have "a \<noteq> i1" "a \<noteq> i2" "inversion a \<noteq> i1" "inversion a \<noteq> i2"
	+ using assms \<open>inversion a \<notin> unit_circle_set\<close>
	+ by auto
	+
	+ then obtain b where cr2: "cross_ratio b i1 a i2 = of_complex 2"
	+ using \<open>i1 \<noteq> i2\<close>
	+ using ex_cross_ratio[of i1 a i2]
	+ by blast
	+
	+ have distinct_b: "b \<noteq> i1" "b \<noteq> i2" "b \<noteq> a"
	+ using \<open>i1 \<noteq> i2\<close> \<open>a \<noteq> i1\<close> \<open>a \<noteq> i2\<close>
	+ using ex1_cross_ratio[of i1 a i2]
	+ using cross_ratio_0[of i1 a i2] cross_ratio_1[of i1 a i2] cross_ratio_inf[of i1 i2 a]
	+ using cr2
	+ by auto
	+
	+ hence "b \<in> circline_set H"
	+ using assms four_points_on_circline_iff_cross_ratio_real[of b i1 a i2] cr2
	+ using unique_circline_set[of i1 i2 a]
	+ by auto
	+
	+ moreover
	+
	+ have "b \<noteq> inversion a"
	+ proof (rule ccontr)
	+ assume *: "\<not> ?thesis"
	+ have "inversion i1 = i1" "inversion i2 = i2"
	+ using i12
	+ unfolding unit_circle_set_def
	+ by auto
	+ hence "cross_ratio (inversion a) i1 a i2 = cross_ratio a i1 (inversion a) i2"
	+ using * cross_ratio_inversion[of i1 a i2 b] \<open>a \<noteq> i1\<close> \<open>a \<noteq> i2\<close> \<open>i1 \<noteq> i2\<close> \<open>b \<noteq> i1\<close>
	+ using four_points_on_circline_iff_cross_ratio_real[of b i1 a i2]
	+ using i12 distinct_b conjugate_id_iff[of "cross_ratio b i1 a i2"]
	+ using i12 a \<open>b \<in> circline_set H\<close>
	+ by auto
	+ hence "cross_ratio (inversion a) i1 a i2 \<noteq> of_complex 2"
	+ using cross_ratio_commute_13[of "inversion a" i1 a i2]
	+ using reciprocal_id_iff
	+ using of_complex_inj
	+ by force
	+ thus False
	+ using * cr2
	+ by simp
	+ qed
	+
	+ ultimately
	+ show ?thesis
	+ using assms \<open>b \<noteq> i1\<close> \<open>b \<noteq> i2\<close> \<open>b \<noteq> a\<close>
	+ by auto
	+qed
	+
	+text\<open>Now we can prove the statement.\<close>
	+lemma ex_is_poincare_line_points:
	+ assumes "is_poincare_line H"
	+ shows "\<exists> u v. u \<in> unit_disc \<and> v \<in> unit_disc \<and> u \<noteq> v \<and> {u, v} \<subseteq> circline_set H"
	+proof-
	+ obtain u v w where *: "u \<noteq> v" "v \<noteq> w" "u \<noteq> w" "{u, v, w} \<subseteq> circline_set H"
	+ using assms is_poincare_line_iff[of H]
	+ using circline_type_neg_card_gt3[of H]
	+ by auto
	+
	+ have "\<not> {u, v, w} \<subseteq> unit_circle_set"
	+ using unique_circline_set[of u v w] *
	+ by (metis assms insert_subset not_is_poincare_line_unit_circle unit_circle_set_def)
	+
	+ hence "H \<noteq> unit_circle"
	+ unfolding unit_circle_set_def
	+ using *
	+ by auto
	+
	+ show ?thesis
	+ proof (cases "(u \<in> unit_disc \<and> v \<in> unit_disc) \<or>
	+ (u \<in> unit_disc \<and> w \<in> unit_disc) \<or>
	+ (v \<in> unit_disc \<and> w \<in> unit_disc)")
	+ case True
	+ thus ?thesis
	+ using *
	+ by auto
	+ next
	+ case False
	+
	+ have "\<exists> a b. a \<noteq> b \<and> a \<noteq> inversion b \<and> a \<in> circline_set H \<and> b \<in> circline_set H \<and> a \<notin> unit_circle_set \<and> b \<notin> unit_circle_set"
	+ proof (cases "(u \<in> unit_circle_set \<and> v \<in> unit_circle_set) \<or>
	+ (u \<in> unit_circle_set \<and> w \<in> unit_circle_set) \<or>
	+ (v \<in> unit_circle_set \<and> w \<in> unit_circle_set)")
	+ case True
	+ then obtain i1 i2 a where *:
	+ "i1 \<in> unit_circle_set \<inter> circline_set H" "i2 \<in> unit_circle_set \<inter> circline_set H"
	+ "a \<in> circline_set H" "a \<notin> unit_circle_set"
	+ "i1 \<noteq> i2" "i1 \<noteq> a" "i2 \<noteq> a"
	+ using * \<open>\<not> {u, v, w} \<subseteq> unit_circle_set\<close>
	+ by auto
	+ then obtain b where "b \<in> circline_set H" "b \<noteq> i1" "b \<noteq> i2" "b \<noteq> a" "b \<noteq> inversion a"
	+ using ex_is_poincare_line_points'[of i1 H i2 a]
	+ by blast
	+
	+ hence "b \<notin> unit_circle_set"
	+ using * \<open>H \<noteq> unit_circle\<close> unique_circline_set[of i1 i2 b]
	+ unfolding unit_circle_set_def
	+ by auto
	+
	+ thus ?thesis
	+ using * \<open>b \<in> circline_set H\<close> \<open>b \<noteq> a\<close> \<open>b \<noteq> inversion a\<close>
	+ by auto
	+ next
	+ case False
	+ then obtain f g h where
	+ *: "f \<noteq> g" "f \<in> circline_set H" "f \<notin> unit_circle_set"
	+ "g \<in> circline_set H" "g \<notin> unit_circle_set"
	+ "h \<in> circline_set H" "h \<noteq> f" "h \<noteq> g"
	+ using *
	+ by auto
	+ show ?thesis
	+ proof (cases "f = inversion g")
	+ case False
	+ thus ?thesis
	+ using *
	+ by auto
	+ next
	+ case True
	+ show ?thesis
	+ proof (cases "h \<in> unit_circle_set")
	+ case False
	+ thus ?thesis
	+ using * \<open>f = inversion g\<close>
	+ by auto
	+ next
	+ case True
	+ obtain m where cr2: "cross_ratio m h f g = of_complex 2"
	+ using ex_cross_ratio[of h f g] * \<open>f \<noteq> g\<close> \<open>h \<noteq> f\<close> \<open>h \<noteq> g\<close>
	+ by auto
	+ hence "m \<noteq> h" "m \<noteq> f" "m \<noteq> g"
	+ using \<open>h \<noteq> f\<close> \<open>h \<noteq> g\<close> \<open>f \<noteq> g\<close>
	+ using ex1_cross_ratio[of h f g]
	+ using cross_ratio_0[of h f g] cross_ratio_1[of h f g] cross_ratio_inf[of h g f]
	+ using cr2
	+ by auto
	+ hence "m \<in> circline_set H"
	+ using four_points_on_circline_iff_cross_ratio_real[of m h f g] cr2
	+ using \<open>h \<noteq> f\<close> \<open>h \<noteq> g\<close> \<open>f \<noteq> g\<close> *
	+ using unique_circline_set[of h f g]
	+ by auto
	+
	+ show ?thesis
	+ proof (cases "m \<in> unit_circle_set")
	+ case False
	+ thus ?thesis
	+ using \<open>m \<noteq> f\<close> \<open>m \<noteq> g\<close> \<open>f = inversion g\<close> * \<open>m \<in> circline_set H\<close>
	+ by auto
	+ next
	+ case True
	+ then obtain n where "n \<noteq> h" "n \<noteq> m" "n \<noteq> f" "n \<noteq> inversion f" "n \<in> circline_set H"
	+ using ex_is_poincare_line_points'[of h H m f] * \<open>m \<in> circline_set H\<close> \<open>h \<in> unit_circle_set\<close> \<open>m \<noteq> h\<close>
	+ by auto
	+ hence "n \<notin> unit_circle_set"
	+ using * \<open>H \<noteq> unit_circle\<close> unique_circline_set[of m n h]
	+ using \<open>m \<noteq> h\<close> \<open>m \<in> unit_circle_set\<close> \<open>h \<in> unit_circle_set\<close> \<open>m \<in> circline_set H\<close>
	+ unfolding unit_circle_set_def
	+ by auto
	+
	+ thus ?thesis
	+ using * \<open>n \<in> circline_set H\<close> \<open>n \<noteq> f\<close> \<open>n \<noteq> inversion f\<close>
	+ by auto
	+ qed
	+ qed
	+ qed
	+ qed
	+ then obtain a b where ab: "a \<noteq> b" "a \<noteq> inversion b" "a \<in> circline_set H" "b \<in> circline_set H" "a \<notin> unit_circle_set" "b \<notin> unit_circle_set"
	+ by blast
	+ have "\<forall> x. x \<in> circline_set H \<and> x \<notin> unit_circle_set \<longrightarrow> (\<exists> x'. x' \<in> circline_set H \<inter> unit_disc \<and> (x' = x \<or> x' = inversion x))"
	+ proof safe
	+ fix x
	+ assume x: "x \<in> circline_set H" "x \<notin> unit_circle_set"
	+ show "\<exists> x'. x' \<in> circline_set H \<inter> unit_disc \<and> (x' = x \<or> x' = inversion x)"
	+ proof (cases "x \<in> unit_disc")
	+ case True
	+ thus ?thesis
	+ using x
	+ by auto
	+ next
	+ case False
	+ hence "x \<in> unit_disc_compl"
	+ using x in_on_out_univ[of "ounit_circle"]
	+ unfolding unit_circle_set_def unit_disc_def unit_disc_compl_def
	+ by auto
	+ hence "inversion x \<in> unit_disc"
	+ using inversion_unit_disc_compl
	+ by blast
	+ thus ?thesis
	+ using is_poincare_line_inverse_point[OF assms, of x] x
	+ by auto
	+ qed
	+ qed
	+ then obtain a' b' where
	+ *: "a' \<in> circline_set H" "a' \<in> unit_disc" "b' \<in> circline_set H" "b' \<in> unit_disc" and
	+ **: "a' = a \<or> a' = inversion a" "b' = b \<or> b' = inversion b"
	+ using ab
	+ by blast
	+ have "a' \<noteq> b'"
	+ using \<open>a \<noteq> b\<close> \<open>a \<noteq> inversion b\<close> ** *
	+ by (metis inversion_involution)
	+ thus ?thesis
	+ using *
	+ by auto
	+ qed
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsubsection \<open>H-line uniqueness\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>There is no more than one h-line that contains two different h-points (in the disc).\<close>
	+lemma unique_is_poincare_line:
	+ assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ assumes pl: "is_poincare_line l1" "is_poincare_line l2"
	+ assumes on_l: "{u, v} \<subseteq> circline_set l1 \<inter> circline_set l2"
	+ shows "l1 = l2"
	+proof-
	+ have "u \<noteq> inversion u" "v \<noteq> inversion u"
	+ using in_disc
	+ using inversion_noteq_unit_disc[of u v]
	+ using inversion_noteq_unit_disc[of u u]
	+ by auto
	+ thus ?thesis
	+ using on_l
	+ using unique_circline_set[of u "inversion u" "v"] \<open>u \<noteq> v\<close>
	+ using is_poincare_line_inverse_point[of l1 u]
	+ using is_poincare_line_inverse_point[of l2 u]
	+ using pl
	+ by auto
	+qed
	+
	+text\<open>For the rest of our formalization it is often useful to consider points on h-lines that are not
	+within the unit disc. Many lemmas in the rest of this section will have such generalizations.\<close>
	+
	+text\<open>There is no more than one h-line that contains two different and not mutually inverse points
	+(not necessary in the unit disc).\<close>
	+lemma unique_is_poincare_line_general:
	+ assumes different: "u \<noteq> v" "u \<noteq> inversion v"
	+ assumes pl: "is_poincare_line l1" "is_poincare_line l2"
	+ assumes on_l: "{u, v} \<subseteq> circline_set l1 \<inter> circline_set l2"
	+ shows "l1 = l2"
	+proof (cases "u \<noteq> inversion u")
	+ case True
	+ thus ?thesis
	+ using unique_circline_set[of u "inversion u" "v"]
	+ using assms
	+ using is_poincare_line_inverse_point by force
	+next
	+ case False
	+ show ?thesis
	+ proof (cases "v \<noteq> inversion v")
	+ case True
	+ thus ?thesis
	+ using unique_circline_set[of u "inversion v" "v"]
	+ using assms
	+ using is_poincare_line_inverse_point by force
	+ next
	+ case False
	+
	+ have "on_circline unit_circle u" "on_circline unit_circle v"
	+ using `\<not> u \<noteq> inversion u` `\<not> v \<noteq> inversion v`
	+ using inversion_id_iff_on_unit_circle
	+ by fastforce+
	+ thus ?thesis
	+ using pl on_l `u \<noteq> v`
	+ unfolding circline_set_def
	+ apply simp
	+ proof (transfer, transfer, safe)
	+ fix u1 u2 v1 v2 A1 B1 C1 D1 A2 B2 C2 D2 :: complex
	+ let ?u = "(u1, u2)" and ?v = "(v1, v2)" and ?H1 = "(A1, B1, C1, D1)" and ?H2 = "(A2, B2, C2, D2)"
	+ assume *: "?u \<noteq> vec_zero" "?v \<noteq> vec_zero"
	+ "on_circline_cmat_cvec unit_circle_cmat ?u" "on_circline_cmat_cvec unit_circle_cmat ?v"
	+ "is_poincare_line_cmat ?H1" "is_poincare_line_cmat ?H2"
	+ "hermitean ?H1" "?H1 \<noteq> mat_zero" "hermitean ?H2" "?H2 \<noteq> mat_zero"
	+ "on_circline_cmat_cvec ?H1 ?u" "on_circline_cmat_cvec ?H1 ?v"
	+ "on_circline_cmat_cvec ?H2 ?u" "on_circline_cmat_cvec ?H2 ?v"
	+ "\<not> (u1, u2) \<approx>\<^sub>v (v1, v2)"
	+ have **: "A1 = D1" "A2 = D2" "C1 = cnj B1" "C2 = cnj B2" "is_real A1" "is_real A2"
	+ using `is_poincare_line_cmat ?H1` `is_poincare_line_cmat ?H2`
	+ using `hermitean ?H1` `?H1 \<noteq> mat_zero` `hermitean ?H2` `?H2 \<noteq> mat_zero`
	+ using hermitean_elems
	+ by auto
	+
	+ have uv: "u1 \<noteq> 0" "u2 \<noteq> 0" "v1 \<noteq> 0" "v2 \<noteq> 0"
	+ using *(1-4)
	+ by (auto simp add: vec_cnj_def)
	+
	+ have u: "cor ((Re (u1/u2))\<^sup>2) + cor ((Im (u1/u2))\<^sup>2) = 1"
	+ using `on_circline_cmat_cvec unit_circle_cmat ?u` uv
	+ apply (subst cor_add[symmetric])
	+ apply (subst complex_mult_cnj[symmetric])
	+ apply (simp add: vec_cnj_def mult.commute)
	+ done
	+
	+ have v: "cor ((Re (v1/v2))\<^sup>2) + cor ((Im (v1/v2))\<^sup>2) = 1"
	+ using `on_circline_cmat_cvec unit_circle_cmat ?v` uv
	+ apply (subst cor_add[symmetric])
	+ apply (subst complex_mult_cnj[symmetric])
	+ apply (simp add: vec_cnj_def mult.commute)
	+ done
	+
	+ have
	+ "A1 * (cor ((Re (u1/u2))\<^sup>2) + cor ((Im (u1/u2))\<^sup>2) + 1) + cor (Re B1) * cor(2 * Re (u1/u2)) + cor (Im B1) * cor(2 * Im (u1/u2)) = 0"
	+ "A2 * (cor ((Re (u1/u2))\<^sup>2) + cor ((Im (u1/u2))\<^sup>2) + 1) + cor (Re B2) * cor(2 * Re (u1/u2)) + cor (Im B2) * cor(2 * Im (u1/u2)) = 0"
	+ "A1 * (cor ((Re (v1/v2))\<^sup>2) + cor ((Im (v1/v2))\<^sup>2) + 1) + cor (Re B1) * cor(2 * Re (v1/v2)) + cor (Im B1) * cor(2 * Im (v1/v2)) = 0"
	+ "A2 * (cor ((Re (v1/v2))\<^sup>2) + cor ((Im (v1/v2))\<^sup>2) + 1) + cor (Re B2) * cor(2 * Re (v1/v2)) + cor (Im B2) * cor(2 * Im (v1/v2)) = 0"
	+ using circline_equation_quadratic_equation[of A1 "u1/u2" B1 D1 "Re (u1/u2)" "Im (u1 / u2)" "Re B1" "Im B1"]
	+ using circline_equation_quadratic_equation[of A2 "u1/u2" B2 D2 "Re (u1/u2)" "Im (u1 / u2)" "Re B2" "Im B2"]
	+ using circline_equation_quadratic_equation[of A1 "v1/v2" B1 D1 "Re (v1/v2)" "Im (v1 / v2)" "Re B1" "Im B1"]
	+ using circline_equation_quadratic_equation[of A2 "v1/v2" B2 D2 "Re (v1/v2)" "Im (v1 / v2)" "Re B2" "Im B2"]
	+ using `on_circline_cmat_cvec ?H1 ?u` `on_circline_cmat_cvec ?H2 ?u`
	+ using `on_circline_cmat_cvec ?H1 ?v` `on_circline_cmat_cvec ?H2 ?v`
	+ using ** uv
	+ by (simp_all add: vec_cnj_def field_simps)
	+
	+ hence
	+ "A1 + cor (Re B1) * cor(Re (u1/u2)) + cor (Im B1) * cor(Im (u1/u2)) = 0"
	+ "A1 + cor (Re B1) * cor(Re (v1/v2)) + cor (Im B1) * cor(Im (v1/v2)) = 0"
	+ "A2 + cor (Re B2) * cor(Re (u1/u2)) + cor (Im B2) * cor(Im (u1/u2)) = 0"
	+ "A2 + cor (Re B2) * cor(Re (v1/v2)) + cor (Im B2) * cor(Im (v1/v2)) = 0"
	+ using u v
	+ by simp_all algebra+
	+
	+ hence
	+ "cor (Re A1 + Re B1 * Re (u1/u2) + Im B1 * Im (u1/u2)) = 0"
	+ "cor (Re A2 + Re B2 * Re (u1/u2) + Im B2 * Im (u1/u2)) = 0"
	+ "cor (Re A1 + Re B1 * Re (v1/v2) + Im B1 * Im (v1/v2)) = 0"
	+ "cor (Re A2 + Re B2 * Re (v1/v2) + Im B2 * Im (v1/v2)) = 0"
	+ using `is_real A1` `is_real A2`
	+ by simp_all
	+
	+ hence
	+ "Re A1 + Re B1 * Re (u1/u2) + Im B1 * Im (u1/u2) = 0"
	+ "Re A1 + Re B1 * Re (v1/v2) + Im B1 * Im (v1/v2) = 0"
	+ "Re A2 + Re B2 * Re (u1/u2) + Im B2 * Im (u1/u2) = 0"
	+ "Re A2 + Re B2 * Re (v1/v2) + Im B2 * Im (v1/v2) = 0"
	+ using of_real_eq_0_iff
	+ by blast+
	+
	+ moreover
	+
	+ have "Re(u1/u2) \<noteq> Re(v1/v2) \<or> Im(u1/u2) \<noteq> Im(v1/v2)"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "u1/u2 = v1/v2"
	+ using complex_eqI by blast
	+ thus False
	+ using uv `\<not> (u1, u2) \<approx>\<^sub>v (v1, v2)`
	+ using ""(1) ""(2) complex_cvec_eq_mix[OF (1) (2)]
	+ by (auto simp add: field_simps)
	+ qed
	+
	+ moreover
	+
	+ have "Re A1 \<noteq> 0 \<or> Re B1 \<noteq> 0 \<or> Im B1 \<noteq> 0"
	+ using `?H1 \<noteq> mat_zero` **
	+ by (metis complex_cnj_zero complex_of_real_Re mat_zero_def of_real_0)
	+
	+ ultimately
	+
	+ obtain k where
	+ k: "Re A2 = k * Re A1" "Re B2 = k * Re B1" "Im B2 = k * Im B1"
	+ using linear_system_homogenous_3_2[of "\<lambda>x y z. 1 * x + Re (u1 / u2) * y + Im (u1 / u2) * z" 1 "Re (u1/u2)" "Im (u1/u2)"
	+ "\<lambda>x y z. 1 * x + Re (v1 / v2) * y + Im (v1 / v2) * z" 1 "Re (v1/v2)" "Im (v1/v2)"
	+ "Re A2" "Re B2" "Im B2" "Re A1" "Re B1" "Im B1"]
	+ by (auto simp add: field_simps)
	+
	+ have "Re A2 \<noteq> 0 \<or> Re B2 \<noteq> 0 \<or> Im B2 \<noteq> 0"
	+ using `?H2 \<noteq> mat_zero` **
	+ by (metis complex_cnj_zero complex_of_real_Re mat_zero_def of_real_0)
	+ hence "k \<noteq> 0"
	+ using k
	+ by auto
	+
	+ show "circline_eq_cmat ?H1 ?H2"
	+ using ** k `k \<noteq> 0`
	+ by (auto simp add: vec_cnj_def) (rule_tac x="k" in exI, auto simp add: complex.expand)
	+ qed
	+ qed
	+qed
	+
	+text \<open>The only h-line that goes trough zero and a non-zero point on the x-axis is the x-axis.\<close>
	+lemma is_poincare_line_0_real_is_x_axis:
	+ assumes "is_poincare_line l" "0\<^sub>h \<in> circline_set l"
	+ "x \<in> circline_set l \<inter> circline_set x_axis" "x \<noteq> 0\<^sub>h" "x \<noteq> \<infinity>\<^sub>h"
	+ shows "l = x_axis"
	+ using assms
	+ using is_poincare_line_trough_zero_trough_infty[OF assms(1-2)]
	+ using unique_circline_set[of x "0\<^sub>h" "\<infinity>\<^sub>h"]
	+ by auto
	+
	+text \<open>The only h-line that goes trough zero and a non-zero point on the y-axis is the y-axis.\<close>
	+lemma is_poincare_line_0_imag_is_y_axis:
	+ assumes "is_poincare_line l" "0\<^sub>h \<in> circline_set l"
	+ "y \<in> circline_set l \<inter> circline_set y_axis" "y \<noteq> 0\<^sub>h" "y \<noteq> \<infinity>\<^sub>h"
	+ shows "l = y_axis"
	+ using assms
	+ using is_poincare_line_trough_zero_trough_infty[OF assms(1-2)]
	+ using unique_circline_set[of y "0\<^sub>h" "\<infinity>\<^sub>h"]
	+ by auto
	+
	+(* ------------------------------------------------------------------ *)
	+subsubsection\<open>H-isometries preserve h-lines\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>\emph{H-isometries} are defined as homographies (actions of Möbius transformations) and
	+antihomographies (compositions of actions of Möbius transformations with conjugation) that fix the
	+unit disc (map it onto itself). They also map h-lines onto h-lines\<close>
	+
	+text\<open>We prove a bit more general lemma that states that all Möbius transformations that fix the
	+unit circle (not necessary the unit disc) map h-lines onto h-lines\<close>
	+lemma unit_circle_fix_preserve_is_poincare_line [simp]:
	+ assumes "unit_circle_fix M" "is_poincare_line H"
	+ shows "is_poincare_line (moebius_circline M H)"
	+ using assms
	+ unfolding is_poincare_line_iff
	+proof (safe)
	+ let ?H' = "moebius_ocircline M (of_circline H)"
	+ let ?U' = "moebius_ocircline M ounit_circle"
	+ assume ++: "unit_circle_fix M" "perpendicular H unit_circle"
	+ have ounit: "ounit_circle = moebius_ocircline M ounit_circle \<or>
	+ ounit_circle = moebius_ocircline M (opposite_ocircline ounit_circle)"
	+ using ++(1) unit_circle_fix_iff[of M]
	+ by (simp add: inj_of_ocircline moebius_circline_ocircline)
	+
	+ show "perpendicular (moebius_circline M H) unit_circle"
	+ proof (cases "pos_oriented ?H'")
	+ case True
	+ hence *: "of_circline (of_ocircline ?H') = ?H'"
	+ using of_circline_of_ocircline_pos_oriented
	+ by blast
	+ from ounit show ?thesis
	+ proof
	+ assume **: "ounit_circle = moebius_ocircline M ounit_circle"
	+ show ?thesis
	+ using ++
	+ unfolding perpendicular_def
	+ by (simp, subst moebius_circline_ocircline, subst , subst *) simp
	+ next
	+ assume **: "ounit_circle = moebius_ocircline M (opposite_ocircline ounit_circle)"
	+ show ?thesis
	+ using ++
	+ unfolding perpendicular_def
	+ by (simp, subst moebius_circline_ocircline, subst , subst *) simp
	+ qed
	+ next
	+ case False
	+ hence *: "of_circline (of_ocircline ?H') = opposite_ocircline ?H'"
	+ by (metis of_circline_of_ocircline pos_oriented_of_circline)
	+ from ounit show ?thesis
	+ proof
	+ assume **: "ounit_circle = moebius_ocircline M ounit_circle"
	+ show ?thesis
	+ using ++
	+ unfolding perpendicular_def
	+ by (simp, subst moebius_circline_ocircline, subst , subst *) simp
	+ next
	+ assume **: "ounit_circle = moebius_ocircline M (opposite_ocircline ounit_circle)"
	+ show ?thesis
	+ using ++
	+ unfolding perpendicular_def
	+ by (simp, subst moebius_circline_ocircline, subst , subst *) simp
	+ qed
	+ qed
	+qed simp
	+
	+lemma unit_circle_fix_preserve_is_poincare_line_iff [simp]:
	+ assumes "unit_circle_fix M"
	+ shows "is_poincare_line (moebius_circline M H) \<longleftrightarrow> is_poincare_line H"
	+ using assms
	+ using unit_circle_fix_preserve_is_poincare_line[of M H]
	+ using unit_circle_fix_preserve_is_poincare_line[of "moebius_inv M" "moebius_circline M H"]
	+ by (auto simp del: unit_circle_fix_preserve_is_poincare_line)
	+
	+text\<open>Since h-lines are preserved by transformations that fix the unit circle, so is collinearity.\<close>
	+lemma unit_disc_fix_preserve_poincare_collinear [simp]:
	+ assumes "unit_circle_fix M" "poincare_collinear A"
	+ shows "poincare_collinear (moebius_pt M ` A)"
	+ using assms
	+ unfolding poincare_collinear_def
	+ by (auto, rule_tac x="moebius_circline M p" in exI, auto)
	+
	+lemma unit_disc_fix_preserve_poincare_collinear_iff [simp]:
	+ assumes "unit_circle_fix M"
	+ shows "poincare_collinear (moebius_pt M ` A) \<longleftrightarrow> poincare_collinear A"
	+ using assms
	+ using unit_disc_fix_preserve_poincare_collinear[of M A]
	+ using unit_disc_fix_preserve_poincare_collinear[of "moebius_inv M" "moebius_pt M ` A"]
	+ by (auto simp del: unit_disc_fix_preserve_poincare_collinear)
	+
	+lemma unit_disc_fix_preserve_poincare_collinear3 [simp]:
	+ assumes "unit_disc_fix M"
	+ shows "poincare_collinear {moebius_pt M u, moebius_pt M v, moebius_pt M w} \<longleftrightarrow>
	+ poincare_collinear {u, v, w}"
	+ using assms unit_disc_fix_preserve_poincare_collinear_iff[of M "{u, v, w}"]
	+ by simp
	+
	+text\<open>Conjugation is also an h-isometry and it preserves h-lines.\<close>
	+lemma is_poincare_line_conjugate_circline [simp]:
	+ assumes "is_poincare_line H"
	+ shows "is_poincare_line (conjugate_circline H)"
	+ using assms
	+ by (transfer, transfer, auto simp add: mat_cnj_def hermitean_def mat_adj_def)
	+
	+lemma is_poincare_line_conjugate_circline_iff [simp]:
	+ shows "is_poincare_line (conjugate_circline H) \<longleftrightarrow> is_poincare_line H"
	+ using is_poincare_line_conjugate_circline[of "conjugate_circline H"]
	+ by auto
	+
	+text\<open>Since h-lines are preserved by conjugation, so is collinearity.\<close>
	+lemma conjugate_preserve_poincare_collinear [simp]:
	+ assumes "poincare_collinear A"
	+ shows "poincare_collinear (conjugate ` A)"
	+ using assms
	+ unfolding poincare_collinear_def
	+ by auto (rule_tac x="conjugate_circline p" in exI, auto)
	+
	+lemma conjugate_conjugate [simp]: "conjugate ` conjugate ` A = A"
	+ by (auto simp add: image_iff)
	+
	+lemma conjugate_preserve_poincare_collinear_iff [simp]:
	+ shows "poincare_collinear (conjugate ` A) \<longleftrightarrow> poincare_collinear A"
	+ using conjugate_preserve_poincare_collinear[of "A"]
	+ using conjugate_preserve_poincare_collinear[of "conjugate ` A"]
	+ by (auto simp del: conjugate_preserve_poincare_collinear)
	+
	+(* ------------------------------------------------------------------ *)
	+subsubsection\<open>Mapping h-lines to x-axis\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>Each h-line in the Poincar\'e model can be mapped onto the x-axis (by a unit-disc preserving
	+Möbius transformation).\<close>
	+lemma ex_unit_disc_fix_is_poincare_line_to_x_axis:
	+ assumes "is_poincare_line l"
	+ shows "\<exists> M. unit_disc_fix M \<and> moebius_circline M l = x_axis"
	+proof-
	+ from assms obtain u v where "u \<noteq> v" "u \<in> unit_disc" "v \<in> unit_disc" and "{u, v} \<subseteq> circline_set l"
	+ using ex_is_poincare_line_points
	+ by blast
	+ then obtain M where *: "unit_disc_fix M" "moebius_pt M u = 0\<^sub>h" "moebius_pt M v \<in> positive_x_axis"
	+ using ex_unit_disc_fix_to_zero_positive_x_axis[of u v]
	+ by auto
	+ moreover
	+ hence "{0\<^sub>h, moebius_pt M v} \<subseteq> circline_set x_axis"
	+ unfolding positive_x_axis_def
	+ by auto
	+ moreover
	+ have "moebius_pt M v \<noteq> 0\<^sub>h"
	+ using \<open>u \<noteq> v\<close> *
	+ by (metis moebius_pt_neq_I)
	+ moreover
	+ have "moebius_pt M v \<noteq> \<infinity>\<^sub>h"
	+ using \<open>unit_disc_fix M\<close> \<open>v \<in> unit_disc\<close>
	+ using unit_disc_fix_discI
	+ by fastforce
	+ ultimately
	+ show ?thesis
	+ using \<open>is_poincare_line l\<close> \<open>{u, v} \<subseteq> circline_set l\<close> \<open>unit_disc_fix M\<close>
	+ using is_poincare_line_0_real_is_x_axis[of "moebius_circline M l" "moebius_pt M v"]
	+ by (rule_tac x="M" in exI, force)
	+qed
	+
	+text \<open>When proving facts about h-lines, without loss of generality it can be assumed that h-line is
	+the x-axis (if the property being proved is invariant under Möbius transformations that fix the
	+unit disc).\<close>
	+
	+lemma wlog_line_x_axis:
	+ assumes is_line: "is_poincare_line H"
	+ assumes x_axis: "P x_axis"
	+ assumes preserves: "\<And> M. \<lbrakk>unit_disc_fix M; P (moebius_circline M H)\<rbrakk> \<Longrightarrow> P H"
	+ shows "P H"
	+ using assms
	+ using ex_unit_disc_fix_is_poincare_line_to_x_axis[of H]
	+ by auto
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Construction of the h-line between the two given points\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>Next we show how to construct the (unique) h-line between the two given points in the Poincar\'e model\<close>
	+
	+text\<open>
	+Geometrically, h-line can be constructed by finding the inverse point of one of the two points and
	+by constructing the circle (or line) trough it and the two given points.
	+
	+Algebraically, for two given points $u$ and $v$ in $\mathbb{C}$, the h-line matrix coefficients can
	+be $A = i\cdot(u\overline{v}-v\overline{u})$ and $B = i\cdot(v(\|u\|^2+1) - u(\|v\|^2+1))$.
	+
	+We need to extend this to homogenous coordinates. There are several degenerate cases.
	+
	+ - If $\{z, w\} = \{0_h, \infty_h\}$ then there is no unique h-line (any line trough zero is an h-line).
	+
	+ - If z and w are mutually inverse, then the construction fails (both geometric and algebraic).
	+
	+ - If z and w are different points on the unit circle, then the standard construction fails (only geometric).
	+
	+ - None of this problematic cases occur when z and w are inside the unit disc.
	+
	+We express the construction algebraically, and construct the Hermitean circline matrix for the two
	+points given in homogenous coordinates. It works correctly in all cases except when the two points
	+are the same or are mutually inverse.
	+\<close>
	+
	+
	+definition mk_poincare_line_cmat :: "real \<Rightarrow> complex \<Rightarrow> complex_mat" where
	+ [simp]: "mk_poincare_line_cmat A B = (cor A, B, cnj B, cor A)"
	+
	+lemma mk_poincare_line_cmat_zero_iff:
	+ "mk_poincare_line_cmat A B = mat_zero \<longleftrightarrow> A = 0 \<and> B = 0"
	+ by auto
	+
	+lemma mk_poincare_line_cmat_hermitean
	+ [simp]: "hermitean (mk_poincare_line_cmat A B)"
	+ by simp
	+
	+lemma mk_poincare_line_cmat_scale:
	+ "cor k \<^sub>s\<^sub>m mk_poincare_line_cmat A B = mk_poincare_line_cmat (k A) (k * B)"
	+ by simp
	+
	+definition poincare_line_cvec_cmat :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_mat" where
	+ [simp]: "poincare_line_cvec_cmat z w =
	+ (let (z1, z2) = z;
	+ (w1, w2) = w;
	+ nom = w1cnj w2(z1cnj z1 + z2cnj z2) - z1cnj z2(w1cnj w1 + w2cnj w2);
	+ den = z1cnj z2cnj w1w2 - w1cnj w2cnj z1z2
	+ in if den \<noteq> 0 then
	+ mk_poincare_line_cmat (Re(\<i>den)) (\<i>nom)
	+ else if z1*cnj z2 \<noteq> 0 then
	+ mk_poincare_line_cmat 0 (\<i>z1cnj z2)
	+ else if w1*cnj w2 \<noteq> 0 then
	+ mk_poincare_line_cmat 0 (\<i>w1cnj w2)
	+ else
	+ mk_poincare_line_cmat 0 \<i>)"
	+
	+lemma poincare_line_cvec_cmat_AeqD:
	+ assumes "poincare_line_cvec_cmat z w = (A, B, C, D)"
	+ shows "A = D"
	+ using assms
	+ by (cases z, cases w) (auto split: if_split_asm)
	+
	+lemma poincare_line_cvec_cmat_hermitean [simp]:
	+ shows "hermitean (poincare_line_cvec_cmat z w)"
	+ by (cases z, cases w) (auto split: if_split_asm simp del: mk_poincare_line_cmat_def)
	+
	+lemma poincare_line_cvec_cmat_nonzero [simp]:
	+ assumes "z \<noteq> vec_zero" "w \<noteq> vec_zero"
	+ shows "poincare_line_cvec_cmat z w \<noteq> mat_zero"
	+proof-
	+
	+ obtain z1 z2 w1 w2 where *: "z = (z1, z2)" "w = (w1, w2)"
	+ by (cases z, cases w, auto)
	+
	+ let ?den = "z1cnj z2cnj w1w2 - w1cnj w2cnj z1z2"
	+ show ?thesis
	+ proof (cases "?den \<noteq> 0")
	+ case True
	+ have "is_real (\<i> * ?den)"
	+ using eq_cnj_iff_real[of "\<i> *?den"]
	+ by (simp add: field_simps)
	+ hence "Re (\<i> * ?den) \<noteq> 0"
	+ using \<open>?den \<noteq> 0\<close>
	+ by (metis complex_i_not_zero complex_surj mult_eq_0_iff zero_complex.code)
	+ thus ?thesis
	+ using * \<open>?den \<noteq> 0\<close>
	+ by (simp del: mk_poincare_line_cmat_def mat_zero_def add: mk_poincare_line_cmat_zero_iff)
	+ next
	+ case False
	+ thus ?thesis
	+ using *
	+ by (simp del: mk_poincare_line_cmat_def mat_zero_def add: mk_poincare_line_cmat_zero_iff)
	+ qed
	+qed
	+
	+lift_definition poincare_line_hcoords_clmat :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> circline_mat" is poincare_line_cvec_cmat
	+ using poincare_line_cvec_cmat_hermitean poincare_line_cvec_cmat_nonzero
	+ by simp
	+
	+lift_definition poincare_line :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> circline" is poincare_line_hcoords_clmat
	+proof transfer
	+ fix za zb wa wb
	+ assume "za \<noteq> vec_zero" "zb \<noteq> vec_zero" "wa \<noteq> vec_zero" "wb \<noteq> vec_zero"
	+ assume "za \<approx>\<^sub>v zb" "wa \<approx>\<^sub>v wb"
	+ obtain za1 za2 zb1 zb2 wa1 wa2 wb1 wb2 where
	+ *: "(za1, za2) = za" "(zb1, zb2) = zb"
	+ "(wa1, wa2) = wa" "(wb1, wb2) = wb"
	+ by (cases za, cases zb, cases wa, cases wb, auto)
	+ obtain kz kw where
	+ *: "kz \<noteq> 0" "kw \<noteq> 0" "zb1 = kz za1" "zb2 = kz * za2" "wb1 = kw * wa1" "wb2 = kw * wa2"
	+ using \<open>za \<approx>\<^sub>v zb\<close> \<open>wa \<approx>\<^sub>v wb\<close> *[symmetric]
	+ by auto
	+
	+ let ?nom = "\<lambda> z1 z2 w1 w2. w1cnj w2(z1cnj z1 + z2cnj z2) - z1cnj z2(w1cnj w1 + w2cnj w2)"
	+ let ?den = "\<lambda> z1 z2 w1 w2. z1cnj z2cnj w1w2 - w1cnj w2cnj z1z2"
	+
	+ show "circline_eq_cmat (poincare_line_cvec_cmat za wa)
	+ (poincare_line_cvec_cmat zb wb)"
	+ proof-
	+ have "\<exists>k. k \<noteq> 0 \<and>
	+ poincare_line_cvec_cmat (zb1, zb2) (wb1, wb2) = cor k *\<^sub>s\<^sub>m poincare_line_cvec_cmat (za1, za2) (wa1, wa2)"
	+ proof (cases "?den za1 za2 wa1 wa2 \<noteq> 0")
	+ case True
	+ hence "?den zb1 zb2 wb1 wb2 \<noteq> 0"
	+ using **
	+ by (simp add: field_simps)
	+
	+ let ?k = "kz * cnj kz * kw * cnj kw"
	+
	+ have "?k \<noteq> 0"
	+ using **
	+ by simp
	+
	+ have "is_real ?k"
	+ using eq_cnj_iff_real[of ?k]
	+ by auto
	+
	+ have "cor (Re ?k) = ?k"
	+ using \<open>is_real ?k\<close>
	+ using complex_of_real_Re
	+ by blast
	+
	+ have "Re ?k \<noteq> 0"
	+ using \<open>?k \<noteq> 0\<close> \<open>cor (Re ?k) = ?k\<close>
	+ by (metis of_real_0)
	+
	+ have arg1: "Re (\<i> * ?den zb1 zb2 wb1 wb2) = Re ?k * Re (\<i> * ?den za1 za2 wa1 wa2)"
	+ apply (subst **)+
	+ apply (subst Re_mult_real[symmetric, OF \<open>is_real ?k\<close>])
	+ apply (rule arg_cong[where f=Re])
	+ apply (simp add: field_simps)
	+ done
	+ have arg2: "\<i> * ?nom zb1 zb2 wb1 wb2 = ?k * \<i> * ?nom za1 za2 wa1 wa2"
	+ using **
	+ by (simp add: field_simps)
	+ have "mk_poincare_line_cmat (Re (\<i>?den zb1 zb2 wb1 wb2)) (\<i>?nom zb1 zb2 wb1 wb2) =
	+ cor (Re ?k) \<^sub>s\<^sub>m mk_poincare_line_cmat (Re (\<i>?den za1 za2 wa1 wa2)) (\<i>*?nom za1 za2 wa1 wa2)"
	+ using \<open>cor (Re ?k) = ?k\<close> \<open>is_real ?k\<close>
	+ apply (subst mk_poincare_line_cmat_scale)
	+ apply (subst arg1, subst arg2)
	+ apply (subst \<open>cor (Re ?k) = ?k\<close>)+
	+ apply simp
	+ done
	+ thus ?thesis
	+ using \<open>?den za1 za2 wa1 wa2 \<noteq> 0\<close> \<open>?den zb1 zb2 wb1 wb2 \<noteq> 0\<close>
	+ using \<open>Re ?k \<noteq> 0\<close> \<open>cor (Re ?k) = ?k\<close>
	+ by (rule_tac x="Re ?k" in exI, simp)
	+ next
	+ case False
	+ hence "?den zb1 zb2 wb1 wb2 = 0"
	+ using **
	+ by (simp add: field_simps)
	+ show ?thesis
	+ proof (cases "za1*cnj za2 \<noteq> 0")
	+ case True
	+ hence "zb1*cnj zb2 \<noteq> 0"
	+ using **
	+ by (simp add: field_simps)
	+
	+ let ?k = "kz * cnj kz"
	+
	+ have "?k \<noteq> 0" "is_real ?k"
	+ using **
	+ using eq_cnj_iff_real[of ?k]
	+ by auto
	+ thus ?thesis
	+ using \<open>za1 * cnj za2 \<noteq> 0\<close> \<open>zb1 * cnj zb2 \<noteq> 0\<close>
	+ using \<open>\<not> (?den za1 za2 wa1 wa2 \<noteq> 0)\<close> \<open>?den zb1 zb2 wb1 wb2 = 0\<close> **
	+ by (rule_tac x="Re (kz * cnj kz)" in exI, auto simp add: complex.expand)
	+ next
	+ case False
	+ hence "zb1 * cnj zb2 = 0"
	+ using **
	+ by (simp add: field_simps)
	+ show ?thesis
	+ proof (cases "wa1 * cnj wa2 \<noteq> 0")
	+ case True
	+ hence "wb1*cnj wb2 \<noteq> 0"
	+ using **
	+ by (simp add: field_simps)
	+
	+ let ?k = "kw * cnj kw"
	+
	+ have "?k \<noteq> 0" "is_real ?k"
	+ using **
	+ using eq_cnj_iff_real[of ?k]
	+ by auto
	+
	+ thus ?thesis
	+ using \<open>\<not> (za1 * cnj za2 \<noteq> 0)\<close>
	+ using \<open>wa1 * cnj wa2 \<noteq> 0\<close> \<open>wb1 * cnj wb2 \<noteq> 0\<close>
	+ using \<open>\<not> (?den za1 za2 wa1 wa2 \<noteq> 0)\<close> \<open>?den zb1 zb2 wb1 wb2 = 0\<close> **
	+ by (rule_tac x="Re (kw * cnj kw)" in exI)
	+ (auto simp add: complex.expand)
	+ next
	+ case False
	+ hence "wb1 * cnj wb2 = 0"
	+ using **
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using \<open>\<not> (za1 * cnj za2 \<noteq> 0)\<close> \<open>zb1 * cnj zb2 = 0\<close>
	+ using \<open>\<not> (wa1 * cnj wa2 \<noteq> 0)\<close> \<open>wb1 * cnj wb2 = 0\<close>
	+ using \<open>\<not> (?den za1 za2 wa1 wa2 \<noteq> 0)\<close> \<open>?den zb1 zb2 wb1 wb2 = 0\<close> **
	+ by simp
	+ qed
	+ qed
	+ qed
	+ thus ?thesis
	+ using *[symmetric]
	+ by simp
	+ qed
	+qed
	+
	+subsubsection \<open>Correctness of the construction\<close>
	+
	+text\<open>For finite points, our definition matches the classic algebraic definition for points in
	+$\mathbb{C}$ (given in ordinary, not homogenous coordinates).\<close>
	+lemma poincare_line_non_homogenous:
	+ assumes "u \<noteq> \<infinity>\<^sub>h" "v \<noteq> \<infinity>\<^sub>h" "u \<noteq> v" "u \<noteq> inversion v"
	+ shows "let u' = to_complex u; v' = to_complex v;
	+ A = \<i> * (u' * cnj v' - v' * cnj u');
	+ B = \<i> * (v' * ((cmod u')\<^sup>2 + 1) - u' * ((cmod v')\<^sup>2 + 1))
	+ in poincare_line u v = mk_circline A B (cnj B) A"
	+ using assms
	+ unfolding unit_disc_def disc_def inversion_def
	+ apply (simp add: Let_def)
	+proof (transfer, transfer, safe)
	+ fix u1 u2 v1 v2
	+ assume uv: "(u1, u2) \<noteq> vec_zero" "(v1, v2) \<noteq> vec_zero"
	+ "\<not> (u1, u2) \<approx>\<^sub>v \<infinity>\<^sub>v" "\<not> (v1, v2) \<approx>\<^sub>v \<infinity>\<^sub>v"
	+ "\<not> (u1, u2) \<approx>\<^sub>v (v1, v2)" "\<not> (u1, u2) \<approx>\<^sub>v conjugate_cvec (reciprocal_cvec (v1, v2))"
	+ let ?u = "to_complex_cvec (u1, u2)" and ?v = "to_complex_cvec (v1, v2)"
	+ let ?A = "\<i> * (?u * cnj ?v - ?v * cnj ?u)"
	+ let ?B = "\<i> * (?v * ((cor (cmod ?u))\<^sup>2 + 1) - ?u * ((cor (cmod ?v))\<^sup>2 + 1))"
	+ let ?C = "- (\<i> * (cnj ?v * ((cor (cmod ?u))\<^sup>2 + 1) - cnj ?u * ((cor (cmod ?v))\<^sup>2 + 1)))"
	+ let ?D = ?A
	+ let ?H = "(?A, ?B, ?C, ?D)"
	+
	+
	+ let ?den = "u1 * cnj u2 * cnj v1 * v2 - v1 * cnj v2 * cnj u1 * u2"
	+
	+ have "u2 \<noteq> 0" "v2 \<noteq> 0"
	+ using uv
	+ using inf_cvec_z2_zero_iff
	+ by blast+
	+
	+ have "\<not> (u1, u2) \<approx>\<^sub>v (cnj v2, cnj v1)"
	+ using uv(6)
	+ by (simp add: vec_cnj_def)
	+ moreover
	+ have "(cnj v2, cnj v1) \<noteq> vec_zero"
	+ using uv(2)
	+ by auto
	+ ultimately
	+ have : "u1 cnj v1 \<noteq> u2 * cnj v2" "u1 * v2 \<noteq> u2 * v1"
	+ using uv(5) uv(1) uv(2) `u2 \<noteq> 0` `v2 \<noteq> 0`
	+ using complex_cvec_eq_mix
	+ by blast+
	+
	+ show "circline_eq_cmat (poincare_line_cvec_cmat (u1, u2) (v1, v2))
	+ (mk_circline_cmat ?A ?B ?C ?D)"
	+ proof (cases "?den \<noteq> 0")
	+ case True
	+
	+ let ?nom = "v1 * cnj v2 * (u1 * cnj u1 + u2 * cnj u2) - u1 * cnj u2 * (v1 * cnj v1 + v2 * cnj v2)"
	+ let ?H' = "mk_poincare_line_cmat (Re (\<i> * ?den)) (\<i> * ?nom)"
	+
	+ have "circline_eq_cmat ?H ?H'"
	+ proof-
	+ let ?k = "(u2 * cnj v2) * (v2 * cnj u2)"
	+ have "is_real ?k"
	+ using eq_cnj_iff_real
	+ by fastforce
	+ hence "cor (Re ?k) = ?k"
	+ using complex_of_real_Re
	+ by blast
	+
	+ have "Re (\<i> * ?den) = Re ?k * ?A"
	+ proof-
	+ have "?A = cnj ?A"
	+ by (simp add: field_simps)
	+ hence "is_real ?A"
	+ using eq_cnj_iff_real
	+ by fastforce
	+ moreover
	+ have "\<i> * ?den = cnj (\<i> * ?den)"
	+ by (simp add: field_simps)
	+ hence "is_real (\<i> * ?den)"
	+ using eq_cnj_iff_real
	+ by fastforce
	+ hence "cor (Re (\<i> * ?den)) = \<i> * ?den"
	+ using complex_of_real_Re
	+ by blast
	+ ultimately
	+ show ?thesis
	+ using `cor (Re ?k) = ?k`
	+ by (simp add: field_simps)
	+ qed
	+
	+ moreover
	+ have "\<i> * ?nom = Re ?k * ?B"
	+ using `cor (Re ?k) = ?k` `u2 \<noteq> 0` `v2 \<noteq> 0` complex_mult_cnj_cmod[symmetric]
	+ by (auto simp add: field_simps)
	+
	+ moreover
	+ have "?k \<noteq> 0"
	+ using `u2 \<noteq> 0` `v2 \<noteq> 0`
	+ by simp
	+ hence "Re ?k \<noteq> 0"
	+ using `is_real ?k`
	+ by (metis \<open>cor (Re ?k) = ?k\<close> of_real_0)
	+
	+ ultimately
	+ show ?thesis
	+ by simp (rule_tac x="Re ?k" in exI, simp add: mult.commute)
	+ qed
	+
	+ moreover
	+
	+ have "poincare_line_cvec_cmat (u1, u2) (v1, v2) = ?H'"
	+ using `?den \<noteq> 0`
	+ unfolding poincare_line_cvec_cmat_def
	+ by (simp add: Let_def)
	+
	+ moreover
	+
	+ hence "hermitean ?H' \<and> ?H' \<noteq> mat_zero"
	+ by (metis mk_poincare_line_cmat_hermitean poincare_line_cvec_cmat_nonzero uv(1) uv(2))
	+
	+ hence "hermitean ?H \<and> ?H \<noteq> mat_zero"
	+ using `circline_eq_cmat ?H ?H'`
	+ using circline_eq_cmat_hermitean_nonzero[of ?H' ?H] symp_circline_eq_cmat
	+ unfolding symp_def
	+ by metis
	+
	+ hence "mk_circline_cmat ?A ?B ?C ?D = ?H"
	+ by simp
	+
	+ ultimately
	+
	+ have "circline_eq_cmat (mk_circline_cmat ?A ?B ?C ?D)
	+ (poincare_line_cvec_cmat (u1, u2) (v1, v2))"
	+ by simp
	+ thus ?thesis
	+ using symp_circline_eq_cmat
	+ unfolding symp_def
	+ by blast
	+ next
	+ case False
	+
	+ let ?d = "v1 * (u1 * cnj u1 / (u2 * cnj u2) + 1) / v2 - u1 * (v1 * cnj v1 / (v2 * cnj v2) + 1) / u2"
	+ let ?cd = "cnj v1 * (u1 * cnj u1 / (u2 * cnj u2) + 1) / cnj v2 - cnj u1 * (v1 * cnj v1 / (v2 * cnj v2) + 1) / cnj u2"
	+
	+ have "cnj ?d = ?cd"
	+ by (simp add: mult.commute)
	+
	+ let ?d1 = "(v1 / v2) * (cnj u1 / cnj u2) - 1"
	+ let ?d2 = "u1 / u2 - v1 / v2"
	+
	+ have *: "?d = ?d1 ?d2"
	+ using `\<not> ?den \<noteq> 0` `u2 \<noteq> 0` `v2 \<noteq> 0`
	+ by(simp add: field_simps)
	+
	+ hence "?d \<noteq> 0"
	+ using `\<not> ?den \<noteq> 0` `u2 \<noteq> 0` `v2 \<noteq> 0` *
	+ by auto (simp add: field_simps)+
	+
	+ have "is_real ?d1"
	+ proof-
	+ have "cnj ?d1 = ?d1"
	+ using `\<not> ?den \<noteq> 0` `u2 \<noteq> 0` `v2 \<noteq> 0` *
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ using eq_cnj_iff_real
	+ by blast
	+ qed
	+
	+ show ?thesis
	+ proof (cases "u1 * cnj u2 \<noteq> 0")
	+ case True
	+ let ?nom = "u1 * cnj u2"
	+ let ?H' = "mk_poincare_line_cmat 0 (\<i> * ?nom)"
	+
	+ have "circline_eq_cmat ?H ?H'"
	+ proof-
	+
	+ let ?k = "(u1 * cnj u2) / ?d"
	+
	+ have "is_real ?k"
	+ proof-
	+ have "is_real ((u1 * cnj u2) / ?d2)"
	+ proof-
	+ let ?rhs = "(u2 * cnj u2) / (1 - (v1u2)/(u1v2))"
	+
	+ have 1: "(u1 * cnj u2) / ?d2 = ?rhs"
	+ using `\<not> ?den \<noteq> 0` `u2 \<noteq> 0` `v2 \<noteq> 0` * `u1 * cnj u2 \<noteq> 0`
	+ by (simp add: field_simps)
	+ moreover
	+ have "cnj ?rhs = ?rhs"
	+ proof-
	+ have "cnj (1 - v1 * u2 / (u1 * v2)) = 1 - v1 * u2 / (u1 * v2)"
	+ using `\<not> ?den \<noteq> 0` `u2 \<noteq> 0` `v2 \<noteq> 0` * `u1 * cnj u2 \<noteq> 0`
	+ by (simp add: field_simps)
	+ moreover
	+ have "cnj (u2 * cnj u2) = u2 * cnj u2"
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by simp
	+ qed
	+
	+ ultimately
	+
	+ show ?thesis
	+ using eq_cnj_iff_real
	+ by fastforce
	+ qed
	+
	+ thus ?thesis
	+ using ** `is_real ?d1`
	+ by (metis complex_cnj_divide divide_divide_eq_left' eq_cnj_iff_real)
	+ qed
	+
	+ have "?k \<noteq> 0"
	+ using `?d \<noteq> 0` `u1 * cnj u2 \<noteq> 0`
	+ by simp
	+
	+ have "cnj ?k = ?k"
	+ using `is_real ?k`
	+ using eq_cnj_iff_real by blast
	+
	+ have "Re ?k \<noteq> 0"
	+ using `?k \<noteq> 0` `is_real ?k`
	+ by (metis complex.expand zero_complex.simps(1) zero_complex.simps(2))
	+
	+ have "u1 * cnj u2 = ?k * ?d"
	+ using `?d \<noteq> 0`
	+ by simp
	+
	+ moreover
	+
	+ hence "cnj u1 * u2 = cnj ?k * cnj ?d"
	+ by (metis complex_cnj_cnj complex_cnj_mult)
	+ hence "cnj u1 * u2 = ?k * ?cd"
	+ using `cnj ?k = ?k` `cnj ?d = ?cd`
	+ by metis
	+
	+ ultimately
	+
	+ show ?thesis
	+ using `~ ?den \<noteq> 0` `u1 * cnj u2 \<noteq> 0` `u2 \<noteq> 0` `v2 \<noteq> 0` `Re ?k \<noteq> 0` `is_real ?k` `?d \<noteq> 0`
	+ using complex_mult_cnj_cmod[symmetric, of u1]
	+ using complex_mult_cnj_cmod[symmetric, of v1]
	+ using complex_mult_cnj_cmod[symmetric, of u2]
	+ using complex_mult_cnj_cmod[symmetric, of v2]
	+ apply (auto simp add: power_divide)
	+ apply (rule_tac x="Re ?k" in exI)
	+ apply simp
	+ apply (simp add: field_simps)
	+ done
	+ qed
	+
	+ moreover
	+
	+ have "poincare_line_cvec_cmat (u1, u2) (v1, v2) = ?H'"
	+ using `\<not> ?den \<noteq> 0` `u1 * cnj u2 \<noteq> 0`
	+ unfolding poincare_line_cvec_cmat_def
	+ by (simp add: Let_def)
	+
	+ moreover
	+
	+ hence "hermitean ?H' \<and> ?H' \<noteq> mat_zero"
	+ by (metis mk_poincare_line_cmat_hermitean poincare_line_cvec_cmat_nonzero uv(1) uv(2))
	+
	+ hence "hermitean ?H \<and> ?H \<noteq> mat_zero"
	+ using `circline_eq_cmat ?H ?H'`
	+ using circline_eq_cmat_hermitean_nonzero[of ?H' ?H] symp_circline_eq_cmat
	+ unfolding symp_def
	+ by metis
	+
	+ hence "mk_circline_cmat ?A ?B ?C ?D = ?H"
	+ by simp
	+
	+ ultimately
	+
	+ have "circline_eq_cmat (mk_circline_cmat ?A ?B ?C ?D)
	+ (poincare_line_cvec_cmat (u1, u2) (v1, v2))"
	+ by simp
	+ thus ?thesis
	+ using symp_circline_eq_cmat
	+ unfolding symp_def
	+ by blast
	+ next
	+ case False
	+ show ?thesis
	+ proof (cases "v1 * cnj v2 \<noteq> 0")
	+ case True
	+ let ?nom = "v1 * cnj v2"
	+ let ?H' = "mk_poincare_line_cmat 0 (\<i> * ?nom)"
	+
	+ have "circline_eq_cmat ?H ?H'"
	+ proof-
	+ let ?k = "(v1 * cnj v2) / ?d"
	+
	+ have "is_real ?k"
	+ proof-
	+ have "is_real ((v1 * cnj v2) / ?d2)"
	+ proof-
	+ let ?rhs = "(v2 * cnj v2) / ((u1v2)/(u2v1) - 1)"
	+
	+ have 1: "(v1 * cnj v2) / ?d2 = ?rhs"
	+ using `\<not> ?den \<noteq> 0` `u2 \<noteq> 0` `v2 \<noteq> 0` * `v1 * cnj v2 \<noteq> 0`
	+ by (simp add: field_simps)
	+ moreover
	+ have "cnj ?rhs = ?rhs"
	+ proof-
	+ have "cnj (u1 * v2 / (u2 * v1) - 1) = u1 * v2 / (u2 * v1) - 1"
	+ using `\<not> ?den \<noteq> 0` `u2 \<noteq> 0` `v2 \<noteq> 0` * `v1 * cnj v2 \<noteq> 0`
	+ by (simp add: field_simps)
	+ moreover
	+ have "cnj (v2 * cnj v2) = v2 * cnj v2"
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by simp
	+ qed
	+
	+ ultimately
	+
	+ show ?thesis
	+ using eq_cnj_iff_real
	+ by fastforce
	+ qed
	+
	+ thus ?thesis
	+ using ** `is_real ?d1`
	+ by (metis complex_cnj_divide divide_divide_eq_left' eq_cnj_iff_real)
	+ qed
	+
	+ have "?k \<noteq> 0"
	+ using `?d \<noteq> 0` `v1 * cnj v2 \<noteq> 0`
	+ by simp
	+
	+ have "cnj ?k = ?k"
	+ using `is_real ?k`
	+ using eq_cnj_iff_real by blast
	+
	+ have "Re ?k \<noteq> 0"
	+ using `?k \<noteq> 0` `is_real ?k`
	+ by (metis complex.expand zero_complex.simps(1) zero_complex.simps(2))
	+
	+ have "v1 * cnj v2 = ?k * ?d"
	+ using `?d \<noteq> 0`
	+ by simp
	+
	+ moreover
	+
	+ hence "cnj v1 * v2 = cnj ?k * cnj ?d"
	+ by (metis complex_cnj_cnj complex_cnj_mult)
	+ hence "cnj v1 * v2 = ?k * ?cd"
	+ using `cnj ?k = ?k` `cnj ?d = ?cd`
	+ by metis
	+
	+ ultimately
	+
	+ show ?thesis
	+ using `~ ?den \<noteq> 0` `v1 * cnj v2 \<noteq> 0` `u2 \<noteq> 0` `v2 \<noteq> 0` `Re ?k \<noteq> 0` `is_real ?k` `?d \<noteq> 0`
	+ using complex_mult_cnj_cmod[symmetric, of u1]
	+ using complex_mult_cnj_cmod[symmetric, of v1]
	+ using complex_mult_cnj_cmod[symmetric, of u2]
	+ using complex_mult_cnj_cmod[symmetric, of v2]
	+ apply (auto simp add: power_divide)
	+ apply (rule_tac x="Re ?k" in exI)
	+ apply simp
	+ apply (simp add: field_simps)
	+ done
	+ qed
	+
	+ moreover
	+
	+ have "poincare_line_cvec_cmat (u1, u2) (v1, v2) = ?H'"
	+ using `\<not> ?den \<noteq> 0` `\<not> u1 * cnj u2 \<noteq> 0` `v1 * cnj v2 \<noteq> 0`
	+ unfolding poincare_line_cvec_cmat_def
	+ by (simp add: Let_def)
	+
	+ moreover
	+
	+ hence "hermitean ?H' \<and> ?H' \<noteq> mat_zero"
	+ by (metis mk_poincare_line_cmat_hermitean poincare_line_cvec_cmat_nonzero uv(1) uv(2))
	+
	+ hence "hermitean ?H \<and> ?H \<noteq> mat_zero"
	+ using `circline_eq_cmat ?H ?H'`
	+ using circline_eq_cmat_hermitean_nonzero[of ?H' ?H] symp_circline_eq_cmat
	+ unfolding symp_def
	+ by metis
	+
	+ hence "mk_circline_cmat ?A ?B ?C ?D = ?H"
	+ by simp
	+
	+ ultimately
	+
	+ have "circline_eq_cmat (mk_circline_cmat ?A ?B ?C ?D)
	+ (poincare_line_cvec_cmat (u1, u2) (v1, v2))"
	+ by simp
	+ thus ?thesis
	+ using symp_circline_eq_cmat
	+ unfolding symp_def
	+ by blast
	+ next
	+ case False
	+ hence False
	+ using `\<not> ?den \<noteq> 0` `\<not> u1 * cnj u2 \<noteq> 0` uv
	+ by (simp add: \<open>u2 \<noteq> 0\<close> \<open>v2 \<noteq> 0\<close>)
	+ thus ?thesis
	+ by simp
	+ qed
	+ qed
	+ qed
	+qed
	+
	+text\<open>Our construction (in homogenous coordinates) always yields an h-line that contain two starting
	+points (this also holds for all degenerate cases except when points are the same).\<close>
	+lemma poincare_line [simp]:
	+ assumes "z \<noteq> w"
	+ shows "on_circline (poincare_line z w) z"
	+ "on_circline (poincare_line z w) w"
	+proof-
	+ have "on_circline (poincare_line z w) z \<and> on_circline (poincare_line z w) w"
	+ using assms
	+ proof (transfer, transfer)
	+ fix z w
	+ assume vz: "z \<noteq> vec_zero" "w \<noteq> vec_zero"
	+ obtain z1 z2 w1 w2 where
	+ zw: "(z1, z2) = z" "(w1, w2) = w"
	+ by (cases z, cases w, auto)
	+
	+ let ?den = "z1cnj z2cnj w1w2 - w1cnj w2cnj z1z2"
	+ have : "cor (Re (\<i> ?den)) = \<i> * ?den"
	+ proof-
	+ have "cnj ?den = -?den"
	+ by auto
	+ hence "is_imag ?den"
	+ using eq_minus_cnj_iff_imag[of ?den]
	+ by simp
	+ thus ?thesis
	+ using complex_of_real_Re[of "\<i> * ?den"]
	+ by simp
	+ qed
	+ show "on_circline_cmat_cvec (poincare_line_cvec_cmat z w) z \<and>
	+ on_circline_cmat_cvec (poincare_line_cvec_cmat z w) w"
	+ unfolding poincare_line_cvec_cmat_def mk_poincare_line_cmat_def
	+ apply (subst zw[symmetric])+
	+ unfolding Let_def prod.case
	+ apply (subst *)+
	+ by (auto simp add: vec_cnj_def field_simps)
	+ qed
	+ thus "on_circline (poincare_line z w) z" "on_circline (poincare_line z w) w"
	+ by auto
	+qed
	+
	+lemma poincare_line_circline_set [simp]:
	+ assumes "z \<noteq> w"
	+ shows "z \<in> circline_set (poincare_line z w)"
	+ "w \<in> circline_set (poincare_line z w)"
	+ using assms
	+ by (auto simp add: circline_set_def)
	+
	+text\<open>When the points are different, the constructed line matrix always has a negative determinant\<close>
	+lemma poincare_line_type:
	+ assumes "z \<noteq> w"
	+ shows "circline_type (poincare_line z w) = -1"
	+proof-
	+ have "\<exists> a b. a \<noteq> b \<and> {a, b} \<subseteq> circline_set (poincare_line z w)"
	+ using poincare_line[of z w] assms
	+ unfolding circline_set_def
	+ by (rule_tac x=z in exI, rule_tac x=w in exI, simp)
	+ thus ?thesis
	+ using circline_type[of "poincare_line z w"]
	+ using circline_type_pos_card_eq0[of "poincare_line z w"]
	+ using circline_type_zero_card_eq1[of "poincare_line z w"]
	+ by auto
	+qed
	+
	+text\<open>The constructed line is an h-line in the Poincar\'e model (in all cases when the two points are
	+different)\<close>
	+lemma is_poincare_line_poincare_line [simp]:
	+ assumes "z \<noteq> w"
	+ shows "is_poincare_line (poincare_line z w)"
	+ using poincare_line_type[of z w, OF assms]
	+proof (transfer, transfer)
	+ fix z w
	+ assume vz: "z \<noteq> vec_zero" "w \<noteq> vec_zero"
	+ obtain A B C D where *: "poincare_line_cvec_cmat z w = (A, B, C, D)"
	+ by (cases "poincare_line_cvec_cmat z w") auto
	+ assume "circline_type_cmat (poincare_line_cvec_cmat z w) = - 1"
	+ thus "is_poincare_line_cmat (poincare_line_cvec_cmat z w)"
	+ using vz *
	+ using poincare_line_cvec_cmat_hermitean[of z w]
	+ using poincare_line_cvec_cmat_nonzero[of z w]
	+ using poincare_line_cvec_cmat_AeqD[of z w A B C D]
	+ using hermitean_elems[of A B C D]
	+ using cmod_power2[of D] cmod_power2[of C]
	+ unfolding is_poincare_line_cmat_def
	+ by (simp del: poincare_line_cvec_cmat_def add: sgn_1_neg power2_eq_square)
	+qed
	+
	+text \<open>When the points are different, the constructed h-line between two points also contains their inverses\<close>
	+lemma poincare_line_inversion:
	+ assumes "z \<noteq> w"
	+ shows "on_circline (poincare_line z w) (inversion z)"
	+ "on_circline (poincare_line z w) (inversion w)"
	+ using assms
	+ using is_poincare_line_poincare_line[OF \<open>z \<noteq> w\<close>]
	+ using is_poincare_line_inverse_point
	+ unfolding circline_set_def
	+ by auto
	+
	+text \<open>When the points are different, the onstructed h-line between two points contains the inverse of its every point\<close>
	+lemma poincare_line_inversion_full:
	+ assumes "u \<noteq> v"
	+ assumes "on_circline (poincare_line u v) x"
	+ shows "on_circline (poincare_line u v) (inversion x)"
	+ using is_poincare_line_inverse_point[of "poincare_line u v" x]
	+ using is_poincare_line_poincare_line[OF `u \<noteq> v`] assms
	+ unfolding circline_set_def
	+ by simp
	+
	+subsubsection \<open>Existence of h-lines\<close>
	+
	+text\<open>There is an h-line trough every point in the Poincar\'e model\<close>
	+lemma ex_poincare_line_one_point:
	+ shows "\<exists> l. is_poincare_line l \<and> z \<in> circline_set l"
	+proof (cases "z = 0\<^sub>h")
	+ case True
	+ thus ?thesis
	+ by (rule_tac x="x_axis" in exI) simp
	+next
	+ case False
	+ thus ?thesis
	+ by (rule_tac x="poincare_line 0\<^sub>h z" in exI) auto
	+qed
	+
	+lemma poincare_collinear_singleton [simp]:
	+ assumes "u \<in> unit_disc"
	+ shows "poincare_collinear {u}"
	+ using assms
	+ using ex_poincare_line_one_point[of u]
	+ by (auto simp add: poincare_collinear_def)
	+
	+text\<open>There is an h-line trough every two points in the Poincar\'e model\<close>
	+lemma ex_poincare_line_two_points:
	+ assumes "z \<noteq> w"
	+ shows "\<exists> l. is_poincare_line l \<and> z \<in> circline_set l \<and> w \<in> circline_set l"
	+ using assms
	+ by (rule_tac x="poincare_line z w" in exI, simp)
	+
	+lemma poincare_collinear_doubleton [simp]:
	+ assumes "u \<in> unit_disc" "v \<in> unit_disc"
	+ shows "poincare_collinear {u, v}"
	+ using assms
	+ using ex_poincare_line_one_point[of u]
	+ using ex_poincare_line_two_points[of u v]
	+ by (cases "u = v") (simp_all add: poincare_collinear_def)
	+
	+
	+subsubsection \<open>Uniqueness of h-lines\<close>
	+
	+text \<open>The only h-line between two points is the one obtained by the line-construction.\<close>
	+text \<open>First we show this only for two different points inside the disc.\<close>
	+lemma unique_poincare_line:
	+ assumes in_disc: "u \<noteq> v" "u \<in> unit_disc" "v \<in> unit_disc"
	+ assumes on_l: "u \<in> circline_set l" "v \<in> circline_set l" "is_poincare_line l"
	+ shows "l = poincare_line u v"
	+ using assms
	+ using unique_is_poincare_line[of u v l "poincare_line u v"]
	+ unfolding circline_set_def
	+ by auto
	+
	+text\<open>The assumption that the points are inside the disc can be relaxed.\<close>
	+lemma unique_poincare_line_general:
	+ assumes in_disc: "u \<noteq> v" "u \<noteq> inversion v"
	+ assumes on_l: "u \<in> circline_set l" "v \<in> circline_set l" "is_poincare_line l"
	+ shows "l = poincare_line u v"
	+ using assms
	+ using unique_is_poincare_line_general[of u v l "poincare_line u v"]
	+ unfolding circline_set_def
	+ by auto
	+
	+text\<open>The explicit line construction enables us to prove that there exists a unique h-line through any
	+given two h-points (uniqueness part was already shown earlier).\<close>
	+text \<open>First we show this only for two different points inside the disc.\<close>
	+lemma ex1_poincare_line:
	+ assumes "u \<noteq> v" "u \<in> unit_disc" "v \<in> unit_disc"
	+ shows "\<exists>! l. is_poincare_line l \<and> u \<in> circline_set l \<and> v \<in> circline_set l"
	+proof (rule ex1I)
	+ let ?l = "poincare_line u v"
	+ show "is_poincare_line ?l \<and> u \<in> circline_set ?l \<and> v \<in> circline_set ?l"
	+ using assms
	+ unfolding circline_set_def
	+ by auto
	+next
	+ fix l
	+ assume "is_poincare_line l \<and> u \<in> circline_set l \<and> v \<in> circline_set l"
	+ thus "l = poincare_line u v"
	+ using unique_poincare_line assms
	+ by auto
	+qed
	+
	+text \<open>The assumption that the points are in the disc can be relaxed.\<close>
	+lemma ex1_poincare_line_general:
	+ assumes "u \<noteq> v" "u \<noteq> inversion v"
	+ shows "\<exists>! l. is_poincare_line l \<and> u \<in> circline_set l \<and> v \<in> circline_set l"
	+proof (rule ex1I)
	+ let ?l = "poincare_line u v"
	+ show "is_poincare_line ?l \<and> u \<in> circline_set ?l \<and> v \<in> circline_set ?l"
	+ using assms
	+ unfolding circline_set_def
	+ by auto
	+next
	+ fix l
	+ assume "is_poincare_line l \<and> u \<in> circline_set l \<and> v \<in> circline_set l"
	+ thus "l = poincare_line u v"
	+ using unique_poincare_line_general assms
	+ by auto
	+qed
	+
	+subsubsection \<open>Some consequences of line uniqueness\<close>
	+
	+text\<open>H-line $uv$ is the same as the h-line $vu$.\<close>
	+lemma poincare_line_sym:
	+ assumes "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ shows "poincare_line u v = poincare_line v u"
	+ using assms
	+ using unique_poincare_line[of u v "poincare_line v u"]
	+ by simp
	+
	+lemma poincare_line_sym_general:
	+ assumes "u \<noteq> v" "u \<noteq> inversion v"
	+ shows "poincare_line u v = poincare_line v u"
	+ using assms
	+ using unique_poincare_line_general[of u v "poincare_line v u"]
	+ by simp
	+
	+text\<open>Each h-line is the h-line constructed out of its two arbitrary different points.\<close>
	+lemma ex_poincare_line_points:
	+ assumes "is_poincare_line H"
	+ shows "\<exists> u v. u \<in> unit_disc \<and> v \<in> unit_disc \<and> u \<noteq> v \<and> H = poincare_line u v"
	+ using assms
	+ using ex_is_poincare_line_points
	+ using unique_poincare_line[where l=H]
	+ by fastforce
	+
	+text\<open>If an h-line contains two different points on x-axis/y-axis then it is the x-axis/y-axis.\<close>
	+lemma poincare_line_0_real_is_x_axis:
	+ assumes "x \<in> circline_set x_axis" "x \<noteq> 0\<^sub>h" "x \<noteq> \<infinity>\<^sub>h"
	+ shows "poincare_line 0\<^sub>h x = x_axis"
	+ using assms
	+ using is_poincare_line_0_real_is_x_axis[of "poincare_line 0\<^sub>h x" x]
	+ by auto
	+
	+lemma poincare_line_0_imag_is_y_axis:
	+ assumes "y \<in> circline_set y_axis" "y \<noteq> 0\<^sub>h" "y \<noteq> \<infinity>\<^sub>h"
	+ shows "poincare_line 0\<^sub>h y = y_axis"
	+ using assms
	+ using is_poincare_line_0_imag_is_y_axis[of "poincare_line 0\<^sub>h y" y]
	+ by auto
	+
	+lemma poincare_line_x_axis:
	+ assumes "x \<in> unit_disc" "y \<in> unit_disc" "x \<in> circline_set x_axis" "y \<in> circline_set x_axis" "x \<noteq> y"
	+ shows "poincare_line x y = x_axis"
	+ using assms
	+ using unique_poincare_line
	+ by auto
	+
	+lemma poincare_line_minus_one_one [simp]:
	+ shows "poincare_line (of_complex (-1)) (of_complex 1) = x_axis"
	+proof-
	+ have "0\<^sub>h \<in> circline_set (poincare_line (of_complex (-1)) (of_complex 1))"
	+ unfolding circline_set_def
	+ by simp (transfer, transfer, simp add: vec_cnj_def)
	+ hence "poincare_line 0\<^sub>h (of_complex 1) = poincare_line (of_complex (-1)) (of_complex 1)"
	+ by (metis is_poincare_line_poincare_line is_poincare_line_trough_zero_trough_infty not_zero_on_unit_circle of_complex_inj of_complex_one one_neq_neg_one one_on_unit_circle poincare_line_0_real_is_x_axis poincare_line_circline_set(2) reciprocal_involution reciprocal_one reciprocal_zero unique_circline_01inf')
	+ thus ?thesis
	+ using poincare_line_0_real_is_x_axis[of "of_complex 1"]
	+ by auto
	+qed
	+
	+subsubsection \<open>Transformations of constructed lines\<close>
	+
	+text\<open>Unit dics preserving Möbius transformations preserve the h-line construction\<close>
	+lemma unit_disc_fix_preserve_poincare_line [simp]:
	+ assumes "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ shows "poincare_line (moebius_pt M u) (moebius_pt M v) = moebius_circline M (poincare_line u v)"
	+proof (rule unique_poincare_line[symmetric])
	+ show "moebius_pt M u \<noteq> moebius_pt M v"
	+ using \<open>u \<noteq> v\<close>
	+ by auto
	+next
	+ show "moebius_pt M u \<in> circline_set (moebius_circline M (poincare_line u v))"
	+ "moebius_pt M v \<in> circline_set (moebius_circline M (poincare_line u v))"
	+ unfolding circline_set_def
	+ using moebius_circline[of M "poincare_line u v"] \<open>u \<noteq> v\<close>
	+ by auto
	+next
	+ from assms(1) have "unit_circle_fix M"
	+ by simp
	+ thus "is_poincare_line (moebius_circline M (poincare_line u v))"
	+ using unit_circle_fix_preserve_is_poincare_line assms
	+ by auto
	+next
	+ show "moebius_pt M u \<in> unit_disc" "moebius_pt M v \<in> unit_disc"
	+ using assms(2-3) unit_disc_fix_iff[OF assms(1)]
	+ by auto
	+qed
	+
	+text\<open>Conjugate preserve the h-line construction\<close>
	+lemma conjugate_preserve_poincare_line [simp]:
	+ assumes "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ shows "poincare_line (conjugate u) (conjugate v) = conjugate_circline (poincare_line u v)"
	+proof-
	+ have "conjugate u \<noteq> conjugate v"
	+ using \<open>u \<noteq> v\<close>
	+ by (auto simp add: conjugate_inj)
	+ moreover
	+ have "conjugate u \<in> unit_disc" "conjugate v \<in> unit_disc"
	+ using assms
	+ by auto
	+ moreover
	+ have "conjugate u \<in> circline_set (conjugate_circline (poincare_line u v))"
	+ "conjugate v \<in> circline_set (conjugate_circline (poincare_line u v))"
	+ using \<open>u \<noteq> v\<close>
	+ by simp_all
	+ moreover
	+ have "is_poincare_line (conjugate_circline (poincare_line u v))"
	+ using is_poincare_line_poincare_line[OF \<open>u \<noteq> v\<close>]
	+ by simp
	+ ultimately
	+ show ?thesis
	+ using unique_poincare_line[of "conjugate u" "conjugate v" "conjugate_circline (poincare_line u v)"]
	+ by simp
	+qed
	+
	+subsubsection \<open>Collinear points and h-lines\<close>
	+
	+lemma poincare_collinear3_poincare_line_general:
	+ assumes "poincare_collinear {a, a1, a2}" "a1 \<noteq> a2" "a1 \<noteq> inversion a2"
	+ shows "a \<in> circline_set (poincare_line a1 a2)"
	+ using assms
	+ using poincare_collinear_def unique_poincare_line_general
	+ by auto
	+
	+lemma poincare_line_poincare_collinear3_general:
	+ assumes "a \<in> circline_set (poincare_line a1 a2)" "a1 \<noteq> a2"
	+ shows "poincare_collinear {a, a1, a2}"
	+ using assms
	+ unfolding poincare_collinear_def
	+ by (rule_tac x="poincare_line a1 a2" in exI, simp)
	+
	+
	+lemma poincare_collinear3_poincare_lines_equal_general:
	+ assumes "poincare_collinear {a, a1, a2}" "a \<noteq> a1" "a \<noteq> a2" "a \<noteq> inversion a1" "a \<noteq> inversion a2"
	+ shows "poincare_line a a1 = poincare_line a a2"
	+ using assms
	+ using unique_poincare_line_general[of a a2 "poincare_line a a1"]
	+ by (simp add: insert_commute poincare_collinear3_poincare_line_general)
	+
	+subsubsection \<open>Points collinear with @{term "0\<^sub>h"}\<close>
	+
	+lemma poincare_collinear_zero_iff:
	+ assumes "of_complex y' \<in> unit_disc" and "of_complex z' \<in> unit_disc" and
	+ "y' \<noteq> z'" and "y' \<noteq> 0" and "z' \<noteq> 0"
	+ shows "poincare_collinear {0\<^sub>h, of_complex y', of_complex z'} \<longleftrightarrow>
	+ y'cnj z' = cnj y'z'" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof-
	+ have "of_complex y' \<noteq> of_complex z'"
	+ using assms
	+ using of_complex_inj
	+ by blast
	+ show ?thesis
	+ proof
	+ assume ?lhs
	+ hence "0\<^sub>h \<in> circline_set (poincare_line (of_complex y') (of_complex z'))"
	+ using unique_poincare_line[of "of_complex y'" "of_complex z'"]
	+ using assms \<open>of_complex y' \<noteq> of_complex z'\<close>
	+ unfolding poincare_collinear_def
	+ by auto
	+ moreover
	+ let ?mix = "y' * cnj z' - cnj y' * z'"
	+ have "is_real (\<i> * ?mix)"
	+ using eq_cnj_iff_real[of ?mix]
	+ by auto
	+ hence "y' * cnj z' = cnj y' * z' \<longleftrightarrow> Re (\<i> * ?mix) = 0"
	+ using complex.expand[of "\<i> * ?mix" 0]
	+ by (metis complex_i_not_zero eq_iff_diff_eq_0 mult_eq_0_iff zero_complex.simps(1) zero_complex.simps(2))
	+ ultimately
	+ show ?rhs
	+ using \<open>y' \<noteq> z'\<close> \<open>y' \<noteq> 0\<close> \<open>z' \<noteq> 0\<close>
	+ unfolding circline_set_def
	+ by simp (transfer, transfer, auto simp add: vec_cnj_def split: if_split_asm, metis Re_complex_of_real Re_mult_real Im_complex_of_real)
	+ next
	+ assume ?rhs
	+ thus ?lhs
	+ using assms \<open>of_complex y' \<noteq> of_complex z'\<close>
	+ unfolding poincare_collinear_def
	+ unfolding circline_set_def
	+ apply (rule_tac x="poincare_line (of_complex y') (of_complex z')" in exI)
	+ apply auto
	+ apply (transfer, transfer, simp add: vec_cnj_def)
	+ done
	+ qed
	+qed
	+
	+lemma poincare_collinear_zero_polar_form:
	+ assumes "poincare_collinear {0\<^sub>h, of_complex x, of_complex y}" and
	+ "x \<noteq> 0" and "y \<noteq> 0" and "of_complex x \<in> unit_disc" and "of_complex y \<in> unit_disc"
	+ shows "\<exists> \<phi> rx ry. x = cor rx * cis \<phi> \<and> y = cor ry * cis \<phi> \<and> rx \<noteq> 0 \<and> ry \<noteq> 0"
	+proof-
	+ from \<open>x \<noteq> 0\<close> \<open>y \<noteq> 0\<close> obtain \<phi> \<phi>' rx ry where
	+ polar: "x = cor rx * cis \<phi>" "y = cor ry * cis \<phi>'" and "\<phi> = arg x" "\<phi>' = arg y"
	+ by (metis cmod_cis)
	+ hence "rx \<noteq> 0" "ry \<noteq> 0"
	+ using \<open>x \<noteq> 0\<close> \<open>y \<noteq> 0\<close>
	+ by auto
	+ have "of_complex y \<in> circline_set (poincare_line 0\<^sub>h (of_complex x))"
	+ using assms
	+ using unique_poincare_line[of "0\<^sub>h" "of_complex x"]
	+ unfolding poincare_collinear_def
	+ unfolding circline_set_def
	+ using of_complex_zero_iff
	+ by fastforce
	+ hence "cnj x * y = x * cnj y"
	+ using \<open>x \<noteq> 0\<close> \<open>y \<noteq> 0\<close>
	+ unfolding circline_set_def
	+ by simp (transfer, transfer, simp add: vec_cnj_def field_simps)
	+ hence "cis(\<phi>' - \<phi>) = cis(\<phi> - \<phi>')"
	+ using polar \<open>rx \<noteq> 0\<close> \<open>ry \<noteq> 0\<close>
	+ by (simp add: cis_mult)
	+ hence "sin (\<phi>' - \<phi>) = 0"
	+ using cis_diff_cis_opposite[of "\<phi>' - \<phi>"]
	+ by simp
	+ then obtain k :: int where "\<phi>' - \<phi> = k * pi"
	+ using sin_zero_iff_int2[of "\<phi>' - \<phi>"]
	+ by auto
	+ hence : "\<phi>' = \<phi> + k pi"
	+ by simp
	+ show ?thesis
	+ proof (cases "even k")
	+ case True
	+ then obtain k' where "k = 2*k'"
	+ using evenE by blast
	+ hence "cis \<phi> = cis \<phi>'"
	+ using * cos_periodic_int sin_periodic_int
	+ by (simp add: cis.ctr field_simps)
	+ thus ?thesis
	+ using polar \<open>rx \<noteq> 0\<close> \<open>ry \<noteq> 0\<close>
	+ by (rule_tac x=\<phi> in exI, rule_tac x=rx in exI, rule_tac x=ry in exI) simp
	+ next
	+ case False
	+ then obtain k' where "k = 2*k' + 1"
	+ using oddE by blast
	+ hence "cis \<phi> = - cis \<phi>'"
	+ using * cos_periodic_int sin_periodic_int
	+ by (simp add: cis.ctr complex_minus field_simps)
	+ thus ?thesis
	+ using polar \<open>rx \<noteq> 0\<close> \<open>ry \<noteq> 0\<close>
	+ by (rule_tac x=\<phi> in exI, rule_tac x=rx in exI, rule_tac x="-ry" in exI) simp
	+ qed
	+qed
	+
	+end
	diff --git a/thys/Poincare_Disc/Poincare_Lines_Axis_Intersections.thy b/thys/Poincare_Disc/Poincare_Lines_Axis_Intersections.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Poincare_Lines_Axis_Intersections.thy
	@@ -0,0 +1,1235 @@
	+theory Poincare_Lines_Axis_Intersections
	+ imports Poincare_Between
	+begin
	+
	+(* ------------------------------------------------------------------ *)
	+section\<open>Intersection of h-lines with the x-axis in the Poincar\'e model\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+(* ---------------------------------------------------------------- *)
	+subsection\<open>Betweeness of x-axis intersection\<close>
	+(* ---------------------------------------------------------------- *)
	+
	+text\<open>The intersection point of the h-line determined by points $u$ and $v$ and the x-axis is between
	+$u$ and $v$, then $u$ and $v$ are in the opposite half-planes (one must be in the upper, and the
	+other one in the lower half-plane).\<close>
	+
	+lemma poincare_between_x_axis_intersection:
	+ assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "z \<in> unit_disc" and "u \<noteq> v"
	+ assumes "u \<notin> circline_set x_axis" and "v \<notin> circline_set x_axis"
	+ assumes "z \<in> circline_set (poincare_line u v) \<inter> circline_set x_axis"
	+ shows "poincare_between u z v \<longleftrightarrow> arg (to_complex u) * arg (to_complex v) < 0"
	+proof-
	+ have "\<forall> u v. u \<in> unit_disc \<and> v \<in> unit_disc \<and> u \<noteq> v \<and>
	+ u \<notin> circline_set x_axis \<and> v \<notin> circline_set x_axis \<and>
	+ z \<in> circline_set (poincare_line u v) \<inter> circline_set x_axis \<longrightarrow>
	+ (poincare_between u z v \<longleftrightarrow> arg (to_complex u) * arg (to_complex v) < 0)" (is "?P z")
	+ proof (rule wlog_real_zero)
	+ show "?P 0\<^sub>h"
	+ proof ((rule allI)+, rule impI, (erule conjE)+)
	+ fix u v
	+ assume *: "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ "u \<notin> circline_set x_axis" "v \<notin> circline_set x_axis"
	+ "0\<^sub>h \<in> circline_set (poincare_line u v) \<inter> circline_set x_axis"
	+ obtain u' v' where uv: "u = of_complex u'" "v = of_complex v'"
	+ using * inf_or_of_complex[of u] inf_or_of_complex[of v]
	+ by auto
	+
	+
	+ hence "u \<noteq> 0\<^sub>h" "v \<noteq> 0\<^sub>h" "u' \<noteq> 0" "v' \<noteq> 0"
	+ using *
	+ by auto
	+
	+ hence "arg u' \<noteq> 0" "arg v' \<noteq> 0"
	+ using * arg_0_iff[of u'] arg_0_iff[of v']
	+ unfolding circline_set_x_axis uv
	+ by auto
	+
	+ have "poincare_collinear {0\<^sub>h, u, v}"
	+ using *
	+ unfolding poincare_collinear_def
	+ by (rule_tac x="poincare_line u v" in exI, simp)
	+ have "(\<exists>k<0. u' = cor k * v') \<longleftrightarrow> (arg u' * arg v' < 0)" (is "?lhs \<longleftrightarrow> ?rhs")
	+ proof
	+ assume "?lhs"
	+ then obtain k where "k < 0" "u' = cor k * v'"
	+ by auto
	+ thus ?rhs
	+ using arg_mult_real_negative[of k v'] arg_uminus_opposite_sign[of v']
	+ using \<open>u' \<noteq> 0\<close> \<open>v' \<noteq> 0\<close> \<open>arg u' \<noteq> 0\<close> \<open>arg v' \<noteq> 0\<close>
	+ by (auto simp add: mult_neg_pos mult_pos_neg)
	+ next
	+ assume ?rhs
	+ obtain ru rv \<phi> where polar: "u' = cor ru * cis \<phi>" "v' = cor rv * cis \<phi>"
	+ using \<open>poincare_collinear {0\<^sub>h, u, v}\<close> poincare_collinear_zero_polar_form[of u' v'] uv * \<open>u' \<noteq> 0\<close> \<open>v' \<noteq> 0\<close>
	+ by auto
	+ have "ru * rv < 0"
	+ using polar \<open>?rhs\<close> \<open>u' \<noteq> 0\<close> \<open>v' \<noteq> 0\<close>
	+ using arg_mult_real_negative[of "ru" "cis \<phi>"] arg_mult_real_positive[of "ru" "cis \<phi>"]
	+ using arg_mult_real_negative[of "rv" "cis \<phi>"] arg_mult_real_positive[of "rv" "cis \<phi>"]
	+ apply (cases "ru > 0")
	+ apply (cases "rv > 0", simp, simp add: mult_pos_neg)
	+ apply (cases "rv > 0", simp add: mult_neg_pos, simp)
	+ done
	+ thus "?lhs"
	+ using polar
	+ by (rule_tac x="ru / rv" in exI, auto simp add: divide_less_0_iff mult_less_0_iff)
	+ qed
	+ thus "poincare_between u 0\<^sub>h v = (arg (to_complex u) * arg (to_complex v) < 0)"
	+ using poincare_between_u0v[of u v] * \<open>u \<noteq> 0\<^sub>h\<close> \<open>v \<noteq> 0\<^sub>h\<close> uv
	+ by simp
	+ qed
	+ next
	+ fix a z
	+ assume 1: "is_real a" "cmod a < 1" "z \<in> unit_disc"
	+ assume 2: "?P (moebius_pt (blaschke a) z)"
	+ show "?P z"
	+ proof ((rule allI)+, rule impI, (erule conjE)+)
	+ fix u v
	+ let ?M = "moebius_pt (blaschke a)"
	+ let ?Mu = "?M u"
	+ let ?Mv = "?M v"
	+ assume *: "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v" "u \<notin> circline_set x_axis" "v \<notin> circline_set x_axis"
	+ hence "u \<noteq> \<infinity>\<^sub>h" "v \<noteq> \<infinity>\<^sub>h"
	+ by auto
	+
	+ have *: "\<And> x y :: real. x y < 0 \<longleftrightarrow> sgn (x * y) < 0"
	+ by simp
	+
	+ assume "z \<in> circline_set (poincare_line u v) \<inter> circline_set x_axis"
	+ thus "poincare_between u z v = (arg (to_complex u) * arg (to_complex v) < 0)"
	+ using * 1 2[rule_format, of ?Mu ?Mv] \<open>cmod a < 1\<close> \<open>is_real a\<close> blaschke_unit_disc_fix[of a]
	+ using inversion_noteq_unit_disc[of "of_complex a" u] \<open>u \<noteq> \<infinity>\<^sub>h\<close>
	+ using inversion_noteq_unit_disc[of "of_complex a" v] \<open>v \<noteq> \<infinity>\<^sub>h\<close>
	+ apply auto
	+ apply (subst (asm) , subst , subst (asm) sgn_mult, subst sgn_mult, simp)
	+ apply (subst (asm) , subst (asm) , subst (asm) sgn_mult, subst (asm) sgn_mult, simp)
	+ done
	+ qed
	+ next
	+ show "z \<in> unit_disc" by fact
	+ next
	+ show "is_real (to_complex z)"
	+ using assms inf_or_of_complex[of z]
	+ by (auto simp add: circline_set_x_axis)
	+ qed
	+ thus ?thesis
	+ using assms
	+ by simp
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Check if an h-line intersects the x-axis\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lemma x_axis_intersection_equation:
	+ assumes
	+ "H = mk_circline A B C D" and
	+ "(A, B, C, D) \<in> hermitean_nonzero"
	+ shows "of_complex z \<in> circline_set x_axis \<inter> circline_set H \<longleftrightarrow>
	+ Az\<^sup>2 + 2Re B*z + D = 0 \<and> is_real z" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof-
	+ have "?lhs \<longleftrightarrow> Az\<^sup>2 + (B + cnj B)z + D = 0 \<and> z = cnj z"
	+ using assms
	+ using circline_equation_x_axis[of z]
	+ using circline_equation[of H A B C D z]
	+ using hermitean_elems
	+ by (auto simp add: power2_eq_square field_simps)
	+ thus ?thesis
	+ using eq_cnj_iff_real[of z]
	+ using hermitean_elems[of A B C D]
	+ by (simp add: complex_add_cnj complex_eq_if_Re_eq)
	+qed
	+
	+text \<open>Check if an h-line intersects x-axis within the unit disc - this could be generalized to
	+checking if an arbitrary circline intersects the x-axis, but we do not need that.\<close>
	+
	+definition intersects_x_axis_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "intersects_x_axis_cmat H = (let (A, B, C, D) = H in A = 0 \<or> (Re B)\<^sup>2 > (Re A)\<^sup>2)"
	+
	+lift_definition intersects_x_axis_clmat :: "circline_mat \<Rightarrow> bool" is intersects_x_axis_cmat
	+ done
	+
	+lift_definition intersects_x_axis :: "circline \<Rightarrow> bool" is intersects_x_axis_clmat
	+proof (transfer)
	+ fix H1 H2
	+ assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" and "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
	+ by (cases H1, cases H2, auto)
	+ assume "circline_eq_cmat H1 H2"
	+ then obtain k where k: "k \<noteq> 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
	+ by auto
	+ show "intersects_x_axis_cmat H1 = intersects_x_axis_cmat H2"
	+ proof-
	+ have "k \<noteq> 0 \<Longrightarrow> (Re A1)\<^sup>2 < (Re B1)\<^sup>2 \<longleftrightarrow> (k * Re A1)\<^sup>2 < (k * Re B1)\<^sup>2"
	+ by (smt mult_strict_left_mono power2_eq_square semiring_normalization_rules(13) zero_less_power2)
	+ thus ?thesis
	+ using * k
	+ by auto
	+ qed
	+qed
	+
	+lemma intersects_x_axis_mk_circline:
	+ assumes "is_real A" and "A \<noteq> 0 \<or> B \<noteq> 0"
	+ shows "intersects_x_axis (mk_circline A B (cnj B) A) \<longleftrightarrow> A = 0 \<or> (Re B)\<^sup>2 > (Re A)\<^sup>2"
	+proof-
	+ let ?H = "(A, B, (cnj B), A)"
	+ have "hermitean ?H"
	+ using `is_real A`
	+ unfolding hermitean_def mat_adj_def mat_cnj_def
	+ using eq_cnj_iff_real
	+ by auto
	+ moreover
	+ have "?H \<noteq> mat_zero"
	+ using assms
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by (transfer, transfer, auto simp add: Let_def)
	+qed
	+
	+lemma intersects_x_axis_iff:
	+ assumes "is_poincare_line H"
	+ shows "(\<exists> x \<in> unit_disc. x \<in> circline_set H \<inter> circline_set x_axis) \<longleftrightarrow> intersects_x_axis H"
	+proof-
	+ obtain Ac B C Dc where *: "H = mk_circline Ac B C Dc" "hermitean (Ac, B, C, Dc)" "(Ac, B, C, Dc) \<noteq> mat_zero"
	+ using ex_mk_circline[of H]
	+ by auto
	+ hence "(cmod B)\<^sup>2 > (cmod Ac)\<^sup>2" "Ac = Dc"
	+ using assms
	+ using is_poincare_line_mk_circline
	+ by auto
	+
	+ hence "H = mk_circline (Re Ac) B (cnj B) (Re Ac)" "hermitean (cor (Re Ac), B, (cnj B), cor (Re Ac))" "(cor (Re Ac), B, (cnj B), cor (Re Ac)) \<noteq> mat_zero"
	+ using hermitean_elems[of Ac B C Dc] *
	+ by auto
	+ then obtain A where
	+ *: "H = mk_circline (cor A) B (cnj B) (cor A)" "(cor A, B, (cnj B), cor A) \<in> hermitean_nonzero"
	+ by auto
	+
	+ show ?thesis
	+ proof (cases "A = 0")
	+ case True
	+ thus ?thesis
	+ using *
	+ using x_axis_intersection_equation[OF *(1-2), of 0]
	+ using intersects_x_axis_mk_circline[of "cor A" B]
	+ by auto
	+ next
	+ case False
	+ show ?thesis
	+ proof
	+ assume "\<exists> x \<in> unit_disc. x \<in> circline_set H \<inter> circline_set x_axis"
	+ then obtain x where **: "of_complex x \<in> unit_disc" "of_complex x \<in> circline_set H \<inter> circline_set x_axis"
	+ by (metis inf_or_of_complex inf_notin_unit_disc)
	+ hence "is_real x"
	+ unfolding circline_set_x_axis
	+ using of_complex_inj
	+ by auto
	+ hence eq: "A * (Re x)\<^sup>2 + 2 * Re B * Re x + A = 0"
	+ using **
	+ using x_axis_intersection_equation[OF *(1-2), of "Re x"]
	+ by simp
	+ hence "(2 * Re B)\<^sup>2 - 4 * A * A \<ge> 0"
	+ using discriminant_iff[of A _ "2 * Re B" A]
	+ using discrim_def[of A "2 * Re B" A] False
	+ by auto
	+ hence "(Re B)\<^sup>2 \<ge> (Re A)\<^sup>2"
	+ by (simp add: power2_eq_square)
	+ moreover
	+ have "(Re B)\<^sup>2 \<noteq> (Re A)\<^sup>2"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "Re B = Re A \<or> Re B = - Re A"
	+ using power2_eq_iff by blast
	+ hence "A * (Re x)\<^sup>2 + A * 2* Re x + A = 0 \<or> A * (Re x)\<^sup>2 - A * 2 * Re x + A = 0"
	+ using eq
	+ by auto
	+ hence "A * ((Re x)\<^sup>2 + 2* Re x + 1) = 0 \<or> A * ((Re x)\<^sup>2 - 2 * Re x + 1) = 0"
	+ by (simp add: field_simps)
	+ hence "(Re x)\<^sup>2 + 2 * Re x + 1 = 0 \<or> (Re x)\<^sup>2 - 2 * Re x + 1 = 0"
	+ using \<open>A \<noteq> 0\<close>
	+ by simp
	+ hence "(Re x + 1)\<^sup>2 = 0 \<or> (Re x - 1)\<^sup>2 = 0"
	+ by (simp add: power2_sum power2_diff field_simps)
	+ hence "Re x = -1 \<or> Re x = 1"
	+ by auto
	+ thus False
	+ using \<open>is_real x\<close> \<open>of_complex x \<in> unit_disc\<close>
	+ by (auto simp add: cmod_eq_Re)
	+ qed
	+ ultimately
	+ show "intersects_x_axis H"
	+ using intersects_x_axis_mk_circline
	+ using *
	+ by auto
	+ next
	+ assume "intersects_x_axis H"
	+ hence "(Re B)\<^sup>2 > (Re A)\<^sup>2"
	+ using * False
	+ using intersects_x_axis_mk_circline
	+ by simp
	+ hence discr: "(2 * Re B)\<^sup>2 - 4 * A * A > 0"
	+ by (simp add: power2_eq_square)
	+ then obtain x1 x2 where
	+ eqs: "A * x1\<^sup>2 + 2 * Re B * x1 + A = 0" "A * x2\<^sup>2 + 2 * Re B * x2 + A = 0" "x1 \<noteq> x2"
	+ using discriminant_pos_ex[OF \<open>A \<noteq> 0\<close>, of "2 * Re B" A]
	+ using discrim_def[of A "2 * Re B" A]
	+ by auto
	+ hence "x1 * x2 = 1"
	+ using viette2[OF \<open>A \<noteq> 0\<close>, of "2 * Re B" A x1 x2] discr \<open>A \<noteq> 0\<close>
	+ by auto
	+ have "abs x1 \<noteq> 1" "abs x2 \<noteq> 1"
	+ using eqs discr \<open>x1 * x2 = 1\<close>
	+ by (auto simp add: abs_if power2_eq_square)
	+ hence "abs x1 < 1 \<or> abs x2 < 1"
	+ using \<open>x1 * x2 = 1\<close>
	+ by (smt mult_le_cancel_left1 mult_minus_right)
	+ thus "\<exists>x \<in> unit_disc. x \<in> circline_set H \<inter> circline_set x_axis"
	+ using x_axis_intersection_equation[OF *(1-2), of x1]
	+ using x_axis_intersection_equation[OF *(1-2), of x2]
	+ using eqs
	+ by auto
	+ qed
	+ qed
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Check if a Poincar\'e line intersects the y-axis\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+definition intersects_y_axis_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "intersects_y_axis_cmat H = (let (A, B, C, D) = H in A = 0 \<or> (Im B)\<^sup>2 > (Re A)\<^sup>2)"
	+
	+lift_definition intersects_y_axis_clmat :: "circline_mat \<Rightarrow> bool" is intersects_y_axis_cmat
	+ done
	+
	+lift_definition intersects_y_axis :: "circline \<Rightarrow> bool" is intersects_y_axis_clmat
	+proof (transfer)
	+ fix H1 H2
	+ assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" and "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
	+ by (cases H1, cases H2, auto)
	+ assume "circline_eq_cmat H1 H2"
	+ then obtain k where k: "k \<noteq> 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
	+ by auto
	+ show "intersects_y_axis_cmat H1 = intersects_y_axis_cmat H2"
	+ proof-
	+ have "k \<noteq> 0 \<Longrightarrow> (Re A1)\<^sup>2 < (Im B1)\<^sup>2 \<longleftrightarrow> (k * Re A1)\<^sup>2 < (k * Im B1)\<^sup>2"
	+ by (smt mult_strict_left_mono power2_eq_square semiring_normalization_rules(13) zero_less_power2)
	+ thus ?thesis
	+ using * k
	+ by auto
	+ qed
	+qed
	+
	+lemma intersects_x_axis_intersects_y_axis [simp]:
	+ shows "intersects_x_axis (moebius_circline (moebius_rotation (pi/2)) H) \<longleftrightarrow> intersects_y_axis H"
	+ unfolding moebius_rotation_def moebius_similarity_def
	+ by simp (transfer, transfer, auto simp add: mat_adj_def mat_cnj_def)
	+
	+lemma intersects_y_axis_iff:
	+ assumes "is_poincare_line H"
	+ shows "(\<exists> y \<in> unit_disc. y \<in> circline_set H \<inter> circline_set y_axis) \<longleftrightarrow> intersects_y_axis H" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof-
	+ let ?R = "moebius_rotation (pi / 2)"
	+ let ?H' = "moebius_circline ?R H"
	+ have 1: "is_poincare_line ?H'"
	+ using assms
	+ using unit_circle_fix_preserve_is_poincare_line[OF _ assms, of ?R]
	+ by simp
	+
	+ show ?thesis
	+ proof
	+ assume "?lhs"
	+ then obtain y where "y \<in> unit_disc" "y \<in> circline_set H \<inter> circline_set y_axis"
	+ by auto
	+ hence "moebius_pt ?R y \<in> unit_disc \<and> moebius_pt ?R y \<in> circline_set ?H' \<inter> circline_set x_axis"
	+ using rotation_pi_2_y_axis
	+ by (metis Int_iff circline_set_moebius_circline_E moebius_circline_comp_inv_left moebius_pt_comp_inv_left unit_disc_fix_discI unit_disc_fix_rotation)
	+ thus ?rhs
	+ using intersects_x_axis_iff[OF 1]
	+ using intersects_x_axis_intersects_y_axis[of H]
	+ by auto
	+ next
	+ assume "intersects_y_axis H"
	+ hence "intersects_x_axis ?H'"
	+ using intersects_x_axis_intersects_y_axis[of H]
	+ by simp
	+ then obtain x where *: "x \<in> unit_disc" "x \<in> circline_set ?H' \<inter> circline_set x_axis"
	+ using intersects_x_axis_iff[OF 1]
	+ by auto
	+ let ?y = "moebius_pt (-?R) x"
	+ have "?y \<in> unit_disc \<and> ?y \<in> circline_set H \<inter> circline_set y_axis"
	+ using * rotation_pi_2_y_axis[symmetric]
	+ by (metis Int_iff circline_set_moebius_circline_E moebius_pt_comp_inv_left moebius_rotation_uminus uminus_moebius_def unit_disc_fix_discI unit_disc_fix_rotation)
	+ thus ?lhs
	+ by auto
	+ qed
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Intersection point of a Poincar\'e line with the x-axis in the unit disc\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+definition calc_x_axis_intersection_cvec :: "complex \<Rightarrow> complex \<Rightarrow> complex_vec" where
	+ [simp]: "calc_x_axis_intersection_cvec A B =
	+ (let discr = (Re B)\<^sup>2 - (Re A)\<^sup>2 in
	+ (-Re(B) + sgn (Re B) * sqrt(discr), A))"
	+
	+(* intersection with the x-axis for poincare lines that are euclidean circles *)
	+definition calc_x_axis_intersection_cmat_cvec :: "complex_mat \<Rightarrow> complex_vec" where [simp]:
	+ "calc_x_axis_intersection_cmat_cvec H =
	+ (let (A, B, C, D) = H in
	+ if A \<noteq> 0 then
	+ calc_x_axis_intersection_cvec A B
	+ else
	+ (0, 1)
	+ )"
	+
	+lift_definition calc_x_axis_intersection_clmat_hcoords :: "circline_mat \<Rightarrow> complex_homo_coords" is calc_x_axis_intersection_cmat_cvec
	+ by (auto split: if_split_asm)
	+
	+lift_definition calc_x_axis_intersection :: "circline \<Rightarrow> complex_homo" is calc_x_axis_intersection_clmat_hcoords
	+proof transfer
	+ fix H1 H2
	+ assume *: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ obtain A1 B1 C1 D1 A2 B2 C2 D2 where hh: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
	+ by (cases H1, cases H2, auto)
	+ assume "circline_eq_cmat H1 H2"
	+ then obtain k where k: "k \<noteq> 0" "H2 = cor k *\<^sub>s\<^sub>m H1"
	+ by auto
	+
	+ have "calc_x_axis_intersection_cvec A1 B1 \<approx>\<^sub>v calc_x_axis_intersection_cvec A2 B2"
	+ using hh k
	+ apply simp
	+ apply (rule_tac x="cor k" in exI)
	+ apply auto
	+ apply (simp add: sgn_mult power_mult_distrib)
	+ apply (subst right_diff_distrib[symmetric])
	+ apply (subst real_sqrt_mult)
	+ apply (subst cor_mult)
	+ by (simp add: real_sgn_eq right_diff_distrib)
	+
	+ thus "calc_x_axis_intersection_cmat_cvec H1 \<approx>\<^sub>v
	+ calc_x_axis_intersection_cmat_cvec H2"
	+ using hh k
	+ by (auto simp del: calc_x_axis_intersection_cvec_def)
	+qed
	+
	+
	+lemma calc_x_axis_intersection_in_unit_disc:
	+ assumes "is_poincare_line H" "intersects_x_axis H"
	+ shows "calc_x_axis_intersection H \<in> unit_disc"
	+proof (cases "is_line H")
	+ case True
	+ thus ?thesis
	+ using assms
	+ unfolding unit_disc_def disc_def
	+ by simp (transfer, transfer, auto simp add: vec_cnj_def)
	+next
	+ case False
	+ thus ?thesis
	+ using assms
	+ unfolding unit_disc_def disc_def
	+ proof (simp, transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ then obtain A B D where *: "H = (A, B, cnj B, D)" "is_real A" "is_real D"
	+ using hermitean_elems
	+ by (cases H) blast
	+ assume "is_poincare_line_cmat H"
	+ hence *: "H = (A, B, cnj B, A)" "is_real A"
	+ using *
	+ by auto
	+
	+ assume "\<not> circline_A0_cmat H"
	+ hence "A \<noteq> 0"
	+ using *
	+ by simp
	+
	+ assume "intersects_x_axis_cmat H"
	+ hence "(Re B)\<^sup>2 > (Re A)\<^sup>2"
	+ using * \<open>A \<noteq> 0\<close>
	+ by (auto simp add: power2_eq_square complex.expand)
	+
	+ hence "Re B \<noteq> 0"
	+ by auto
	+
	+ have "Re A \<noteq> 0"
	+ using \<open>is_real A\<close> \<open>A \<noteq> 0\<close>
	+ by (auto simp add: complex.expand)
	+
	+ have "sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2) < sqrt((Re B)\<^sup>2)"
	+ using \<open>Re A \<noteq> 0\<close>
	+ by (subst real_sqrt_less_iff) auto
	+ also have "... = sgn (Re B) * (Re B)"
	+ by (smt mult_minus_right nonzero_eq_divide_eq real_sgn_eq real_sqrt_abs)
	+ finally
	+ have 1: "sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2) < sgn (Re B) * (Re B)"
	+ .
	+
	+ have 2: "(Re B)\<^sup>2 - (Re A)\<^sup>2 < sgn (Re B) * (Re B) * sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
	+ using \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close>
	+ using mult_strict_right_mono[OF 1, of "sqrt ((Re B)\<^sup>2 - (Re A)\<^sup>2)"]
	+ by simp
	+
	+ have 3: "(Re B)\<^sup>2 - 2sgn (Re B)Re B*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2) + (Re B)\<^sup>2 - (Re A)\<^sup>2 < (Re A)\<^sup>2"
	+ using mult_strict_left_mono[OF 2, of 2]
	+ by (simp add: field_simps)
	+
	+ have "(sgn (Re B))\<^sup>2 = 1"
	+ using \<open>Re B \<noteq> 0\<close>
	+ by (simp add: sgn_if)
	+
	+ hence "(-Re B + sgn (Re B) * sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 < (Re A)\<^sup>2"
	+ using \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close> 3
	+ by (simp add: power2_diff field_simps)
	+
	+ thus "in_ocircline_cmat_cvec unit_circle_cmat (calc_x_axis_intersection_cmat_cvec H)"
	+ using * \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close>
	+ by (auto simp add: vec_cnj_def power2_eq_square split: if_split_asm)
	+ qed
	+qed
	+
	+
	+lemma calc_x_axis_intersection:
	+ assumes "is_poincare_line H" and "intersects_x_axis H"
	+ shows "calc_x_axis_intersection H \<in> circline_set H \<inter> circline_set x_axis"
	+proof (cases "is_line H")
	+ case True
	+ thus ?thesis
	+ using assms
	+ unfolding circline_set_def
	+ by simp (transfer, transfer, auto simp add: vec_cnj_def)
	+next
	+ case False
	+ thus ?thesis
	+ using assms
	+ unfolding circline_set_def
	+ proof (simp, transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ then obtain A B D where *: "H = (A, B, cnj B, D)" "is_real A" "is_real D"
	+ using hermitean_elems
	+ by (cases H) blast
	+ assume "is_poincare_line_cmat H"
	+ hence *: "H = (A, B, cnj B, A)" "is_real A"
	+ using *
	+ by auto
	+ assume "\<not> circline_A0_cmat H"
	+ hence "A \<noteq> 0"
	+ using *
	+ by auto
	+
	+ assume "intersects_x_axis_cmat H"
	+ hence "(Re B)\<^sup>2 > (Re A)\<^sup>2"
	+ using * \<open>A \<noteq> 0\<close>
	+ by (auto simp add: power2_eq_square complex.expand)
	+
	+ hence "Re B \<noteq> 0"
	+ by auto
	+
	+ show "on_circline_cmat_cvec H (calc_x_axis_intersection_cmat_cvec H) \<and>
	+ on_circline_cmat_cvec x_axis_cmat (calc_x_axis_intersection_cmat_cvec H)" (is "?P1 \<and> ?P2")
	+ proof
	+ show "on_circline_cmat_cvec H (calc_x_axis_intersection_cmat_cvec H)"
	+ proof (cases "circline_A0_cmat H")
	+ case True
	+ thus ?thesis
	+ using * \<open>is_poincare_line_cmat H\<close> \<open>intersects_x_axis_cmat H\<close>
	+ by (simp add: vec_cnj_def)
	+ next
	+ case False
	+ let ?x = "calc_x_axis_intersection_cvec A B"
	+ let ?nom = "fst ?x" and ?den = "snd ?x"
	+ have x: "?x = (?nom, ?den)"
	+ by simp
	+
	+ hence "on_circline_cmat_cvec H (calc_x_axis_intersection_cvec A B)"
	+ proof (subst *, subst x, subst on_circline_cmat_cvec_circline_equation)
	+ have "(sgn(Re B))\<^sup>2 = 1"
	+ using \<open>Re B \<noteq> 0\<close> sgn_pos zero_less_power2 by fastforce
	+ have "(sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 = (Re B)\<^sup>2 - (Re A)\<^sup>2"
	+ using \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close>
	+ by simp
	+
	+ have "(-(Re B) + sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 =
	+ (-(Re B))\<^sup>2 + (sgn(Re B)sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 - 2(Re B)sgn(Re B)sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
	+ by (simp add: power2_diff)
	+ also have "... = (Re B)(Re B) + (sgn(Re B)sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 - 2(Re B)sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
	+ by (simp add: power2_eq_square)
	+ also have "... = (Re B)(Re B) + (sgn(Re B))\<^sup>2(sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 - 2(Re B)sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
	+ by (simp add: power_mult_distrib)
	+ also have "... = (Re B)(Re B) + (Re B)\<^sup>2 - (Re A)\<^sup>2 - 2(Re B)sgn(Re B)sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
	+ using \<open>(sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 = (Re B)\<^sup>2 - (Re A)\<^sup>2\<close> \<open>(sgn(Re B))\<^sup>2 = 1\<close>
	+ by simp
	+ finally have "(-(Re B) + sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 =
	+ (Re B)(Re B) + (Re B)\<^sup>2 - (Re A)\<^sup>2 - 2(Re B)sgn(Re B)sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
	+ by simp
	+
	+ have "is_real ?nom" "is_real ?den"
	+ using \<open>is_real A\<close>
	+ by simp+
	+ hence "cnj (?nom) = ?nom" "cnj (?den) = ?den"
	+ by (simp add:eq_cnj_iff_real)+
	+ hence "A?nom(cnj (?nom)) + B?den(cnj (?nom)) + (cnj B)(cnj (?den))?nom + A?den(cnj (?den))
	+ = A?nom?nom + B?den?nom + (cnj B)?den?nom + A?den?den"
	+ by auto
	+ also have "... = A?nom?nom + (B + (cnj B))?den?nom + A?den?den"
	+ by (simp add:field_simps)
	+ also have "... = A?nom?nom + 2(Re B)?den?nom + A?den*?den"
	+ by (simp add:complex_add_cnj)
	+ also have "... = A?nom\<^sup>2 + 2(Re B)?den?nom + A?den?den"
	+ by (simp add:power2_eq_square)
	+ also have "... = A(-(Re B) + sgn(Re B)sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2
	+ + 2(Re B)A(-(Re B) + sgn(Re B)sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)) + AAA"
	+ unfolding calc_x_axis_intersection_cvec_def
	+ by auto
	+ also have "... = A((Re B)(Re B) + (Re B)\<^sup>2 - (Re A)\<^sup>2 - 2(Re B)sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))
	+ + 2(Re B)A(-(Re B) + sgn(Re B)sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)) + AAA"
	+ using \<open>(-(Re B) + sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 =
	+ (Re B)(Re B) + (Re B)\<^sup>2 - (Re A)\<^sup>2 - 2(Re B)sgn(Re B)sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)\<close>
	+ by simp
	+ also have "... = A((Re B)(Re B) + (Re B)\<^sup>2 - A\<^sup>2 - 2(Re B)sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))
	+ + 2(Re B)A(-(Re B) + sgn(Re B)sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)) + AAA"
	+ using \<open>is_real A\<close>
	+ by simp
	+ also have "... = 0"
	+ apply (simp add:field_simps)
	+ by (simp add: power2_eq_square)
	+ finally have "A?nom(cnj (?nom)) + B?den(cnj (?nom)) + (cnj B)(cnj (?den))?nom + A?den(cnj (?den)) = 0"
	+ by simp
	+ thus "circline_equation A B (cnj B) A ?nom ?den"
	+ by simp
	+ qed
	+ thus ?thesis
	+ using * \<open>is_poincare_line_cmat H\<close> \<open>intersects_x_axis_cmat H\<close>
	+ by (simp add: vec_cnj_def)
	+ qed
	+ next
	+ show "on_circline_cmat_cvec x_axis_cmat (calc_x_axis_intersection_cmat_cvec H)"
	+ using * \<open>is_poincare_line_cmat H\<close> \<open>intersects_x_axis_cmat H\<close> \<open>is_real A\<close>
	+ using eq_cnj_iff_real[of A]
	+ by (simp add: vec_cnj_def)
	+ qed
	+ qed
	+qed
	+
	+lemma unique_calc_x_axis_intersection:
	+ assumes "is_poincare_line H" and "H \<noteq> x_axis"
	+ assumes "x \<in> unit_disc" and "x \<in> circline_set H \<inter> circline_set x_axis"
	+ shows "x = calc_x_axis_intersection H"
	+proof-
	+ have *: "intersects_x_axis H"
	+ using assms
	+ using intersects_x_axis_iff[OF assms(1)]
	+ by auto
	+ show "x = calc_x_axis_intersection H"
	+ using calc_x_axis_intersection[OF assms(1) *]
	+ using calc_x_axis_intersection_in_unit_disc[OF assms(1) *]
	+ using assms
	+ using unique_is_poincare_line[of x "calc_x_axis_intersection H" H x_axis]
	+ by auto
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Check if an h-line intersects the positive part of the x-axis\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+definition intersects_x_axis_positive_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "intersects_x_axis_positive_cmat H = (let (A, B, C, D) = H in Re A \<noteq> 0 \<and> Re B / Re A < -1)"
	+
	+lift_definition intersects_x_axis_positive_clmat :: "circline_mat \<Rightarrow> bool" is intersects_x_axis_positive_cmat
	+ done
	+
	+lift_definition intersects_x_axis_positive :: "circline \<Rightarrow> bool" is intersects_x_axis_positive_clmat
	+proof (transfer)
	+ fix H1 H2
	+ assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" and "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
	+ by (cases H1, cases H2, auto)
	+ assume "circline_eq_cmat H1 H2"
	+ then obtain k where "k \<noteq> 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
	+ by auto
	+ thus "intersects_x_axis_positive_cmat H1 = intersects_x_axis_positive_cmat H2"
	+ using *
	+ by simp
	+qed
	+
	+lemma intersects_x_axis_positive_mk_circline:
	+ assumes "is_real A" and "A \<noteq> 0 \<or> B \<noteq> 0"
	+ shows "intersects_x_axis_positive (mk_circline A B (cnj B) A) \<longleftrightarrow> Re B / Re A < -1"
	+proof-
	+ let ?H = "(A, B, (cnj B), A)"
	+ have "hermitean ?H"
	+ using `is_real A`
	+ unfolding hermitean_def mat_adj_def mat_cnj_def
	+ using eq_cnj_iff_real
	+ by auto
	+ moreover
	+ have "?H \<noteq> mat_zero"
	+ using assms
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by (transfer, transfer, auto simp add: Let_def)
	+qed
	+
	+
	+lemma intersects_x_axis_positive_intersects_x_axis [simp]:
	+ assumes "intersects_x_axis_positive H"
	+ shows "intersects_x_axis H"
	+proof-
	+ have "\<And> a aa. \<lbrakk> Re a \<noteq> 0; Re aa / Re a < - 1; \<not> (Re a)\<^sup>2 < (Re aa)\<^sup>2 \<rbrakk> \<Longrightarrow> aa = 0 \<and> a = 0"
	+ by (smt less_divide_eq_1_pos one_less_power pos2 power2_minus power_divide zero_less_power2)
	+ thus ?thesis
	+ using assms
	+ apply transfer
	+ apply transfer
	+ apply (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
	+ done
	+qed
	+
	+lemma add_less_abs_positive_iff:
	+ fixes a b :: real
	+ assumes "abs b < abs a"
	+ shows "a + b > 0 \<longleftrightarrow> a > 0"
	+ using assms
	+ by auto
	+
	+lemma calc_x_axis_intersection_positive_abs':
	+ fixes A B :: real
	+ assumes "B\<^sup>2 > A\<^sup>2" and "A \<noteq> 0"
	+ shows "abs (sgn(B) * sqrt(B\<^sup>2 - A\<^sup>2) / A) < abs(-B/A)"
	+proof-
	+ from assms have "B \<noteq> 0"
	+ by auto
	+
	+ have "B\<^sup>2 - A\<^sup>2 < B\<^sup>2"
	+ using \<open>A \<noteq> 0\<close>
	+ by auto
	+ hence "sqrt (B\<^sup>2 - A\<^sup>2) < abs B"
	+ using real_sqrt_less_iff[of "B\<^sup>2 - A\<^sup>2" "B\<^sup>2"]
	+ by simp
	+ thus ?thesis
	+ using assms \<open>B \<noteq> 0\<close>
	+ by (simp add: abs_mult divide_strict_right_mono)
	+qed
	+
	+lemma calc_intersect_x_axis_positive_lemma:
	+ assumes "B\<^sup>2 > A\<^sup>2" and "A \<noteq> 0"
	+ shows "(-B + sgn B * sqrt(B\<^sup>2 - A\<^sup>2)) / A > 0 \<longleftrightarrow> -B/A > 1"
	+proof-
	+ have "(-B + sgn B * sqrt(B\<^sup>2 - A\<^sup>2)) / A = -B / A + (sgn B * sqrt(B\<^sup>2 - A\<^sup>2)) / A"
	+ using assms
	+ by (simp add: field_simps)
	+ moreover
	+ have "-B / A + (sgn B * sqrt(B\<^sup>2 - A\<^sup>2)) / A > 0 \<longleftrightarrow> - B / A > 0"
	+ using add_less_abs_positive_iff[OF calc_x_axis_intersection_positive_abs'[OF assms]]
	+ by simp
	+ moreover
	+ hence "(B/A)\<^sup>2 > 1"
	+ using assms
	+ by (simp add: power_divide)
	+ hence "B/A > 1 \<or> B/A < -1"
	+ by (smt one_power2 pos2 power2_minus power_0 power_strict_decreasing zero_power2)
	+ hence "-B / A > 0 \<longleftrightarrow> -B / A > 1"
	+ by auto
	+ ultimately
	+ show ?thesis
	+ using assms
	+ by auto
	+qed
	+
	+lemma intersects_x_axis_positive_iff':
	+ assumes "is_poincare_line H"
	+ shows "intersects_x_axis_positive H \<longleftrightarrow>
	+ calc_x_axis_intersection H \<in> unit_disc \<and> calc_x_axis_intersection H \<in> circline_set H \<inter> positive_x_axis" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof
	+ let ?x = "calc_x_axis_intersection H"
	+ assume ?lhs
	+ hence "?x \<in> circline_set x_axis" "?x \<in> circline_set H" "?x \<in> unit_disc"
	+ using calc_x_axis_intersection_in_unit_disc[OF assms] calc_x_axis_intersection[OF assms]
	+ by auto
	+ moreover
	+ have "Re (to_complex ?x) > 0"
	+ using \<open>?lhs\<close> assms
	+ proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where *: "H = (A, B, C, D)"
	+ by (cases H, auto)
	+ assume "intersects_x_axis_positive_cmat H"
	+ hence **: "Re B / Re A < - 1" "Re A \<noteq> 0"
	+ using *
	+ by auto
	+ have "(Re B)\<^sup>2 > (Re A)\<^sup>2"
	+ using **
	+ by (smt divide_less_eq_1_neg divide_minus_left less_divide_eq_1_pos real_sqrt_abs real_sqrt_less_iff right_inverse_eq)
	+ have "is_real A" "A \<noteq> 0"
	+ using hh hermitean_elems * \<open>Re A \<noteq> 0\<close> complex.expand[of A 0]
	+ by auto
	+ have "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
	+ using \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close> \<open>is_real A\<close>
	+ by (smt cmod_power2 power2_less_0 zero_power2)
	+ have **: "0 < (- Re B + sgn (Re B) sqrt ((Re B)\<^sup>2 - (Re A)\<^sup>2)) / Re A"
	+ using calc_intersect_x_axis_positive_lemma[of "Re A" "Re B"] ** \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close>
	+ by auto
	+
	+ assume "is_poincare_line_cmat H"
	+ hence "A = D"
	+ using * hh
	+ by simp
	+
	+ have "Re ((cor (sgn (Re B)) * cor (sqrt ((Re B)\<^sup>2 - (Re A)\<^sup>2)) - cor (Re B)) / A) = (sgn (Re B) * sqrt ((Re B)\<^sup>2 - (Re A)\<^sup>2) - Re B) / Re D"
	+ using \<open>is_real A\<close> \<open>A = D\<close>
	+ by (metis (no_types, lifting) Re_complex_of_real complex_of_real_Re of_real_diff of_real_divide of_real_mult)
	+ thus "0 < Re (to_complex_cvec (calc_x_axis_intersection_cmat_cvec H))"
	+ using * hh * \<open>(cmod B)\<^sup>2 > (cmod A)\<^sup>2\<close> \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close> \<open>A \<noteq> 0\<close> \<open>A = D\<close>
	+ by simp
	+ qed
	+ ultimately
	+ show ?rhs
	+ unfolding positive_x_axis_def
	+ by auto
	+next
	+ let ?x = "calc_x_axis_intersection H"
	+ assume ?rhs
	+ hence "Re (to_complex ?x) > 0" "?x \<noteq> \<infinity>\<^sub>h" "?x \<in> circline_set x_axis" "?x \<in> unit_disc" "?x \<in> circline_set H"
	+ unfolding positive_x_axis_def
	+ by auto
	+ hence "intersects_x_axis H"
	+ using intersects_x_axis_iff[OF assms]
	+ by auto
	+ thus ?lhs
	+ using \<open>Re (to_complex ?x) > 0\<close> assms
	+ proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where *: "H = (A, B, C, D)"
	+ by (cases H, auto)
	+ assume "0 < Re (to_complex_cvec (calc_x_axis_intersection_cmat_cvec H))" "intersects_x_axis_cmat H" "is_poincare_line_cmat H"
	+ hence *: "A \<noteq> 0" "0 < Re ((cor (sgn (Re B)) cor (sqrt ((Re B)\<^sup>2 - (Re A)\<^sup>2)) - cor (Re B)) / A)" "A = D" "is_real A" "(Re B)\<^sup>2 > (Re A)\<^sup>2"
	+ using * hh hermitean_elems
	+ by (auto split: if_split_asm)
	+
	+ have "Re A \<noteq> 0"
	+ using complex.expand[of A 0] \<open>A \<noteq> 0\<close> \<open>is_real A\<close>
	+ by auto
	+
	+ have "Re ((cor (sgn (Re B)) * cor (sqrt ((Re B)\<^sup>2 - (Re D)\<^sup>2)) - cor (Re B)) / D) = (sgn (Re B) * sqrt ((Re B)\<^sup>2 - (Re D)\<^sup>2) - Re B) / Re D"
	+ using \<open>is_real A\<close> \<open>A = D\<close>
	+ by (metis (no_types, lifting) Re_complex_of_real complex_of_real_Re of_real_diff of_real_divide of_real_mult)
	+
	+ thus "intersects_x_axis_positive_cmat H"
	+ using * ** \<open>Re A \<noteq> 0\<close>
	+ using calc_intersect_x_axis_positive_lemma[of "Re A" "Re B"]
	+ by simp
	+ qed
	+qed
	+
	+lemma intersects_x_axis_positive_iff:
	+ assumes "is_poincare_line H" and "H \<noteq> x_axis"
	+ shows "intersects_x_axis_positive H \<longleftrightarrow>
	+ (\<exists> x. x \<in> unit_disc \<and> x \<in> circline_set H \<inter> positive_x_axis)" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof
	+ assume ?lhs
	+ thus ?rhs
	+ using intersects_x_axis_positive_iff'[OF assms(1)]
	+ by auto
	+next
	+ assume ?rhs
	+ then obtain x where "x \<in> unit_disc" "x \<in> circline_set H \<inter> positive_x_axis"
	+ by auto
	+ thus ?lhs
	+ using unique_calc_x_axis_intersection[OF assms, of x]
	+ using intersects_x_axis_positive_iff'[OF assms(1)]
	+ unfolding positive_x_axis_def
	+ by auto
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Check if an h-line intersects the positive part of the y-axis\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+definition intersects_y_axis_positive_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "intersects_y_axis_positive_cmat H = (let (A, B, C, D) = H in Re A \<noteq> 0 \<and> Im B / Re A < -1)"
	+
	+lift_definition intersects_y_axis_positive_clmat :: "circline_mat \<Rightarrow> bool" is intersects_y_axis_positive_cmat
	+ done
	+
	+lift_definition intersects_y_axis_positive :: "circline \<Rightarrow> bool" is intersects_y_axis_positive_clmat
	+proof (transfer)
	+ fix H1 H2
	+ assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" and "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
	+ by (cases H1, cases H2, auto)
	+ assume "circline_eq_cmat H1 H2"
	+ then obtain k where "k \<noteq> 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
	+ by auto
	+ thus "intersects_y_axis_positive_cmat H1 = intersects_y_axis_positive_cmat H2"
	+ using *
	+ by simp
	+qed
	+
	+lemma intersects_x_axis_positive_intersects_y_axis_positive [simp]:
	+ shows "intersects_x_axis_positive (moebius_circline (moebius_rotation (-pi/2)) H) \<longleftrightarrow> intersects_y_axis_positive H"
	+ using hermitean_elems
	+ unfolding moebius_rotation_def moebius_similarity_def
	+ by simp (transfer, transfer, auto simp add: mat_adj_def mat_cnj_def)
	+
	+lemma intersects_y_axis_positive_iff:
	+ assumes "is_poincare_line H" "H \<noteq> y_axis"
	+ shows "(\<exists> y \<in> unit_disc. y \<in> circline_set H \<inter> positive_y_axis) \<longleftrightarrow> intersects_y_axis_positive H" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof-
	+ let ?R = "moebius_rotation (-pi / 2)"
	+ let ?H' = "moebius_circline ?R H"
	+ have 1: "is_poincare_line ?H'"
	+ using assms
	+ using unit_circle_fix_preserve_is_poincare_line[OF _ assms(1), of ?R]
	+ by simp
	+
	+ have 2: "moebius_circline ?R H \<noteq> x_axis"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "H = moebius_circline (moebius_rotation (pi/2)) x_axis"
	+ using moebius_circline_comp_inv_left[of ?R H]
	+ by auto
	+ thus False
	+ using \<open>H \<noteq> y_axis\<close>
	+ by auto
	+ qed
	+
	+ show ?thesis
	+ proof
	+ assume "?lhs"
	+ then obtain y where "y \<in> unit_disc" "y \<in> circline_set H \<inter> positive_y_axis"
	+ by auto
	+ hence "moebius_pt ?R y \<in> unit_disc" "moebius_pt ?R y \<in> circline_set ?H' \<inter> positive_x_axis"
	+ using rotation_minus_pi_2_positive_y_axis
	+ by auto
	+ thus ?rhs
	+ using intersects_x_axis_positive_iff[OF 1 2]
	+ using intersects_x_axis_positive_intersects_y_axis_positive[of H]
	+ by auto
	+ next
	+ assume "intersects_y_axis_positive H"
	+ hence "intersects_x_axis_positive ?H'"
	+ using intersects_x_axis_positive_intersects_y_axis_positive[of H]
	+ by simp
	+ then obtain x where *: "x \<in> unit_disc" "x \<in> circline_set ?H' \<inter> positive_x_axis"
	+ using intersects_x_axis_positive_iff[OF 1 2]
	+ by auto
	+ let ?y = "moebius_pt (-?R) x"
	+ have "?y \<in> unit_disc \<and> ?y \<in> circline_set H \<inter> positive_y_axis"
	+ using * rotation_minus_pi_2_positive_y_axis[symmetric]
	+ by (metis Int_iff circline_set_moebius_circline_E image_eqI moebius_pt_comp_inv_image_left moebius_rotation_uminus uminus_moebius_def unit_disc_fix_discI unit_disc_fix_rotation)
	+ thus ?lhs
	+ by auto
	+ qed
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Position of the intersection point in the unit disc\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text\<open>Check if the intersection point of one h-line with the x-axis is located more outward the edge
	+of the disc than the intersection point of another h-line.\<close>
	+
	+definition outward_cmat :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> bool" where
	+ [simp]: "outward_cmat H1 H2 = (let (A1, B1, C1, D1) = H1; (A2, B2, C2, D2) = H2
	+ in -Re B1/Re A1 \<le> -Re B2/Re A2)"
	+lift_definition outward_clmat :: "circline_mat \<Rightarrow> circline_mat \<Rightarrow> bool" is outward_cmat
	+ done
	+lift_definition outward :: "circline \<Rightarrow> circline \<Rightarrow> bool" is outward_clmat
	+ apply transfer
	+ apply simp
	+ apply (case_tac circline_mat1, case_tac circline_mat2, case_tac circline_mat3, case_tac circline_mat4)
	+ apply simp
	+ apply (erule_tac exE)+
	+ apply (erule_tac conjE)+
	+ apply simp
	+ done
	+
	+lemma outward_mk_circline:
	+ assumes "is_real A1" and "is_real A2" and "A1 \<noteq> 0 \<or> B1 \<noteq> 0" and "A2 \<noteq> 0 \<or> B2 \<noteq> 0"
	+ shows "outward (mk_circline A1 B1 (cnj B1) A1) (mk_circline A2 B2 (cnj B2) A2) \<longleftrightarrow> - Re B1 / Re A1 \<le> - Re B2 / Re A2"
	+proof-
	+ let ?H1 = "(A1, B1, (cnj B1), A1)"
	+ let ?H2 = "(A2, B2, (cnj B2), A2)"
	+ have "hermitean ?H1" "hermitean ?H2"
	+ using `is_real A1` `is_real A2`
	+ unfolding hermitean_def mat_adj_def mat_cnj_def
	+ using eq_cnj_iff_real
	+ by auto
	+ moreover
	+ have "?H1 \<noteq> mat_zero" "?H2 \<noteq> mat_zero"
	+ using assms
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by (transfer, transfer, auto simp add: Let_def)
	+qed
	+
	+lemma calc_x_axis_intersection_fun_mono:
	+ fixes x1 x2 :: real
	+ assumes "x1 > 1" and "x2 > x1"
	+ shows "x1 - sqrt(x1\<^sup>2 - 1) > x2 - sqrt(x2\<^sup>2 - 1)"
	+ using assms
	+proof-
	+ have *: "sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1) > 0"
	+ using assms
	+ by (smt one_less_power pos2 real_sqrt_gt_zero)
	+
	+ have "sqrt(x1\<^sup>2 - 1) < x1"
	+ using real_sqrt_less_iff[of "x1\<^sup>2 - 1" "x1\<^sup>2"] \<open>x1 > 1\<close>
	+ by auto
	+ moreover
	+ have "sqrt(x2\<^sup>2 - 1) < x2"
	+ using real_sqrt_less_iff[of "x2\<^sup>2 - 1" "x2\<^sup>2"] \<open>x1 > 1\<close> \<open>x2 > x1\<close>
	+ by auto
	+ ultimately
	+ have "sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1) < x1 + x2"
	+ by simp
	+ hence "(x1 + x2) / (sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1)) > 1"
	+ using *
	+ using less_divide_eq_1_pos[of "sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1)" "x1 + x2"]
	+ by simp
	+ hence "(x2\<^sup>2 - x1\<^sup>2) / (sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1)) > x2 - x1"
	+ using \<open>x2 > x1\<close>
	+ using mult_less_cancel_left_pos[of "x2 - x1" 1 "(x2 + x1) / (sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1))"]
	+ by (simp add: power2_eq_square field_simps)
	+ moreover
	+ have "(x2\<^sup>2 - x1\<^sup>2) = (sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1)) * ((sqrt(x2\<^sup>2 - 1) - sqrt(x1\<^sup>2 - 1)))"
	+ using \<open>x1 > 1\<close> \<open>x2 > x1\<close>
	+ by (simp add: field_simps)
	+ ultimately
	+ have "sqrt(x2\<^sup>2 - 1) - sqrt(x1\<^sup>2 - 1) > x2 - x1"
	+ using *
	+ by simp
	+ thus ?thesis
	+ by simp
	+qed
	+
	+lemma calc_x_axis_intersection_mono:
	+ fixes a1 b1 a2 b2 :: real
	+ assumes "-b1/a1 > 1" and "a1 \<noteq> 0" and "-b2/a2 \<ge> -b1/a1" and "a2 \<noteq> 0"
	+ shows "(-b1 + sgn b1 * sqrt(b1\<^sup>2 - a1\<^sup>2)) / a1 \<ge> (-b2 + sgn b2 * sqrt(b2\<^sup>2 - a2\<^sup>2)) / a2" (is "?lhs \<ge> ?rhs")
	+proof-
	+ have "?lhs = -b1/a1 - sqrt((-b1/a1)\<^sup>2 - 1)"
	+ proof (cases "b1 > 0")
	+ case True
	+ hence "a1 < 0"
	+ using assms
	+ by (smt divide_neg_pos)
	+ thus ?thesis
	+ using \<open>b1 > 0\<close> \<open>a1 < 0\<close>
	+ by (simp add: real_sqrt_divide field_simps)
	+ next
	+ case False
	+ hence "b1 < 0"
	+ using assms
	+ by (cases "b1 = 0") auto
	+ hence "a1 > 0"
	+ using assms
	+ by (smt divide_pos_neg)
	+ thus ?thesis
	+ using \<open>b1 < 0\<close> \<open>a1 > 0\<close>
	+ by (simp add: real_sqrt_divide field_simps)
	+ qed
	+
	+ moreover
	+
	+ have "?rhs = -b2/a2 - sqrt((-b2/a2)\<^sup>2 - 1)"
	+ proof (cases "b2 > 0")
	+ case True
	+ hence "a2 < 0"
	+ using assms
	+ by (smt divide_neg_pos)
	+ thus ?thesis
	+ using \<open>b2 > 0\<close> \<open>a2 < 0\<close>
	+ by (simp add: real_sqrt_divide field_simps)
	+ next
	+ case False
	+ hence "b2 < 0"
	+ using assms
	+ by (cases "b2 = 0") auto
	+ hence "a2 > 0"
	+ using assms
	+ by (smt divide_pos_neg)
	+ thus ?thesis
	+ using \<open>b2 < 0\<close> \<open>a2 > 0\<close>
	+ by (simp add: real_sqrt_divide field_simps)
	+ qed
	+
	+ ultimately
	+
	+ show ?thesis
	+ using calc_x_axis_intersection_fun_mono[of "-b1/a1" "-b2/a2"]
	+ using assms
	+ by (cases "-b1/a1=-b2/a2", auto)
	+qed
	+
	+lemma outward:
	+ assumes "is_poincare_line H1" and "is_poincare_line H2"
	+ assumes "intersects_x_axis_positive H1" and "intersects_x_axis_positive H2"
	+ assumes "outward H1 H2"
	+ shows "Re (to_complex (calc_x_axis_intersection H1)) \<ge> Re (to_complex (calc_x_axis_intersection H2))"
	+proof-
	+ have "intersects_x_axis H1" "intersects_x_axis H2"
	+ using assms
	+ by auto
	+ thus ?thesis
	+ using assms
	+ proof (transfer, transfer)
	+ fix H1 H2
	+ assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
	+ by (cases H1, cases H2, auto)
	+ have "is_real A1" "is_real A2"
	+ using hermitean_elems * hh
	+ by auto
	+ assume 1: "intersects_x_axis_positive_cmat H1" "intersects_x_axis_positive_cmat H2"
	+ assume 2: "intersects_x_axis_cmat H1" "intersects_x_axis_cmat H2"
	+ assume 3: "is_poincare_line_cmat H1" "is_poincare_line_cmat H2"
	+ assume 4: "outward_cmat H1 H2"
	+ have "A1 \<noteq> 0" "A2 \<noteq> 0"
	+ using * \<open>is_real A1\<close> \<open>is_real A2\<close> 1 complex.expand[of A1 0] complex.expand[of A2 0]
	+ by auto
	+ hence "(sgn (Re B2) * sqrt ((Re B2)\<^sup>2 - (Re A2)\<^sup>2) - Re B2) / Re A2
	+ \<le> (sgn (Re B1) * sqrt ((Re B1)\<^sup>2 - (Re A1)\<^sup>2) - Re B1) / Re A1"
	+ using calc_x_axis_intersection_mono[of "Re B1" "Re A1" "Re B2" "Re A2"]
	+ using 1 4 *
	+ by simp
	+ moreover
	+ have "(sgn (Re B2) * sqrt ((Re B2)\<^sup>2 - (Re A2)\<^sup>2) - Re B2) / Re A2 =
	+ Re ((cor (sgn (Re B2)) * cor (sqrt ((Re B2)\<^sup>2 - (Re A2)\<^sup>2)) - cor (Re B2)) / A2)"
	+ using \<open>is_real A2\<close> \<open>A2 \<noteq> 0\<close>
	+ by (simp add: Re_divide_real)
	+ moreover
	+ have "(sgn (Re B1) * sqrt ((Re B1)\<^sup>2 - (Re A1)\<^sup>2) - Re B1) / Re A1 =
	+ Re ((cor (sgn (Re B1)) * cor (sqrt ((Re B1)\<^sup>2 - (Re A1)\<^sup>2)) - cor (Re B1)) / A1)"
	+ using \<open>is_real A1\<close> \<open>A1 \<noteq> 0\<close>
	+ by (simp add: Re_divide_real)
	+ ultimately
	+ show "Re (to_complex_cvec (calc_x_axis_intersection_cmat_cvec H2))
	+ \<le> Re (to_complex_cvec (calc_x_axis_intersection_cmat_cvec H1))"
	+ using 2 3 \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close> * \<open>is_real A1\<close> \<open>is_real A2\<close>
	+ by (simp del: is_poincare_line_cmat_def intersects_x_axis_cmat_def)
	+ qed
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Ideal points and x-axis intersection\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lemma ideal_points_intersects_x_axis:
	+ assumes "is_poincare_line H" and "ideal_points H = {i1, i2}" and "H \<noteq> x_axis"
	+ shows "intersects_x_axis H \<longleftrightarrow> Im (to_complex i1) * Im (to_complex i2) < 0"
	+ using assms
	+proof-
	+ have "i1 \<noteq> i2"
	+ using assms(1) assms(2) ex_poincare_line_points ideal_points_different(1)
	+ by blast
	+
	+ have "calc_ideal_points H = {i1, i2}"
	+ using assms
	+ using ideal_points_unique
	+ by auto
	+
	+ have "\<forall> i1 \<in> calc_ideal_points H.
	+ \<forall> i2 \<in> calc_ideal_points H.
	+ is_poincare_line H \<and> H \<noteq> x_axis \<and> i1 \<noteq> i2 \<longrightarrow> (Im (to_complex i1) * Im (to_complex i2) < 0 \<longleftrightarrow> intersects_x_axis H)"
	+ proof (transfer, transfer, (rule ballI)+, rule impI, (erule conjE)+, case_tac H, case_tac i1, case_tac i2)
	+ fix i11 i12 i21 i22 A B C D H i1 i2
	+ assume H: "H = (A, B, C, D)" "hermitean H" "H \<noteq> mat_zero"
	+ assume line: "is_poincare_line_cmat H"
	+ assume i1: "i1 = (i11, i12)" "i1 \<in> calc_ideal_points_cmat_cvec H"
	+ assume i2: "i2 = (i21, i22)" "i2 \<in> calc_ideal_points_cmat_cvec H"
	+ assume different: "\<not> i1 \<approx>\<^sub>v i2"
	+ assume not_x_axis: "\<not> circline_eq_cmat H x_axis_cmat"
	+
	+ have "is_real A" "is_real D" "C = cnj B"
	+ using H hermitean_elems
	+ by auto
	+ have "(cmod A)\<^sup>2 < (cmod B)\<^sup>2" "A = D"
	+ using line H
	+ by auto
	+
	+ let ?discr = "sqrt ((cmod B)\<^sup>2 - (Re D)\<^sup>2)"
	+ let ?den = "(cmod B)\<^sup>2"
	+ let ?i1 = "B * (- D - \<i> * ?discr)"
	+ let ?i2 = "B * (- D + \<i> * ?discr)"
	+
	+ have "i11 = ?i1 \<or> i11 = ?i2" "i12 = ?den"
	+ "i21 = ?i1 \<or> i21 = ?i2" "i22 = ?den"
	+ using i1 i2 H line
	+ by (auto split: if_split_asm)
	+ hence i: "i11 = ?i1 \<and> i21 = ?i2 \<or> i11 = ?i2 \<and> i21 = ?i1"
	+ using `\<not> i1 \<approx>\<^sub>v i2` i1 i2
	+ by auto
	+
	+ have "Im (i11 / i12) * Im (i21 / i22) = Im (?i1 / ?den) * Im (?i2 / ?den)"
	+ using i `i12 = ?den` `i22 = ?den`
	+ by auto
	+ also have "... = Im (?i1) * Im (?i2) / ?den\<^sup>2"
	+ by simp
	+ also have "... = (Im B * (Im B * (Re D * Re D)) - Re B * (Re B * ((cmod B)\<^sup>2 - (Re D)\<^sup>2))) / cmod B ^ 4"
	+ using `(cmod B)\<^sup>2 > (cmod A)\<^sup>2` `A = D`
	+ using `is_real D` cmod_eq_Re[of A]
	+ by (auto simp add: field_simps)
	+ also have "... = ((Im B)\<^sup>2 * (Re D)\<^sup>2 - (Re B)\<^sup>2 * ((Re B)\<^sup>2 + (Im B)\<^sup>2 - (Re D)\<^sup>2)) / cmod B ^ 4"
	+ proof-
	+ have "cmod B * cmod B = Re B * Re B + Im B * Im B"
	+ by (metis cmod_power2 power2_eq_square)
	+ thus ?thesis
	+ by (simp add: power2_eq_square)
	+ qed
	+ also have "... = (((Re D)\<^sup>2 - (Re B)\<^sup>2) * ((Re B)\<^sup>2 + (Im B)\<^sup>2)) / cmod B ^ 4"
	+ by (simp add: power2_eq_square field_simps)
	+ finally have Im_product: "Im (i11 / i12) * Im (i21 / i22) = ((Re D)\<^sup>2 - (Re B)\<^sup>2) * ((Re B)\<^sup>2 + (Im B)\<^sup>2) / cmod B ^ 4"
	+ .
	+
	+ show "Im (to_complex_cvec i1) * Im (to_complex_cvec i2) < 0 \<longleftrightarrow> intersects_x_axis_cmat H"
	+ proof safe
	+ assume opposite: "Im (to_complex_cvec i1) * Im (to_complex_cvec i2) < 0"
	+ show "intersects_x_axis_cmat H"
	+ proof-
	+ have "((Re D)\<^sup>2 - (Re B)\<^sup>2) * ((Re B)\<^sup>2 + (Im B)\<^sup>2) / cmod B ^ 4 < 0"
	+ using Im_product opposite i1 i2
	+ by simp
	+ hence "((Re D)\<^sup>2 - (Re B)\<^sup>2) * ((Re B)\<^sup>2 + (Im B)\<^sup>2) < 0"
	+ by (simp add: divide_less_0_iff)
	+ hence "(Re D)\<^sup>2 < (Re B)\<^sup>2"
	+ by (simp add: mult_less_0_iff not_sum_power2_lt_zero)
	+ thus ?thesis
	+ using H `A = D` `is_real D`
	+ by auto
	+ qed
	+ next
	+ have : "(\<forall>k. k Im B = 1 \<longrightarrow> k = 0) \<longrightarrow> Im B = 0"
	+ apply (safe, erule_tac x="1 / Im B" in allE)
	+ using divide_cancel_left by fastforce
	+ assume "intersects_x_axis_cmat H"
	+ hence "Re D = 0 \<or> (Re D)\<^sup>2 < (Re B)\<^sup>2"
	+ using H `A = D`
	+ by auto
	+ hence "(Re D)\<^sup>2 < (Re B)\<^sup>2"
	+ using `is_real D` line H `C = cnj B`
	+ using not_x_axis *
	+ by (auto simp add: complex_eq_iff)
	+ hence "((Re D)\<^sup>2 - (Re B)\<^sup>2) * ((Re B)\<^sup>2 + (Im B)\<^sup>2) < 0"
	+ by (metis add_cancel_left_left diff_less_eq mult_eq_0_iff mult_less_0_iff power2_eq_square power2_less_0 sum_squares_gt_zero_iff)
	+ thus "Im (to_complex_cvec i1) * Im (to_complex_cvec i2) < 0"
	+ using Im_product i1 i2
	+ using divide_eq_0_iff divide_less_0_iff prod.simps(2) to_complex_cvec_def zero_complex.simps(1) zero_less_norm_iff
	+ by fastforce
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms `calc_ideal_points H = {i1, i2}` `i1 \<noteq> i2`
	+ by auto
	+qed
	+
	+end
	diff --git a/thys/Poincare_Disc/Poincare_Lines_Ideal_Points.thy b/thys/Poincare_Disc/Poincare_Lines_Ideal_Points.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Poincare_Lines_Ideal_Points.thy
	@@ -0,0 +1,683 @@
	+theory Poincare_Lines_Ideal_Points
	+imports Poincare_Lines
	+begin
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Ideal points of h-lines\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+(* TODO: Introduce ideal points for the oriented circline -
	+ it would be a list, not a set of two points *)
	+
	+text\<open>\emph{Ideal points} of an h-line are points where the h-line intersects the unit disc.\<close>
	+
	+(* ------------------------------------------------------------------ *)
	+subsubsection \<open>Calculation of ideal points\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text \<open>We decided to define ideal points constructively, i.e., we calculate the coordinates of ideal
	+points for a given h-line explicitly. Namely, if the h-line is determined by $A$ and $B$, the two
	+intersection points are $$\frac{B}{\|B\|^2}\left(-A \pm i\cdot \sqrt{\|B\|^2 - A^2}\right).$$\<close>
	+
	+definition calc_ideal_point1_cvec :: "complex \<Rightarrow> complex \<Rightarrow> complex_vec" where
	+ [simp]: "calc_ideal_point1_cvec A B =
	+ (let discr = Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2) in
	+ (B(-A - \<i>sqrt(discr)), (cmod B)\<^sup>2))"
	+
	+definition calc_ideal_point2_cvec :: "complex \<Rightarrow> complex \<Rightarrow> complex_vec" where
	+ [simp]: "calc_ideal_point2_cvec A B =
	+ (let discr = Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2) in
	+ (B(-A + \<i>sqrt(discr)), (cmod B)\<^sup>2))"
	+
	+definition calc_ideal_points_cmat_cvec :: "complex_mat \<Rightarrow> complex_vec set" where
	+ [simp]: "calc_ideal_points_cmat_cvec H =
	+ (if is_poincare_line_cmat H then
	+ let (A, B, C, D) = H
	+ in {calc_ideal_point1_cvec A B, calc_ideal_point2_cvec A B}
	+ else
	+ {(-1, 1), (1, 1)})"
	+
	+lift_definition calc_ideal_points_clmat_hcoords :: "circline_mat \<Rightarrow> complex_homo_coords set" is calc_ideal_points_cmat_cvec
	+ by (auto simp add: Let_def split: if_split_asm)
	+
	+lift_definition calc_ideal_points :: "circline \<Rightarrow> complex_homo set" is calc_ideal_points_clmat_hcoords
	+proof transfer
	+ fix H1 H2
	+ assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
	+ obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
	+ by (cases H1, cases H2, auto)
	+ assume "circline_eq_cmat H1 H2"
	+ then obtain k where k: "k \<noteq> 0" "H2 = cor k *\<^sub>s\<^sub>m H1"
	+ by auto
	+ thus "rel_set (\<approx>\<^sub>v) (calc_ideal_points_cmat_cvec H1) (calc_ideal_points_cmat_cvec H2)"
	+ proof (cases "is_poincare_line_cmat H1")
	+ case True
	+ hence "is_poincare_line_cmat H2"
	+ using k * hermitean_mult_real[of H1 k] hh
	+ by (auto simp add: power2_eq_square)
	+ have *: "sqrt (\<bar>k\<bar> cmod B1 * (\<bar>k\<bar> * cmod B1) - k * Re D1 * (k * Re D1)) =
	+ \<bar>k\<bar> * sqrt(cmod B1 * cmod B1 - Re D1 * Re D1)"
	+ proof-
	+ have "\<bar>k\<bar> * cmod B1 * (\<bar>k\<bar> * cmod B1) - k * Re D1 * (k * Re D1) =
	+ k\<^sup>2 * (cmod B1 * cmod B1 - Re D1 * Re D1)"
	+ by (simp add: power2_eq_square field_simps)
	+ thus ?thesis
	+ by (simp add: real_sqrt_mult)
	+ qed
	+ show ?thesis
	+ using \<open>is_poincare_line_cmat H1\<close> \<open>is_poincare_line_cmat H2\<close>
	+ using * k
	+ apply (simp add: Let_def)
	+ apply safe
	+ apply (simp add: power2_eq_square rel_set_def)
	+ apply safe
	+ apply (cases "k > 0")
	+ apply (rule_tac x="(cor k)\<^sup>2" in exI)
	+ apply (subst **)
	+ apply (simp add: power2_eq_square field_simps)
	+ apply (erule notE, rule_tac x="(cor k)\<^sup>2" in exI)
	+ apply (subst **)
	+ apply (simp add: power2_eq_square field_simps)
	+ apply (cases "k > 0")
	+ apply (erule notE, rule_tac x="(cor k)\<^sup>2" in exI)
	+ apply (subst **)
	+ apply (simp add: power2_eq_square field_simps)
	+ apply (rule_tac x="(cor k)\<^sup>2" in exI)
	+ apply (subst **)
	+ apply (simp add: power2_eq_square field_simps)
	+ apply (cases "k > 0")
	+ apply (rule_tac x="(cor k)\<^sup>2" in exI)
	+ apply (subst **)
	+ apply (simp add: power2_eq_square field_simps)
	+ apply (erule notE, rule_tac x="(cor k)\<^sup>2" in exI)
	+ apply (subst **)
	+ apply (simp add: power2_eq_square field_simps)
	+ apply (cases "k > 0")
	+ apply (erule notE, rule_tac x="(cor k)\<^sup>2" in exI)
	+ apply (subst **)
	+ apply (simp add: power2_eq_square field_simps)
	+ apply (rule_tac x="(cor k)\<^sup>2" in exI)
	+ apply (subst **)
	+ apply (simp add: power2_eq_square field_simps)
	+ done
	+ next
	+ case False
	+ hence "\<not> is_poincare_line_cmat H2"
	+ using k * hermitean_mult_real[of H1 k] hh
	+ by (auto simp add: power2_eq_square)
	+ have "rel_set (\<approx>\<^sub>v) {(- 1, 1), (1, 1)} {(- 1, 1), (1, 1)}"
	+ by (simp add: rel_set_def)
	+ thus ?thesis
	+ using \<open>\<not> is_poincare_line_cmat H1\<close> \<open>\<not> is_poincare_line_cmat H2\<close>
	+ using *
	+ apply (simp add: Let_def)
	+ apply safe
	+ done
	+ qed
	+qed
	+
	+text \<open>Correctness of the calculation\<close>
	+
	+text\<open>We show that for every h-line its two calculated ideal points are different and are on the
	+intersection of that line and the unit circle.\<close>
	+
	+text \<open>Calculated ideal points are on the unit circle\<close>
	+
	+lemma calc_ideal_point_1_unit:
	+ assumes "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
	+ assumes "(z1, z2) = calc_ideal_point1_cvec A B"
	+ shows "z1 * cnj z1 = z2 * cnj z2"
	+proof-
	+ let ?discr = "Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2)"
	+ have "?discr > 0"
	+ using assms
	+ by (simp add: cmod_power2)
	+ have "(B(-A - \<i>sqrt(?discr))) * cnj (B(-A - \<i>sqrt(?discr))) = (B * cnj B) * (A\<^sup>2 + cor (abs ?discr))"
	+ using \<open>is_real A\<close> eq_cnj_iff_real[of A]
	+ by (simp add: field_simps power2_eq_square)
	+ also have "... = (B * cnj B) * (cmod B)\<^sup>2"
	+ using \<open>?discr > 0\<close>
	+ using assms
	+ using complex_of_real_Re[of "(cmod B)\<^sup>2 - (Re A)\<^sup>2"] complex_of_real_Re[of A] \<open>is_real A\<close>
	+ by (simp add: power2_eq_square)
	+ also have "... = (cmod B)\<^sup>2 * cnj ((cmod B)\<^sup>2)"
	+ using complex_cnj_complex_of_real complex_mult_cnj_cmod
	+ by presburger
	+ finally show ?thesis
	+ using assms
	+ by simp
	+qed
	+
	+lemma calc_ideal_point_2_unit:
	+ assumes "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
	+ assumes "(z1, z2) = calc_ideal_point2_cvec A B"
	+ shows "z1 * cnj z1 = z2 * cnj z2"
	+proof-
	+ let ?discr = "Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2)"
	+ have "?discr > 0"
	+ using assms
	+ by (simp add: cmod_power2)
	+ have "(B(-A + \<i>sqrt(?discr))) * cnj (B(-A + \<i>sqrt(?discr))) = (B * cnj B) * (A\<^sup>2 + cor (abs ?discr))"
	+ using \<open>is_real A\<close> eq_cnj_iff_real[of A]
	+ by (simp add: field_simps power2_eq_square)
	+ also have "... = (B * cnj B) * (cmod B)\<^sup>2"
	+ using \<open>?discr > 0\<close>
	+ using assms
	+ using complex_of_real_Re[of "(cmod B)\<^sup>2 - (Re A)\<^sup>2"] complex_of_real_Re[of A] \<open>is_real A\<close>
	+ by (simp add: power2_eq_square)
	+ also have "... = (cmod B)\<^sup>2 * cnj ((cmod B)\<^sup>2)"
	+ using complex_cnj_complex_of_real complex_mult_cnj_cmod
	+ by presburger
	+ finally show ?thesis
	+ using assms
	+ by simp
	+qed
	+
	+lemma calc_ideal_points_on_unit_circle:
	+ shows "\<forall> z \<in> calc_ideal_points H. z \<in> circline_set unit_circle"
	+ unfolding circline_set_def
	+ apply simp
	+proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where *: "H = (A, B, C, D)"
	+ by (cases H, auto)
	+ have "\<forall> (z1, z2) \<in> calc_ideal_points_cmat_cvec H. z1 * cnj z1 = z2 * cnj z2"
	+ using hermitean_elems[of A B C D]
	+ unfolding calc_ideal_points_cmat_cvec_def
	+ using calc_ideal_point_1_unit[of A B]
	+ using calc_ideal_point_2_unit[of A B]
	+ using hh *
	+ apply (cases "calc_ideal_point1_cvec A B", cases "calc_ideal_point2_cvec A B")
	+ apply (auto simp add: Let_def simp del: calc_ideal_point1_cvec_def calc_ideal_point2_cvec_def)
	+ done
	+ thus "Ball (calc_ideal_points_cmat_cvec H) (on_circline_cmat_cvec unit_circle_cmat)"
	+ using on_circline_cmat_cvec_unit
	+ by (auto simp del: on_circline_cmat_cvec_def calc_ideal_points_cmat_cvec_def)
	+qed
	+
	+text \<open>Calculated ideal points are on the h-line\<close>
	+
	+lemma calc_ideal_point1_sq:
	+ assumes "(z1, z2) = calc_ideal_point1_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
	+ shows "z1 * cnj z1 + z2 * cnj z2 = 2 * (B * cnj B)\<^sup>2"
	+proof-
	+ let ?discr = "Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2)"
	+ have "?discr > 0"
	+ using assms
	+ by (simp add: cmod_power2)
	+ have "z1 * cnj z1 = (B * cnj B) * (-A + \<i>sqrt(?discr))(-A - \<i>*sqrt(?discr))"
	+ using assms eq_cnj_iff_real[of A]
	+ by (simp)
	+ also have "... = (B * cnj B) * (A\<^sup>2 + ?discr)"
	+ using complex_of_real_Re[of A] \<open>is_real A\<close> \<open>?discr > 0\<close>
	+ by (simp add: power2_eq_square field_simps)
	+ finally
	+ have "z1 * cnj z1 = (B * cnj B)\<^sup>2"
	+ using complex_of_real_Re[of "(cmod B)\<^sup>2 - (Re A)\<^sup>2"] complex_of_real_Re[of A] \<open>is_real A\<close>
	+ using complex_mult_cnj_cmod[of B]
	+ by (simp add: power2_eq_square)
	+ moreover
	+ have "z2 * cnj z2 = (B * cnj B)\<^sup>2"
	+ using assms
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by simp
	+qed
	+
	+lemma calc_ideal_point2_sq:
	+ assumes "(z1, z2) = calc_ideal_point2_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
	+ shows "z1 * cnj z1 + z2 * cnj z2 = 2 * (B * cnj B)\<^sup>2"
	+proof-
	+ let ?discr = "Re ((cmod B)\<^sup>2 - (Re A)\<^sup>2)"
	+ have "?discr > 0"
	+ using assms
	+ by (simp add: cmod_power2)
	+ have "z1 * cnj z1 = (B * cnj B) * (-A + \<i>sqrt(?discr))(-A - \<i>*sqrt(?discr))"
	+ using assms eq_cnj_iff_real[of A]
	+ by simp
	+ also have "... = (B * cnj B) * (A\<^sup>2 + ?discr)"
	+ using complex_of_real_Re[of A] \<open>is_real A\<close> \<open>?discr > 0\<close>
	+ by (simp add: power2_eq_square field_simps)
	+ finally
	+ have "z1 * cnj z1 = (B * cnj B)\<^sup>2"
	+ using complex_of_real_Re[of "(cmod B)\<^sup>2 - (Re A)\<^sup>2"] complex_of_real_Re[of A] \<open>is_real A\<close>
	+ using complex_mult_cnj_cmod[of B]
	+ by (simp add: power2_eq_square)
	+ moreover
	+ have "z2 * cnj z2 = (B * cnj B)\<^sup>2"
	+ using assms
	+ by simp
	+ ultimately
	+ show ?thesis
	+ by simp
	+qed
	+
	+lemma calc_ideal_point1_mix:
	+ assumes "(z1, z2) = calc_ideal_point1_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
	+ shows "B * cnj z1 * z2 + cnj B * z1 * cnj z2 = - 2 * A * (B * cnj B)\<^sup>2 "
	+proof-
	+ have "Bcnj z1 + cnj Bz1 = -2AB*cnj B"
	+ using assms eq_cnj_iff_real[of A]
	+ by (simp, simp add: field_simps)
	+ moreover
	+ have "cnj z2 = z2"
	+ using assms
	+ by simp
	+ hence "Bcnj z1z2 + cnj Bz1cnj z2 = (Bcnj z1 + cnj Bz1)*z2"
	+ by (simp add: field_simps)
	+ ultimately
	+ have "Bcnj z1z2 + cnj Bz1cnj z2 = -2A(B* cnj B)*z2"
	+ by simp
	+ also have "\<dots> = -2A(B * cnj B)\<^sup>2"
	+ using assms
	+ using complex_mult_cnj_cmod[of B]
	+ by (simp add: power2_eq_square)
	+ finally
	+ show ?thesis
	+ .
	+qed
	+
	+lemma calc_ideal_point2_mix:
	+ assumes "(z1, z2) = calc_ideal_point2_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
	+ shows "B * cnj z1 * z2 + cnj B * z1 * cnj z2 = - 2 * A * (B * cnj B)\<^sup>2 "
	+proof-
	+ have "Bcnj z1 + cnj Bz1 = -2AB*cnj B"
	+ using assms eq_cnj_iff_real[of A]
	+ by (simp, simp add: field_simps)
	+ moreover
	+ have "cnj z2 = z2"
	+ using assms
	+ by simp
	+ hence "Bcnj z1z2 + cnj Bz1cnj z2 = (Bcnj z1 + cnj Bz1)*z2"
	+ by (simp add: field_simps)
	+ ultimately
	+ have "Bcnj z1z2 + cnj Bz1cnj z2 = -2A(B* cnj B)*z2"
	+ by simp
	+ also have "\<dots> = -2A(B * cnj B)\<^sup>2"
	+ using assms
	+ using complex_mult_cnj_cmod[of B]
	+ by (simp add: power2_eq_square)
	+ finally
	+ show ?thesis
	+ .
	+qed
	+
	+lemma calc_ideal_point1_on_circline:
	+ assumes "(z1, z2) = calc_ideal_point1_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
	+ shows "Az1cnj z1 + Bcnj z1z2 + cnj Bz1cnj z2 + Az2cnj z2 = 0" (is "?lhs = 0")
	+proof-
	+ have "?lhs = A * (z1 * cnj z1 + z2 * cnj z2) + (B * cnj z1 * z2 + cnj B * z1 * cnj z2)"
	+ by (simp add: field_simps)
	+ also have "... = 2A(Bcnj B)\<^sup>2 + (-2A(Bcnj B)\<^sup>2)"
	+ using calc_ideal_point1_sq[OF assms]
	+ using calc_ideal_point1_mix[OF assms]
	+ by simp
	+ finally
	+ show ?thesis
	+ by simp
	+qed
	+
	+lemma calc_ideal_point2_on_circline:
	+ assumes "(z1, z2) = calc_ideal_point2_cvec A B" "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
	+ shows "Az1cnj z1 + Bcnj z1z2 + cnj Bz1cnj z2 + Az2cnj z2 = 0" (is "?lhs = 0")
	+proof-
	+ have "?lhs = A * (z1 * cnj z1 + z2 * cnj z2) + (B * cnj z1 * z2 + cnj B * z1 * cnj z2)"
	+ by (simp add: field_simps)
	+ also have "... = 2A(Bcnj B)\<^sup>2 + (-2A(Bcnj B)\<^sup>2)"
	+ using calc_ideal_point2_sq[OF assms]
	+ using calc_ideal_point2_mix[OF assms]
	+ by simp
	+ finally
	+ show ?thesis
	+ by simp
	+qed
	+
	+lemma calc_ideal_points_on_circline:
	+ assumes "is_poincare_line H"
	+ shows "\<forall> z \<in> calc_ideal_points H. z \<in> circline_set H"
	+ using assms
	+ unfolding circline_set_def
	+ apply simp
	+proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero"
	+ obtain A B C D where *: "H = (A, B, C, D)"
	+ by (cases H, auto)
	+ obtain z11 z12 z21 z22 where **: "(z11, z12) = calc_ideal_point1_cvec A B" "(z21, z22) = calc_ideal_point2_cvec A B"
	+ by (cases "calc_ideal_point1_cvec A B", cases "calc_ideal_point2_cvec A B") auto
	+
	+ assume "is_poincare_line_cmat H"
	+ hence "\<forall> (z1, z2) \<in> calc_ideal_points_cmat_cvec H. Az1cnj z1 + Bcnj z1z2 + Cz1cnj z2 + Dz2cnj z2 = 0"
	+ using * ** hh
	+ using hermitean_elems[of A B C D]
	+ using calc_ideal_point1_on_circline[of z11 z12 A B]
	+ using calc_ideal_point2_on_circline[of z21 z22 A B]
	+ by (auto simp del: calc_ideal_point1_cvec_def calc_ideal_point2_cvec_def)
	+ thus "Ball (calc_ideal_points_cmat_cvec H) (on_circline_cmat_cvec H)"
	+ using on_circline_cmat_cvec_circline_equation *
	+ by (auto simp del: on_circline_cmat_cvec_def calc_ideal_points_cmat_cvec_def simp add: field_simps)
	+qed
	+
	+text \<open>Calculated ideal points of an h-line are different\<close>
	+
	+lemma calc_ideal_points_cvec_different [simp]:
	+ assumes "(cmod B)\<^sup>2 > (cmod A)\<^sup>2" "is_real A"
	+ shows "\<not> (calc_ideal_point1_cvec A B \<approx>\<^sub>v calc_ideal_point2_cvec A B)"
	+ using assms
	+ by (auto) (auto simp add: cmod_def)
	+
	+lemma calc_ideal_points_different:
	+ assumes "is_poincare_line H"
	+ shows "\<exists> i1 \<in> (calc_ideal_points H). \<exists> i2 \<in> (calc_ideal_points H). i1 \<noteq> i2"
	+ using assms
	+proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero" "is_poincare_line_cmat H"
	+ obtain A B C D where *: "H = (A, B, C, D)"
	+ by (cases H, auto)
	+ hence "is_real A" using hh hermitean_elems by auto
	+ thus "\<exists>i1\<in>calc_ideal_points_cmat_cvec H. \<exists>i2\<in>calc_ideal_points_cmat_cvec H. \<not> i1 \<approx>\<^sub>v i2"
	+ using * hh calc_ideal_points_cvec_different[of A B]
	+ apply (rule_tac x="calc_ideal_point1_cvec A B" in bexI)
	+ apply (rule_tac x="calc_ideal_point2_cvec A B" in bexI)
	+ by auto
	+qed
	+
	+lemma two_calc_ideal_points [simp]:
	+ assumes "is_poincare_line H"
	+ shows "card (calc_ideal_points H) = 2"
	+proof-
	+ have "\<exists> x \<in> calc_ideal_points H. \<exists> y \<in> calc_ideal_points H. \<forall> z \<in> calc_ideal_points H. z = x \<or> z = y"
	+ by (transfer, transfer, case_tac H, simp del: calc_ideal_point1_cvec_def calc_ideal_point2_cvec_def)
	+ then obtain x y where *: "calc_ideal_points H = {x, y}"
	+ by auto
	+ moreover
	+ have "x \<noteq> y"
	+ using calc_ideal_points_different[OF assms] *
	+ by auto
	+ ultimately
	+ show ?thesis
	+ by auto
	+qed
	+
	+subsubsection \<open>Ideal points\<close>
	+
	+text \<open>Next we give a genuine definition of ideal points -- these are the intersections of the h-line with the unit circle\<close>
	+
	+definition ideal_points :: "circline \<Rightarrow> complex_homo set" where
	+ "ideal_points H = circline_intersection H unit_circle"
	+
	+text \<open>Ideal points are on the unit circle and on the h-line\<close>
	+lemma ideal_points_on_unit_circle:
	+ shows "\<forall> z \<in> ideal_points H. z \<in> circline_set unit_circle"
	+ unfolding ideal_points_def circline_intersection_def circline_set_def
	+ by simp
	+
	+lemma ideal_points_on_circline:
	+ shows "\<forall> z \<in> ideal_points H. z \<in> circline_set H"
	+ unfolding ideal_points_def circline_intersection_def circline_set_def
	+ by simp
	+
	+
	+text \<open>For each h-line there are exactly two ideal points\<close>
	+lemma two_ideal_points:
	+ assumes "is_poincare_line H"
	+ shows "card (ideal_points H) = 2"
	+proof-
	+ have "H \<noteq> unit_circle"
	+ using assms not_is_poincare_line_unit_circle
	+ by auto
	+ let ?int = "circline_intersection H unit_circle"
	+ obtain i1 i2 where "i1 \<in> ?int" "i2 \<in> ?int" "i1 \<noteq> i2"
	+ using calc_ideal_points_on_circline[OF assms]
	+ using calc_ideal_points_on_unit_circle[of H]
	+ using calc_ideal_points_different[OF assms]
	+ unfolding circline_intersection_def circline_set_def
	+ by auto
	+ thus ?thesis
	+ unfolding ideal_points_def
	+ using circline_intersection_at_most_2_points[OF \<open>H \<noteq> unit_circle\<close>]
	+ using card_geq_2_iff_contains_2_elems[of ?int]
	+ by auto
	+qed
	+
	+text \<open>They are exactly the two points that our calculation finds\<close>
	+lemma ideal_points_unique:
	+ assumes "is_poincare_line H"
	+ shows "ideal_points H = calc_ideal_points H"
	+proof-
	+ have "calc_ideal_points H \<subseteq> ideal_points H"
	+ using calc_ideal_points_on_circline[OF assms]
	+ using calc_ideal_points_on_unit_circle[of H]
	+ unfolding ideal_points_def circline_intersection_def circline_set_def
	+ by auto
	+ moreover
	+ have "H \<noteq> unit_circle"
	+ using not_is_poincare_line_unit_circle assms
	+ by auto
	+ hence "finite (ideal_points H)"
	+ using circline_intersection_at_most_2_points[of H unit_circle]
	+ unfolding ideal_points_def
	+ by auto
	+ ultimately
	+ show ?thesis
	+ using card_subset_eq[of "ideal_points H" "calc_ideal_points H"]
	+ using two_calc_ideal_points[OF assms]
	+ using two_ideal_points[OF assms]
	+ by auto
	+qed
	+
	+text \<open>For each h-line we can obtain two different ideal points\<close>
	+lemma obtain_ideal_points:
	+ assumes "is_poincare_line H"
	+ obtains i1 i2 where "i1 \<noteq> i2" "ideal_points H = {i1, i2}"
	+ using two_ideal_points[OF assms] card_eq_2_iff_doubleton[of "ideal_points H"]
	+ by blast
	+
	+text \<open>Ideal points of each h-line constructed from two points in the disc are different than those two points\<close>
	+lemma ideal_points_different:
	+ assumes "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ assumes "ideal_points (poincare_line u v) = {i1, i2}"
	+ shows "i1 \<noteq> i2" "u \<noteq> i1" "u \<noteq> i2" "v \<noteq> i1" "v \<noteq> i2"
	+proof-
	+ have "i1 \<in> ocircline_set ounit_circle" "i2 \<in> ocircline_set ounit_circle"
	+ using assms(3) assms(4) ideal_points_on_unit_circle is_poincare_line_poincare_line
	+ by fastforce+
	+ thus "u \<noteq> i1" "u \<noteq> i2" "v \<noteq> i1" "v \<noteq> i2"
	+ using assms(1-2)
	+ using disc_inter_ocircline_set[of ounit_circle]
	+ unfolding unit_disc_def
	+ by auto
	+ show "i1 \<noteq> i2"
	+ using assms
	+ by (metis doubleton_eq_iff is_poincare_line_poincare_line obtain_ideal_points)
	+qed
	+
	+text \<open>H-line is uniquely determined by its ideal points\<close>
	+lemma ideal_points_line_unique:
	+ assumes "is_poincare_line H" "ideal_points H = {i1, i2}"
	+ shows "H = poincare_line i1 i2"
	+ by (smt assms(1) assms(2) calc_ideal_points_on_unit_circle circline_set_def ex_poincare_line_points ideal_points_different(1) ideal_points_on_circline ideal_points_unique insertI1 insert_commute inversion_unit_circle mem_Collect_eq unique_poincare_line_general)
	+
	+text \<open>Ideal points of some special h-lines\<close>
	+
	+text\<open>Ideal points of @{term x_axis}\<close>
	+lemma ideal_points_x_axis
	+ [simp]: "ideal_points x_axis = {of_complex (-1), of_complex 1}"
	+proof (subst ideal_points_unique, simp)
	+ have "calc_ideal_points_clmat_hcoords x_axis_clmat = {of_complex_hcoords (- 1), of_complex_hcoords 1}"
	+ by transfer auto
	+ thus "calc_ideal_points x_axis = {of_complex (- 1), of_complex 1}"
	+ by (simp add: calc_ideal_points.abs_eq of_complex.abs_eq x_axis_def)
	+qed
	+
	+text \<open>Ideal points are proportional vectors only if h-line is a line segment passing trough zero\<close>
	+lemma ideal_points_proportional:
	+ assumes "is_poincare_line H" "ideal_points H = {i1, i2}" "to_complex i1 = cor k * to_complex i2"
	+ shows "0\<^sub>h \<in> circline_set H"
	+proof-
	+ have "i1 \<noteq> i2"
	+ using `ideal_points H = {i1, i2}`
	+ using `is_poincare_line H` ex_poincare_line_points ideal_points_different(1) by blast
	+
	+ have "i1 \<in> circline_set unit_circle" "i2 \<in> circline_set unit_circle"
	+ using assms calc_ideal_points_on_unit_circle ideal_points_unique
	+ by blast+
	+
	+ hence "cmod (cor k) = 1"
	+ using `to_complex i1 = cor k * to_complex i2`
	+ by (metis (mono_tags, lifting) circline_set_unit_circle imageE mem_Collect_eq mult.right_neutral norm_mult to_complex_of_complex unit_circle_set_def)
	+ hence "k = -1"
	+ using `to_complex i1 = cor k * to_complex i2` `i1 \<noteq> i2`
	+ using \<open>i1 \<in> circline_set unit_circle\<close> \<open>i2 \<in> circline_set unit_circle\<close>
	+ by (metis (no_types, lifting) circline_set_unit_circle complex_cnj_complex_of_real complex_mult_cnj_cmod cor_neg_one imageE mult_cancel_right2 norm_one of_real_eq_iff square_eq_1_iff to_complex_of_complex)
	+
	+ have "\<forall> i1 \<in> calc_ideal_points H. \<forall> i2 \<in> calc_ideal_points H. is_poincare_line H \<and> i1 \<noteq> i2 \<and> to_complex i1 = - to_complex i2 \<longrightarrow>
	+ 0\<^sub>h \<in> circline_set H"
	+ unfolding circline_set_def
	+ proof (simp, transfer, transfer, safe)
	+ fix A B C D i11 i12 i21 i22 k
	+ assume H:"hermitean (A, B, C, D)" "(A, B, C, D) \<noteq> mat_zero"
	+ assume line: "is_poincare_line_cmat (A, B, C, D)"
	+ assume i1: "(i11, i12) \<in> calc_ideal_points_cmat_cvec (A, B, C, D)"
	+ assume i2:"(i21, i22) \<in> calc_ideal_points_cmat_cvec (A, B, C, D)"
	+ assume "\<not> (i11, i12) \<approx>\<^sub>v (i21, i22)"
	+ assume opposite: "to_complex_cvec (i11, i12) = - to_complex_cvec (i21, i22)"
	+
	+
	+ let ?discr = "sqrt ((cmod B)\<^sup>2 - (Re D)\<^sup>2)"
	+ let ?den = "(cmod B)\<^sup>2"
	+ let ?i1 = "B * (- D - \<i> * ?discr)"
	+ let ?i2 = "B * (- D + \<i> * ?discr)"
	+
	+ have "i11 = ?i1 \<or> i11 = ?i2" "i12 = ?den"
	+ "i21 = ?i1 \<or> i21 = ?i2" "i22 = ?den"
	+ using i1 i2 H line
	+ by (auto split: if_split_asm)
	+ hence i: "i11 = ?i1 \<and> i21 = ?i2 \<or> i11 = ?i2 \<and> i21 = ?i1"
	+ using `\<not> (i11, i12) \<approx>\<^sub>v (i21, i22)`
	+ by auto
	+
	+ have "?den \<noteq> 0"
	+ using line
	+ by auto
	+
	+ hence "i11 = - i21"
	+ using opposite `i12 = ?den` `i22 = ?den`
	+ by (simp add: nonzero_neg_divide_eq_eq2)
	+
	+ hence "?i1 = - ?i2"
	+ using i
	+ by (metis add.inverse_inverse)
	+
	+ hence "D = 0"
	+ using `?den \<noteq> 0`
	+ by (simp add: field_simps)
	+
	+ thus "on_circline_cmat_cvec (A, B, C, D) 0\<^sub>v"
	+ by (simp add: vec_cnj_def)
	+ qed
	+
	+ thus ?thesis
	+ using assms `k = -1`
	+ using calc_ideal_points_different ideal_points_unique
	+ by fastforce
	+qed
	+
	+text \<open>Transformations of ideal points\<close>
	+
	+text \<open>Möbius transformations that fix the unit disc when acting on h-lines map their ideal points to ideal points.\<close>
	+lemma ideal_points_moebius_circline [simp]:
	+ assumes "unit_circle_fix M" "is_poincare_line H"
	+ shows "ideal_points (moebius_circline M H) = (moebius_pt M) ` (ideal_points H)" (is "?I' = ?M ` ?I")
	+proof-
	+ obtain i1 i2 where *: "i1 \<noteq> i2" "?I = {i1, i2}"
	+ using assms(2)
	+ by (rule obtain_ideal_points)
	+ let ?Mi1 = "?M i1" and ?Mi2 = "?M i2"
	+ have "?Mi1 \<in> ?M ` (circline_set H)"
	+ "?Mi2 \<in> ?M ` (circline_set H)"
	+ "?Mi1 \<in> ?M ` (circline_set unit_circle)"
	+ "?Mi2 \<in> ?M ` (circline_set unit_circle)"
	+ using *
	+ unfolding ideal_points_def circline_intersection_def circline_set_def
	+ by blast+
	+ hence "?Mi1 \<in> ?I'"
	+ "?Mi2 \<in> ?I'"
	+ using unit_circle_fix_iff[of M] assms
	+ unfolding ideal_points_def circline_intersection_def circline_set_def
	+ by (metis mem_Collect_eq moebius_circline)+
	+ moreover
	+ have "?Mi1 \<noteq> ?Mi2"
	+ using bij_moebius_pt[of M] *
	+ using moebius_pt_invert by blast
	+ moreover
	+ have "is_poincare_line (moebius_circline M H)"
	+ using assms unit_circle_fix_preserve_is_poincare_line
	+ by simp
	+ ultimately
	+ have "?I' = {?Mi1, ?Mi2}"
	+ using two_ideal_points[of "moebius_circline M H"]
	+ using card_eq_2_doubleton[of ?I' ?Mi1 ?Mi2]
	+ by simp
	+ thus ?thesis
	+ using *(2)
	+ by auto
	+qed
	+
	+lemma ideal_points_poincare_line_moebius [simp]:
	+ assumes "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ assumes "ideal_points (poincare_line u v) = {i1, i2}"
	+ shows "ideal_points (poincare_line (moebius_pt M u) (moebius_pt M v)) = {moebius_pt M i1, moebius_pt M i2}"
	+ using assms
	+ by auto
	+
	+text \<open>Conjugation also maps ideal points to ideal points\<close>
	+lemma ideal_points_conjugate [simp]:
	+ assumes "is_poincare_line H"
	+ shows "ideal_points (conjugate_circline H) = conjugate ` (ideal_points H)" (is "?I' = ?M ` ?I")
	+proof-
	+ obtain i1 i2 where *: "i1 \<noteq> i2" "?I = {i1, i2}"
	+ using assms
	+ by (rule obtain_ideal_points)
	+ let ?Mi1 = "?M i1" and ?Mi2 = "?M i2"
	+ have "?Mi1 \<in> ?M ` (circline_set H)"
	+ "?Mi2 \<in> ?M ` (circline_set H)"
	+ "?Mi1 \<in> ?M ` (circline_set unit_circle)"
	+ "?Mi2 \<in> ?M ` (circline_set unit_circle)"
	+ using *
	+ unfolding ideal_points_def circline_intersection_def circline_set_def
	+ by blast+
	+ hence "?Mi1 \<in> ?I'"
	+ "?Mi2 \<in> ?I'"
	+ unfolding ideal_points_def circline_intersection_def circline_set_def
	+ using circline_set_conjugate_circline circline_set_def conjugate_unit_circle_set
	+ by blast+
	+ moreover
	+ have "?Mi1 \<noteq> ?Mi2"
	+ using \<open>i1 \<noteq> i2\<close>
	+ by (auto simp add: conjugate_inj)
	+ moreover
	+ have "is_poincare_line (conjugate_circline H)"
	+ using assms
	+ by simp
	+ ultimately
	+ have "?I' = {?Mi1, ?Mi2}"
	+ using two_ideal_points[of "conjugate_circline H"]
	+ using card_eq_2_doubleton[of ?I' ?Mi1 ?Mi2]
	+ by simp
	+ thus ?thesis
	+ using *(2)
	+ by auto
	+qed
	+
	+lemma ideal_points_poincare_line_conjugate [simp]:
	+ assumes"u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ assumes "ideal_points (poincare_line u v) = {i1, i2}"
	+ shows "ideal_points (poincare_line (conjugate u) (conjugate v)) = {conjugate i1, conjugate i2}"
	+ using assms
	+ by auto
	+
	+end
	diff --git a/thys/Poincare_Disc/Poincare_Perpendicular.thy b/thys/Poincare_Disc/Poincare_Perpendicular.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Poincare_Perpendicular.thy
	@@ -0,0 +1,637 @@
	+theory Poincare_Perpendicular
	+ imports Poincare_Lines_Axis_Intersections
	+begin
	+
	+(* ------------------------------------------------------------------ *)
	+section\<open>H-perpendicular h-lines in the Poincar\'e model\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+definition perpendicular_to_x_axis_cmat :: "complex_mat \<Rightarrow> bool" where
	+ [simp]: "perpendicular_to_x_axis_cmat H \<longleftrightarrow> (let (A, B, C, D) = H in is_real B)"
	+
	+lift_definition perpendicular_to_x_axis_clmat :: "circline_mat \<Rightarrow> bool" is perpendicular_to_x_axis_cmat
	+ done
	+
	+lift_definition perpendicular_to_x_axis :: "circline \<Rightarrow> bool" is perpendicular_to_x_axis_clmat
	+ by transfer auto
	+
	+lemma perpendicular_to_x_axis:
	+ assumes "is_poincare_line H"
	+ shows "perpendicular_to_x_axis H \<longleftrightarrow> perpendicular x_axis H"
	+ using assms
	+ unfolding perpendicular_def
	+proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero" "is_poincare_line_cmat H"
	+ obtain A B C D where *: "H = (A, B, C, D)"
	+ by (cases H, auto)
	+ hence "is_real A" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2" "H = (A, B, cnj B, A)"
	+ using hermitean_elems[of A B C D] hh
	+ by auto
	+ thus "perpendicular_to_x_axis_cmat H =
	+ (cos_angle_cmat (of_circline_cmat x_axis_cmat) (of_circline_cmat H) = 0)"
	+ using cmod_square[of B] cmod_square[of A]
	+ by simp
	+qed
	+
	+lemma perpendicular_to_x_axis_y_axis:
	+ assumes "perpendicular_to_x_axis (poincare_line 0\<^sub>h (of_complex z))" "z \<noteq> 0"
	+ shows "is_imag z"
	+ using assms
	+ by (transfer, transfer, simp)
	+
	+
	+lemma wlog_perpendicular_axes:
	+ assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "z \<in> unit_disc"
	+ assumes perpendicular: "is_poincare_line H1" "is_poincare_line H2" "perpendicular H1 H2"
	+ assumes "z \<in> circline_set H1 \<inter> circline_set H2" "u \<in> circline_set H1" "v \<in> circline_set H2"
	+ assumes axes: "\<And> x y. \<lbrakk>is_real x; 0 \<le> Re x; Re x < 1; is_imag y; 0 \<le> Im y; Im y < 1\<rbrakk> \<Longrightarrow> P 0\<^sub>h (of_complex x) (of_complex y)"
	+ assumes moebius: "\<And> M u v w. \<lbrakk>unit_disc_fix M; u \<in> unit_disc; v \<in> unit_disc; w \<in> unit_disc; P (moebius_pt M u) (moebius_pt M v) (moebius_pt M w) \<rbrakk> \<Longrightarrow> P u v w"
	+ assumes conjugate: "\<And> u v w. \<lbrakk>u \<in> unit_disc; v \<in> unit_disc; w \<in> unit_disc; P (conjugate u) (conjugate v) (conjugate w) \<rbrakk> \<Longrightarrow> P u v w"
	+ shows "P z u v"
	+proof-
	+ have "\<forall> v H1 H2. is_poincare_line H1 \<and> is_poincare_line H2 \<and> perpendicular H1 H2 \<and>
	+ z \<in> circline_set H1 \<inter> circline_set H2 \<and> u \<in> circline_set H1 \<and> v \<in> circline_set H2 \<and> v \<in> unit_disc \<longrightarrow> P z u v" (is "?P z u")
	+ proof (rule wlog_x_axis[where P="?P"])
	+ fix x
	+ assume x: "is_real x" "Re x \<ge> 0" "Re x < 1"
	+ have "of_complex x \<in> unit_disc"
	+ using x
	+ by (simp add: cmod_eq_Re)
	+
	+ show "?P 0\<^sub>h (of_complex x)"
	+ proof safe
	+ fix v H1 H2
	+ assume "v \<in> unit_disc"
	+ then obtain y where y: "v = of_complex y"
	+ using inf_or_of_complex[of v]
	+ by auto
	+
	+ assume 1: "is_poincare_line H1" "is_poincare_line H2" "perpendicular H1 H2"
	+ assume 2: "0\<^sub>h \<in> circline_set H1" "0\<^sub>h \<in> circline_set H2" "of_complex x \<in> circline_set H1" "v \<in> circline_set H2"
	+
	+ show "P 0\<^sub>h (of_complex x) v"
	+ proof (cases "of_complex x = 0\<^sub>h")
	+ case True
	+ show "P 0\<^sub>h (of_complex x) v"
	+ proof (cases "v = 0\<^sub>h")
	+ case True
	+ thus ?thesis
	+ using \<open>of_complex x = 0\<^sub>h\<close>
	+ using axes[of 0 0]
	+ by simp
	+ next
	+ case False
	+ show ?thesis
	+ proof (rule wlog_rotation_to_positive_y_axis)
	+ show "v \<in> unit_disc" "v \<noteq> 0\<^sub>h"
	+ by fact+
	+ next
	+ fix y
	+ assume "is_imag y" "0 < Im y" "Im y < 1"
	+ thus "P 0\<^sub>h (of_complex x) (of_complex y)"
	+ using x axes[of x y]
	+ by simp
	+ next
	+ fix \<phi> u
	+ assume "u \<in> unit_disc" "u \<noteq> 0\<^sub>h"
	+ "P 0\<^sub>h (of_complex x) (moebius_pt (moebius_rotation \<phi>) u)"
	+ thus "P 0\<^sub>h (of_complex x) u"
	+ using \<open>of_complex x = 0\<^sub>h\<close>
	+ using moebius[of "moebius_rotation \<phi>" "0\<^sub>h" "0\<^sub>h" u]
	+ by simp
	+ qed
	+ qed
	+ next
	+ case False
	+ hence *: "poincare_line 0\<^sub>h (of_complex x) = x_axis"
	+ using x poincare_line_0_real_is_x_axis[of "of_complex x"]
	+ unfolding circline_set_x_axis
	+ by auto
	+ hence "H1 = x_axis"
	+ using unique_poincare_line[of "0\<^sub>h" "of_complex x" H1] 1 2
	+ using \<open>of_complex x \<in> unit_disc\<close> False
	+ by simp
	+ have "is_imag y"
	+ proof (cases "y = 0")
	+ case True
	+ thus ?thesis
	+ by simp
	+ next
	+ case False
	+ hence "0\<^sub>h \<noteq> of_complex y"
	+ using of_complex_zero_iff[of y]
	+ by metis
	+ hence "H2 = poincare_line 0\<^sub>h (of_complex y)"
	+ using 1 2 \<open>v \<in> unit_disc\<close>
	+ using unique_poincare_line[of "0\<^sub>h" "of_complex y" H2] y
	+ by simp
	+ thus ?thesis
	+ using 1 \<open>H1 = x_axis\<close>
	+ using perpendicular_to_x_axis_y_axis[of y] False
	+ using perpendicular_to_x_axis[of H2]
	+ by simp
	+ qed
	+ show "P 0\<^sub>h (of_complex x) v"
	+ proof (cases "Im y \<ge> 0")
	+ case True
	+ thus ?thesis
	+ using axes[of x y] x y \<open>is_imag y\<close> \<open>v \<in> unit_disc\<close>
	+ by (simp add: cmod_eq_Im)
	+ next
	+ case False
	+ show ?thesis
	+ proof (rule conjugate)
	+ have "Im (cnj y) < 1"
	+ using \<open>v \<in> unit_disc\<close> y \<open>is_imag y\<close> eq_minus_cnj_iff_imag[of y]
	+ by (simp add: cmod_eq_Im)
	+ thus "P (conjugate 0\<^sub>h) (conjugate (of_complex x)) (conjugate v)"
	+ using \<open>is_real x\<close> eq_cnj_iff_real[of x] y \<open>is_imag y\<close>
	+ using axes[OF x, of "cnj y"] False
	+ by simp
	+ show "0\<^sub>h \<in> unit_disc" "of_complex x \<in> unit_disc" "v \<in> unit_disc"
	+ by (simp, fact+)
	+ qed
	+ qed
	+ qed
	+ qed
	+ next
	+ show "z \<in> unit_disc" "u \<in> unit_disc"
	+ by fact+
	+ next
	+ fix M u v
	+ assume *: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc"
	+ assume **: "?P (moebius_pt M u) (moebius_pt M v)"
	+ show "?P u v"
	+ proof safe
	+ fix w H1 H2
	+ assume ***: "is_poincare_line H1" "is_poincare_line H2" "perpendicular H1 H2"
	+ "u \<in> circline_set H1" "u \<in> circline_set H2"
	+ "v \<in> circline_set H1" "w \<in> circline_set H2" "w \<in> unit_disc"
	+ thus "P u v w"
	+ using moebius[of M u v w] *
	+ using **[rule_format, of "moebius_circline M H1" "moebius_circline M H2" "moebius_pt M w"]
	+ by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms
	+ by blast
	+qed
	+
	+lemma wlog_perpendicular_foot:
	+ assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc" "z \<in> unit_disc"
	+ assumes perpendicular: "u \<noteq> v" "is_poincare_line H" "perpendicular (poincare_line u v) H"
	+ assumes "z \<in> circline_set (poincare_line u v) \<inter> circline_set H" "w \<in> circline_set H"
	+ assumes axes: "\<And> u v w. \<lbrakk>is_real u; 0 < Re u; Re u < 1; is_real v; -1 < Re v; Re v < 1; Re u \<noteq> Re v; is_imag w; 0 \<le> Im w; Im w < 1\<rbrakk> \<Longrightarrow> P 0\<^sub>h (of_complex u) (of_complex v) (of_complex w)"
	+ assumes moebius: "\<And> M z u v w. \<lbrakk>unit_disc_fix M; u \<in> unit_disc; v \<in> unit_disc; w \<in> unit_disc; z \<in> unit_disc; P (moebius_pt M z) (moebius_pt M u) (moebius_pt M v) (moebius_pt M w) \<rbrakk> \<Longrightarrow> P z u v w"
	+ assumes conjugate: "\<And> z u v w. \<lbrakk>u \<in> unit_disc; v \<in> unit_disc; w \<in> unit_disc; P (conjugate z) (conjugate u) (conjugate v) (conjugate w) \<rbrakk> \<Longrightarrow> P z u v w"
	+ assumes perm: "P z v u w \<Longrightarrow> P z u v w"
	+ shows "P z u v w"
	+proof-
	+ obtain m n where mn: "m = u \<or> m = v" "n = u \<or> n = v" "m \<noteq> n" "m \<noteq> z"
	+ using \<open>u \<noteq> v\<close>
	+ by auto
	+
	+ have "n \<in> circline_set (poincare_line z m)"
	+ using \<open>z \<in> circline_set (poincare_line u v) \<inter> circline_set H\<close>
	+ using mn
	+ using unique_poincare_line[of z m "poincare_line u v", symmetric] in_disc
	+ by auto
	+
	+ have "\<forall> n. n \<in> unit_disc \<and> m \<noteq> n \<and> n \<in> circline_set (poincare_line z m) \<and> m \<noteq> z \<longrightarrow> P z m n w" (is "?Q z m w")
	+ proof (rule wlog_perpendicular_axes[where P="?Q"])
	+ show "is_poincare_line (poincare_line u v)"
	+ using \<open>u \<noteq> v\<close>
	+ by auto
	+ next
	+ show "is_poincare_line H"
	+ by fact
	+ next
	+ show "m \<in> unit_disc" "m \<in> circline_set (poincare_line u v)"
	+ using mn in_disc
	+ by auto
	+ next
	+ show "w \<in> unit_disc" "z \<in> unit_disc"
	+ by fact+
	+ next
	+ show "z \<in> circline_set (poincare_line u v) \<inter> circline_set H"
	+ by fact
	+ next
	+ show "perpendicular (poincare_line u v) H"
	+ by fact
	+ next
	+ show "w \<in> circline_set H"
	+ by fact
	+ next
	+ fix x y
	+ assume xy: "is_real x" "0 \<le> Re x" "Re x < 1" "is_imag y" "0 \<le> Im y" "Im y < 1"
	+ show "?Q 0\<^sub>h (of_complex x) (of_complex y)"
	+ proof safe
	+ fix n
	+ assume "n \<in> unit_disc" "of_complex x \<noteq> n"
	+ assume "n \<in> circline_set (poincare_line 0\<^sub>h (of_complex x))" "of_complex x \<noteq> 0\<^sub>h"
	+ hence "n \<in> circline_set x_axis"
	+ using poincare_line_0_real_is_x_axis[of "of_complex x"] xy
	+ by (auto simp add: circline_set_x_axis)
	+ then obtain n' where n': "n = of_complex n'"
	+ using inf_or_of_complex[of n] \<open>n \<in> unit_disc\<close>
	+ by auto
	+ hence "is_real n'"
	+ using \<open>n \<in> circline_set x_axis\<close>
	+ using of_complex_inj
	+ unfolding circline_set_x_axis
	+ by auto
	+ hence "-1 < Re n'" "Re n' < 1"
	+ using \<open>n \<in> unit_disc\<close> n'
	+ by (auto simp add: cmod_eq_Re)
	+
	+ have "Re n' \<noteq> Re x"
	+ using complex.expand[of n' x] \<open>is_real n'\<close> \<open>is_real x\<close> \<open>of_complex x \<noteq> n\<close> n'
	+ by auto
	+
	+ have "Re x > 0"
	+ using xy \<open>of_complex x \<noteq> 0\<^sub>h\<close>
	+ by (cases "Re x = 0", auto simp add: complex.expand)
	+
	+ show "P 0\<^sub>h (of_complex x) n (of_complex y)"
	+ using axes[of x n' y] xy n' \<open>Re x > 0\<close> \<open>is_real n'\<close> \<open>-1 < Re n'\<close> \<open>Re n' < 1\<close> \<open>Re n' \<noteq> Re x\<close>
	+ by simp
	+ qed
	+ next
	+ fix M u v w
	+ assume 1: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
	+ assume 2: "?Q (moebius_pt M u) (moebius_pt M v) (moebius_pt M w)"
	+ show "?Q u v w"
	+ proof safe
	+ fix n
	+ assume "n \<in> unit_disc" "v \<noteq> n" "n \<in> circline_set (poincare_line u v)" "v \<noteq> u"
	+ thus "P u v n w"
	+ using moebius[of M v n w u] 1 2[rule_format, of "moebius_pt M n"]
	+ by fastforce
	+ qed
	+ next
	+ fix u v w
	+ assume 1: "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
	+ assume 2: "?Q (conjugate u) (conjugate v) (conjugate w)"
	+ show "?Q u v w"
	+ proof safe
	+ fix n
	+ assume "n \<in> unit_disc" "v \<noteq> n" "n \<in> circline_set (poincare_line u v)" "v \<noteq> u"
	+ thus "P u v n w"
	+ using conjugate[of v n w u] 1 2[rule_format, of "conjugate n"]
	+ using conjugate_inj
	+ by auto
	+ qed
	+ qed
	+ thus ?thesis
	+ using mn in_disc \<open>n \<in> circline_set (poincare_line z m)\<close> perm
	+ by auto
	+qed
	+
	+lemma perpendicular_to_x_axis_intersects_x_axis:
	+ assumes "is_poincare_line H" "perpendicular_to_x_axis H"
	+ shows "intersects_x_axis H"
	+ using assms hermitean_elems
	+ by (transfer, transfer, auto simp add: cmod_eq_Re)
	+
	+
	+lemma perpendicular_intersects:
	+ assumes "is_poincare_line H1" "is_poincare_line H2"
	+ assumes "perpendicular H1 H2"
	+ shows "\<exists> z. z \<in> unit_disc \<and> z \<in> circline_set H1 \<inter> circline_set H2" (is "?P' H1 H2")
	+proof-
	+ have "\<forall> H2. is_poincare_line H2 \<and> perpendicular H1 H2 \<longrightarrow> ?P' H1 H2" (is "?P H1")
	+ proof (rule wlog_line_x_axis)
	+ show "?P x_axis"
	+ proof safe
	+ fix H2
	+ assume "is_poincare_line H2" "perpendicular x_axis H2"
	+ thus "\<exists>z. z \<in> unit_disc \<and> z \<in> circline_set x_axis \<inter> circline_set H2"
	+ using perpendicular_to_x_axis[of H2]
	+ using perpendicular_to_x_axis_intersects_x_axis[of H2]
	+ using intersects_x_axis_iff[of H2]
	+ by auto
	+ qed
	+ next
	+ fix M
	+ assume "unit_disc_fix M"
	+ assume *: "?P (moebius_circline M H1)"
	+ show "?P H1"
	+ proof safe
	+ fix H2
	+ assume "is_poincare_line H2" "perpendicular H1 H2"
	+ then obtain z where "z \<in> unit_disc" "z \<in> circline_set (moebius_circline M H1) \<and> z \<in> circline_set (moebius_circline M H2)"
	+ using *[rule_format, of "moebius_circline M H2"] \<open>unit_disc_fix M\<close>
	+ by auto
	+ thus "\<exists>z. z \<in> unit_disc \<and> z \<in> circline_set H1 \<inter> circline_set H2"
	+ using \<open>unit_disc_fix M\<close>
	+ by (rule_tac x="moebius_pt (-M) z" in exI)
	+ (metis IntI add.inverse_inverse circline_set_moebius_circline_iff moebius_pt_comp_inv_left uminus_moebius_def unit_disc_fix_discI unit_disc_fix_moebius_uminus)
	+ qed
	+ next
	+ show "is_poincare_line H1"
	+ by fact
	+ qed
	+ thus ?thesis
	+ using assms
	+ by auto
	+qed
	+
	+
	+definition calc_perpendicular_to_x_axis_cmat :: "complex_vec \<Rightarrow> complex_mat" where
	+ [simp]: "calc_perpendicular_to_x_axis_cmat z =
	+ (let (z1, z2) = z
	+ in if z1cnj z2 + z2cnj z1 = 0 then
	+ (0, 1, 1, 0)
	+ else
	+ let A = z1cnj z2 + z2cnj z1;
	+ B = -(z1cnj z1 + z2cnj z2)
	+ in (A, B, B, A)
	+ )"
	+
	+lift_definition calc_perpendicular_to_x_axis_clmat :: "complex_homo_coords \<Rightarrow> circline_mat" is calc_perpendicular_to_x_axis_cmat
	+ by (auto simp add: hermitean_def mat_adj_def mat_cnj_def Let_def split: if_split_asm)
	+
	+lift_definition calc_perpendicular_to_x_axis :: "complex_homo \<Rightarrow> circline" is calc_perpendicular_to_x_axis_clmat
	+proof (transfer)
	+ fix z w
	+ assume "z \<noteq> vec_zero" "w \<noteq> vec_zero"
	+ obtain z1 z2 w1 w2 where zw: "z = (z1, z2)" "w = (w1, w2)"
	+ by (cases z, cases w, auto)
	+ assume "z \<approx>\<^sub>v w"
	+ then obtain k where : "k \<noteq> 0" "w1 = kz1" "w2 = k*z2"
	+ using zw
	+ by auto
	+ have "w1 * cnj w2 + w2 * cnj w1 = (k * cnj k) * (z1 * cnj z2 + z2 * cnj z1)"
	+ using *
	+ by (auto simp add: field_simps)
	+ moreover
	+ have "w1 * cnj w1 + w2 * cnj w2 = (k * cnj k) * (z1 * cnj z1 + z2 * cnj z2)"
	+ using *
	+ by (auto simp add: field_simps)
	+ ultimately
	+ show "circline_eq_cmat (calc_perpendicular_to_x_axis_cmat z) (calc_perpendicular_to_x_axis_cmat w)"
	+ using zw *
	+ apply (auto simp add: Let_def)
	+ apply (rule_tac x="Re (k * cnj k)" in exI, auto simp add: complex.expand field_simps)
	+ done
	+qed
	+
	+lemma calc_perpendicular_to_x_axis:
	+ assumes "z \<noteq> of_complex 1" "z \<noteq> of_complex (-1)"
	+ shows "z \<in> circline_set (calc_perpendicular_to_x_axis z) \<and>
	+ is_poincare_line (calc_perpendicular_to_x_axis z) \<and>
	+ perpendicular_to_x_axis (calc_perpendicular_to_x_axis z)"
	+ using assms
	+ unfolding circline_set_def perpendicular_def
	+proof (simp, transfer, transfer)
	+ fix z :: complex_vec
	+ obtain z1 z2 where z: "z = (z1, z2)"
	+ by (cases z, auto)
	+ assume **: "\<not> z \<approx>\<^sub>v of_complex_cvec 1" "\<not> z \<approx>\<^sub>v of_complex_cvec (- 1)"
	+ show "on_circline_cmat_cvec (calc_perpendicular_to_x_axis_cmat z) z \<and>
	+ is_poincare_line_cmat (calc_perpendicular_to_x_axis_cmat z) \<and>
	+ perpendicular_to_x_axis_cmat (calc_perpendicular_to_x_axis_cmat z)"
	+ proof (cases "z1cnj z2 + z2cnj z1 = 0")
	+ case True
	+ thus ?thesis
	+ using z
	+ by (simp add: vec_cnj_def hermitean_def mat_adj_def mat_cnj_def mult.commute)
	+ next
	+ case False
	+ hence "z2 \<noteq> 0"
	+ using z
	+ by auto
	+ hence "Re (z2 * cnj z2) \<noteq> 0"
	+ using \<open>z2 \<noteq> 0\<close>
	+ by (auto simp add: complex.expand)
	+
	+ have "z1 \<noteq> -z2 \<and> z1 \<noteq> z2"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "z \<approx>\<^sub>v of_complex_cvec 1 \<or> z \<approx>\<^sub>v of_complex_cvec (-1)"
	+ using z \<open>z2 \<noteq> 0\<close>
	+ by auto
	+ thus False
	+ using **
	+ by auto
	+ qed
	+
	+ let ?A = "z1cnj z2 + z2cnj z1" and ?B = "-(z1cnj z1 + z2cnj z2)"
	+ have "Re(z1cnj z1 + z2cnj z2) \<ge> 0"
	+ by auto
	+ hence "Re ?B \<le> 0"
	+ by (smt uminus_complex.simps(1))
	+ hence "abs (Re ?B) = - Re ?B"
	+ by auto
	+ also have "... = (Re z1)\<^sup>2 + (Im z1)\<^sup>2 + (Re z2)\<^sup>2 + (Im z2)\<^sup>2"
	+ by (simp add: power2_eq_square[symmetric])
	+ also have "... > abs (Re ?A)"
	+ proof (cases "Re ?A \<ge> 0")
	+ case False
	+ have "(Re z1 + Re z2)\<^sup>2 + (Im z1 + Im z2)\<^sup>2 > 0"
	+ using \<open>z1 \<noteq> -z2 \<and> z1 \<noteq> z2\<close>
	+ by (metis add.commute add.inverse_unique complex_neq_0 plus_complex.code plus_complex.simps)
	+ thus ?thesis
	+ using False
	+ by (simp add: power2_sum power2_eq_square field_simps)
	+ next
	+ case True
	+ have "(Re z1 - Re z2)\<^sup>2 + (Im z1 - Im z2)\<^sup>2 > 0"
	+ using \<open>z1 \<noteq> -z2 \<and> z1 \<noteq> z2\<close>
	+ by (meson complex_eq_iff right_minus_eq sum_power2_gt_zero_iff)
	+ thus ?thesis
	+ using True
	+ by (simp add: power2_sum power2_eq_square field_simps)
	+ qed
	+ finally
	+ have "abs (Re ?B) > abs (Re ?A)"
	+ .
	+ moreover
	+ have "cmod ?B = abs (Re ?B)" "cmod ?A = abs (Re ?A)"
	+ by (simp_all add: cmod_eq_Re)
	+ ultimately
	+ have "(cmod ?B)\<^sup>2 > (cmod ?A)\<^sup>2"
	+ by (smt power2_le_imp_le)
	+ thus ?thesis
	+ using z False
	+ by (simp_all add: Let_def hermitean_def mat_adj_def mat_cnj_def cmod_eq_Re vec_cnj_def field_simps)
	+ qed
	+qed
	+
	+lemma ex_perpendicular:
	+ assumes "is_poincare_line H" "z \<in> unit_disc"
	+ shows "\<exists> H'. is_poincare_line H' \<and> perpendicular H H' \<and> z \<in> circline_set H'" (is "?P' H z")
	+proof-
	+ have "\<forall> z. z \<in> unit_disc \<longrightarrow> ?P' H z" (is "?P H")
	+ proof (rule wlog_line_x_axis)
	+ show "?P x_axis"
	+ proof safe
	+ fix z
	+ assume "z \<in> unit_disc"
	+ then have "z \<noteq> of_complex 1" "z \<noteq> of_complex (-1)"
	+ by auto
	+ thus "?P' x_axis z"
	+ using \<open>z \<in> unit_disc\<close>
	+ using calc_perpendicular_to_x_axis[of z] perpendicular_to_x_axis
	+ by (rule_tac x = "calc_perpendicular_to_x_axis z" in exI, auto)
	+ qed
	+ next
	+ fix M
	+ assume "unit_disc_fix M"
	+ assume *: "?P (moebius_circline M H)"
	+ show "?P H"
	+ proof safe
	+ fix z
	+ assume "z \<in> unit_disc"
	+ hence "moebius_pt M z \<in> unit_disc"
	+ using \<open>unit_disc_fix M\<close>
	+ by auto
	+ then obtain H' where *: "is_poincare_line H'" "perpendicular (moebius_circline M H) H'" "moebius_pt M z \<in> circline_set H'"
	+ using *
	+ by auto
	+ have h: "H = moebius_circline (-M) (moebius_circline M H)"
	+ by auto
	+ show "?P' H z"
	+ using * \<open>unit_disc_fix M\<close>
	+ apply (subst h)
	+ apply (rule_tac x="moebius_circline (-M) H'" in exI)
	+ apply (simp del: moebius_circline_comp_inv_left)
	+ done
	+ qed
	+ qed fact
	+ thus ?thesis
	+ using assms
	+ by simp
	+qed
	+
	+lemma ex_perpendicular_foot:
	+ assumes "is_poincare_line H" "z \<in> unit_disc"
	+ shows "\<exists> H'. is_poincare_line H' \<and> z \<in> circline_set H' \<and> perpendicular H H' \<and>
	+ (\<exists> z' \<in> unit_disc. z' \<in> circline_set H' \<inter> circline_set H)"
	+ using assms
	+ using ex_perpendicular[OF assms]
	+ using perpendicular_intersects[of H]
	+ by blast
	+
	+lemma Pythagoras:
	+ assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc" "v \<noteq> w"
	+ assumes "distinct[u, v, w] \<longrightarrow> perpendicular (poincare_line u v) (poincare_line u w)"
	+ shows "cosh (poincare_distance v w) = cosh (poincare_distance u v) * cosh (poincare_distance u w)" (is "?P' u v w")
	+proof (cases "distinct [u, v, w]")
	+ case False
	+ thus "?thesis"
	+ using in_disc
	+ by (auto simp add: poincare_distance_sym)
	+next
	+ case True
	+ have "distinct [u, v, w] \<longrightarrow> ?P' u v w" (is "?P u v w")
	+ proof (rule wlog_perpendicular_axes[where P="?P"])
	+ show "is_poincare_line (poincare_line u v)" "is_poincare_line (poincare_line u w)"
	+ using \<open>distinct [u, v, w]\<close>
	+ by simp_all
	+ next
	+ show "perpendicular (poincare_line u v) (poincare_line u w)"
	+ using True assms
	+ by simp
	+ next
	+ show "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
	+ by fact+
	+ next
	+ show "v \<in> circline_set (poincare_line u v)" "w \<in> circline_set (poincare_line u w)"
	+ "u \<in> circline_set (poincare_line u v) \<inter> circline_set (poincare_line u w)"
	+ using \<open>distinct [u, v, w]\<close>
	+ by auto
	+ next
	+ fix x y
	+ assume x: "is_real x" "0 \<le> Re x" "Re x < 1"
	+ assume y: "is_imag y" "0 \<le> Im y" "Im y < 1"
	+
	+ have "of_complex x \<in> unit_disc" "of_complex y \<in> unit_disc"
	+ using x y
	+ by (simp_all add: cmod_eq_Re cmod_eq_Im)
	+
	+ show "?P 0\<^sub>h (of_complex x) (of_complex y)"
	+ proof
	+ assume "distinct [0\<^sub>h, of_complex x, of_complex y]"
	+ hence "x \<noteq> 0" "y \<noteq> 0"
	+ by auto
	+
	+ let ?den1 = "1 - (cmod x)\<^sup>2" and ?den2 = "1 - (cmod y)\<^sup>2"
	+ have "?den1 > 0" "?den2 > 0"
	+ using x y
	+ by (simp_all add: cmod_eq_Re cmod_eq_Im abs_square_less_1)
	+
	+ let ?d1 = "1 + 2 * (cmod x)\<^sup>2 / ?den1"
	+ have "cosh (poincare_distance 0\<^sub>h (of_complex x)) = ?d1"
	+ using \<open>?den1 > 0\<close>
	+ using poincare_distance_formula[of "0\<^sub>h" "of_complex x"] \<open>of_complex x \<in> unit_disc\<close>
	+ by simp
	+
	+ moreover
	+
	+ let ?d2 = "1 + 2 * (cmod y)\<^sup>2 / ?den2"
	+ have "cosh (poincare_distance 0\<^sub>h (of_complex y)) = ?d2"
	+ using \<open>?den2 > 0\<close> \<open>of_complex y \<in> unit_disc\<close>
	+ using poincare_distance_formula[of "0\<^sub>h" "of_complex y"]
	+ by simp
	+
	+ moreover
	+ let ?den = "?den1 * ?den2"
	+ let ?d3 = "1 + 2 * (cmod (x - y))\<^sup>2 / ?den"
	+ have "cosh (poincare_distance (of_complex x) (of_complex y)) = ?d3"
	+ using \<open>of_complex x \<in> unit_disc\<close> \<open>of_complex y \<in> unit_disc\<close>
	+ using \<open>?den1 > 0\<close> \<open>?den2 > 0\<close>
	+ using poincare_distance_formula[of "of_complex x" "of_complex y"]
	+ by simp
	+ moreover
	+ have "?d1 * ?d2 = ?d3"
	+ proof-
	+ have "?d3 = ((1 - (cmod x)\<^sup>2) * (1 - (cmod y)\<^sup>2) + 2 * (cmod (x - y))\<^sup>2) / ?den"
	+ using \<open>?den1 > 0\<close> \<open>?den2 > 0\<close>
	+ by (subst add_num_frac, simp, simp)
	+ also have "... = (Re ((1 - x * cnj x) * (1 - y * cnj y) + 2 * (x - y)*cnj (x - y)) / ?den)"
	+ using \<open>is_real x\<close> \<open>is_imag y\<close>
	+ by ((subst cmod_square)+, simp)
	+ also have "... = Re (1 + x * cnj x * y * cnj y
	+ + x * cnj x - 2 * y * cnj x - 2 * x * cnj y + y * cnj y) / ?den"
	+ by (simp add: field_simps)
	+ also have "... = Re ((1 + y * cnj y) * (1 + x * cnj x)) / ?den"
	+ using \<open>is_real x\<close> \<open>is_imag y\<close>
	+ by (simp add: field_simps)
	+ finally
	+ show ?thesis
	+ using \<open>?den1 > 0\<close> \<open>?den2 > 0\<close>
	+ apply (subst add_num_frac, simp)
	+ apply (subst add_num_frac, simp)
	+ apply simp
	+ apply (subst cmod_square)+
	+ apply (simp add: field_simps)
	+ done
	+ qed
	+ ultimately
	+ show "?P' 0\<^sub>h (of_complex x) (of_complex y)"
	+ by simp
	+ qed
	+ next
	+ fix M u v w
	+ assume 1: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
	+ assume 2: "?P (moebius_pt M u) (moebius_pt M v) (moebius_pt M w)"
	+ show "?P u v w"
	+ using 1 2
	+ by auto
	+ next
	+ fix u v w
	+ assume 1: "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc"
	+ assume 2: "?P (conjugate u) (conjugate v) (conjugate w)"
	+ show "?P u v w"
	+ using 1 2
	+ by (auto simp add: conjugate_inj)
	+ qed
	+ thus ?thesis
	+ using True
	+ by simp
	+qed
	+
	+end
	\ No newline at end of file
	diff --git a/thys/Poincare_Disc/Poincare_Tarski.thy b/thys/Poincare_Disc/Poincare_Tarski.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Poincare_Tarski.thy
	@@ -0,0 +1,3045 @@
	+section \<open>Poincar\'e model satisfies Tarski axioms\<close>
	+
	+theory Poincare_Tarski
	+ imports Poincare Poincare_Lines_Axis_Intersections Tarski
	+begin
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Pasch axiom\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lemma Pasch_fun_mono:
	+ fixes r1 r2 :: real
	+ assumes "0 < r1" and "r1 \<le> r2" and "r2 < 1"
	+ shows "r1 + 1/r1 \<ge> r2 + 1/r2"
	+proof (cases "r1 = r2")
	+ case True
	+ thus ?thesis
	+ by simp
	+next
	+ case False
	+ hence "r2 - r1 > 0"
	+ using assms
	+ by simp
	+
	+ have "r1 * r2 < 1"
	+ using assms
	+ by (smt mult_le_cancel_left1)
	+ hence "1 / (r1 * r2) > 1"
	+ using assms
	+ by simp
	+ hence "(r2 - r1) / (r1 * r2) > (r2 - r1)"
	+ using \<open>r2 - r1 > 0\<close>
	+ using mult_less_cancel_left_pos[of "r2 - r1" 1 "1 / (r1 * r2)"]
	+ by simp
	+ hence "1 / r1 - 1 / r2 > r2 - r1"
	+ using assms
	+ by (simp add: field_simps)
	+ thus ?thesis
	+ by simp
	+qed
	+
	+text\<open>Pasch axiom, non-degenerative case.\<close>
	+lemma Pasch_nondeg:
	+ assumes "x \<in> unit_disc" and "y \<in> unit_disc" and "z \<in> unit_disc" and "u \<in> unit_disc" and "v \<in> unit_disc"
	+ assumes "distinct [x, y, z, u, v]"
	+ assumes "\<not> poincare_collinear {x, y, z}"
	+ assumes "poincare_between x u z" and "poincare_between y v z"
	+ shows "\<exists> a. a \<in> unit_disc \<and> poincare_between u a y \<and> poincare_between x a v"
	+proof-
	+ have "\<forall> y z u. distinct [x, y, z, u, v] \<and> \<not> poincare_collinear {x, y, z} \<and> y \<in> unit_disc \<and> z \<in> unit_disc \<and> u \<in> unit_disc \<and>
	+ poincare_between x u z \<and> poincare_between y v z \<longrightarrow> (\<exists> a. a \<in> unit_disc \<and> poincare_between u a y \<and> poincare_between x a v)" (is "?P x v")
	+ proof (rule wlog_positive_x_axis[where P="?P"])
	+ fix v
	+ assume v: "is_real v" "0 < Re v" "Re v < 1"
	+ hence "of_complex v \<in> unit_disc"
	+ by (auto simp add: cmod_eq_Re)
	+ show "?P 0\<^sub>h (of_complex v)"
	+ proof safe
	+ fix y z u
	+ assume distinct: "distinct [0\<^sub>h, y, z, u, of_complex v]"
	+ assume in_disc: "y \<in> unit_disc" "z \<in> unit_disc" "u \<in> unit_disc"
	+ then obtain y' z' u'
	+ where *: "y = of_complex y'" "z = of_complex z'" "u = of_complex u'"
	+ using inf_or_of_complex inf_notin_unit_disc
	+ by metis
	+
	+ have "y' \<noteq> 0" "z' \<noteq> 0" "u' \<noteq> 0" "v \<noteq> 0" "y' \<noteq> z'" "y' \<noteq> u'" "z' \<noteq> u'" "y \<noteq> z" "y \<noteq> u" "z \<noteq> u"
	+ using of_complex_inj distinct *
	+ by auto
	+
	+ note distinct = distinct this
	+
	+ assume "\<not> poincare_collinear {0\<^sub>h, y, z}"
	+
	+ hence nondeg_yz: "y'cnj z' \<noteq> cnj y' z'"
	+ using * poincare_collinear_zero_iff[of y' z'] in_disc distinct
	+ by auto
	+
	+ assume "poincare_between 0\<^sub>h u z"
	+
	+ hence "arg u' = arg z'" "cmod u' \<le> cmod z'"
	+ using * poincare_between_0uv[of u z] distinct in_disc
	+ by auto
	+
	+ then obtain \<phi> ru rz where
	+ uz_polar: "u' = cor ru * cis \<phi>" "z' = cor rz * cis \<phi>" "0 < ru" "ru \<le> rz" "0 < rz" and
	+ "\<phi> = arg u'" "\<phi> = arg z'"
	+ using * \<open>u' \<noteq> 0\<close> \<open>z' \<noteq> 0\<close>
	+ by (smt cmod_cis norm_le_zero_iff)
	+
	+ obtain \<theta> ry where
	+ y_polar: "y' = cor ry * cis \<theta>" "ry > 0" and "\<theta> = arg y'"
	+ using \<open>y' \<noteq> 0\<close>
	+ by (smt cmod_cis norm_le_zero_iff)
	+
	+ from in_disc * \<open>u' = cor ru * cis \<phi>\<close> \<open>z' = cor rz * cis \<phi>\<close> \<open>y' = cor ry * cis \<theta>\<close>
	+ have "ru < 1" "rz < 1" "ry < 1"
	+ by simp_all
	+
	+ note polar = this y_polar uz_polar
	+
	+ have nondeg: "cis \<theta> * cis (- \<phi>) \<noteq> cis (- \<theta>) * cis \<phi>"
	+ using nondeg_yz polar
	+ by simp
	+
	+ let ?yz = "poincare_line y z"
	+ let ?v = "calc_x_axis_intersection ?yz"
	+
	+ assume "poincare_between y (of_complex v) z"
	+
	+ hence "of_complex v \<in> circline_set ?yz"
	+ using in_disc \<open>of_complex v \<in> unit_disc\<close>
	+ using distinct poincare_between_poincare_collinear[of y "of_complex v" z]
	+ using unique_poincare_line[of y z]
	+ by (auto simp add: poincare_collinear_def)
	+ moreover
	+ have "of_complex v \<in> circline_set x_axis"
	+ using \<open>is_real v\<close>
	+ unfolding circline_set_x_axis
	+ by auto
	+ moreover
	+ have "?yz \<noteq> x_axis"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "{0\<^sub>h, y, z} \<subseteq> circline_set (poincare_line y z)"
	+ unfolding circline_set_def
	+ using distinct poincare_line[of y z]
	+ by auto
	+ hence "poincare_collinear {0\<^sub>h, y, z}"
	+ unfolding poincare_collinear_def
	+ using distinct
	+ by force
	+ thus False
	+ using \<open>\<not> poincare_collinear {0\<^sub>h, y, z}\<close>
	+ by simp
	+ qed
	+ ultimately
	+ have "?v = of_complex v" "intersects_x_axis ?yz"
	+ using unique_calc_x_axis_intersection[of "poincare_line y z" "of_complex v"]
	+ using intersects_x_axis_iff[of ?yz]
	+ using distinct \<open>of_complex v \<in> unit_disc\<close>
	+ by (metis IntI is_poincare_line_poincare_line)+
	+
	+ have "intersects_x_axis_positive ?yz"
	+ using \<open>Re v > 0\<close> \<open>of_complex v \<in> unit_disc\<close>
	+ using \<open>of_complex v \<in> circline_set ?yz\<close> \<open>of_complex v \<in> circline_set x_axis\<close>
	+ using intersects_x_axis_positive_iff[of ?yz] \<open>y \<noteq> z\<close> \<open>?yz \<noteq> x_axis\<close>
	+ unfolding positive_x_axis_def
	+ by force
	+
	+ have "y \<notin> circline_set x_axis"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ moreover
	+ hence "poincare_line y (of_complex v) = x_axis"
	+ using distinct \<open>of_complex v \<in> circline_set x_axis\<close>
	+ using in_disc \<open>of_complex v \<in> unit_disc\<close>
	+ using unique_poincare_line[of y "of_complex v" x_axis]
	+ by simp
	+ moreover
	+ have "z \<in> circline_set (poincare_line y (of_complex v))"
	+ using \<open>of_complex v \<in> circline_set ?yz\<close>
	+ using unique_poincare_line[of y "of_complex v" "poincare_line y z"]
	+ using in_disc \<open>of_complex v \<in> unit_disc\<close> distinct
	+ using poincare_line[of y z]
	+ unfolding circline_set_def
	+ by (metis distinct_length_2_or_more is_poincare_line_poincare_line mem_Collect_eq)
	+ ultimately
	+ have "y \<in> circline_set x_axis" "z \<in> circline_set x_axis"
	+ by auto
	+ hence "poincare_collinear {0\<^sub>h, y, z}"
	+ unfolding poincare_collinear_def
	+ by force
	+ thus False
	+ using \<open>\<not> poincare_collinear {0\<^sub>h, y, z}\<close>
	+ by simp
	+ qed
	+
	+ moreover
	+
	+ have "z \<notin> circline_set x_axis"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ moreover
	+ hence "poincare_line z (of_complex v) = x_axis"
	+ using distinct \<open>of_complex v \<in> circline_set x_axis\<close>
	+ using in_disc \<open>of_complex v \<in> unit_disc\<close>
	+ using unique_poincare_line[of z "of_complex v" x_axis]
	+ by simp
	+ moreover
	+ have "y \<in> circline_set (poincare_line z (of_complex v))"
	+ using \<open>of_complex v \<in> circline_set ?yz\<close>
	+ using unique_poincare_line[of z "of_complex v" "poincare_line y z"]
	+ using in_disc \<open>of_complex v \<in> unit_disc\<close> distinct
	+ using poincare_line[of y z]
	+ unfolding circline_set_def
	+ by (metis distinct_length_2_or_more is_poincare_line_poincare_line mem_Collect_eq)
	+ ultimately
	+ have "y \<in> circline_set x_axis" "z \<in> circline_set x_axis"
	+ by auto
	+ hence "poincare_collinear {0\<^sub>h, y, z}"
	+ unfolding poincare_collinear_def
	+ by force
	+ thus False
	+ using \<open>\<not> poincare_collinear {0\<^sub>h, y, z}\<close>
	+ by simp
	+ qed
	+
	+ ultimately
	+
	+ have "\<phi> * \<theta> < 0"
	+ using \<open>poincare_between y (of_complex v) z\<close>
	+ using poincare_between_x_axis_intersection[of y z "of_complex v"]
	+ using in_disc \<open>of_complex v \<in> unit_disc\<close> distinct
	+ using \<open>of_complex v \<in> circline_set ?yz\<close> \<open>of_complex v \<in> circline_set x_axis\<close>
	+ using \<open>\<phi> = arg z'\<close> \<open>\<theta> = arg y'\<close> *
	+ by (simp add: field_simps)
	+
	+ have "\<phi> \<noteq> pi" "\<phi> \<noteq> 0"
	+ using \<open>z \<notin> circline_set x_axis\<close> * polar cis_pi
	+ unfolding circline_set_x_axis
	+ by auto
	+
	+ have "\<theta> \<noteq> pi" "\<theta> \<noteq> 0"
	+ using \<open>y \<notin> circline_set x_axis\<close> * polar cis_pi
	+ unfolding circline_set_x_axis
	+ by auto
	+
	+ have phi_sin: "\<phi> > 0 \<longleftrightarrow> sin \<phi> > 0" "\<phi> < 0 \<longleftrightarrow> sin \<phi> < 0"
	+ using \<open>\<phi> = arg z'\<close> \<open>\<phi> \<noteq> 0\<close> \<open>\<phi> \<noteq> pi\<close>
	+ using arg_bounded[of z']
	+ by (smt sin_gt_zero sin_le_zero sin_pi_minus sin_0_iff_canon sin_ge_zero)+
	+
	+ have theta_sin: "\<theta> > 0 \<longleftrightarrow> sin \<theta> > 0" "\<theta> < 0 \<longleftrightarrow> sin \<theta> < 0"
	+ using \<open>\<theta> = arg y'\<close> \<open>\<theta> \<noteq> 0\<close> \<open>\<theta> \<noteq> pi\<close>
	+ using arg_bounded[of y']
	+ by (smt sin_gt_zero sin_le_zero sin_pi_minus sin_0_iff_canon sin_ge_zero)+
	+
	+ have "sin \<phi> * sin \<theta> < 0"
	+ using \<open>\<phi> * \<theta> < 0\<close> phi_sin theta_sin
	+ by (simp add: mult_less_0_iff)
	+
	+ have "sin (\<phi> - \<theta>) \<noteq> 0"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "sin (\<phi> - \<theta>) = 0"
	+ by simp
	+ have "- 2 * pi < \<phi> - \<theta>" "\<phi> - \<theta> < 2 * pi"
	+ using \<open>\<phi> = arg z'\<close> \<open>\<theta> = arg y'\<close> arg_bounded[of z'] arg_bounded[of y'] \<open>\<phi> \<noteq> pi\<close> \<open>\<theta> \<noteq> pi\<close>
	+ by auto
	+ hence "\<phi> - \<theta> = -pi \<or> \<phi> - \<theta> = 0 \<or> \<phi> - \<theta> = pi"
	+ using \<open>sin (\<phi> - \<theta>) = 0\<close>
	+ by (smt sin_0_iff_canon sin_periodic_pi2)
	+ moreover
	+ {
	+ assume "\<phi> - \<theta> = - pi"
	+ hence "\<phi> = \<theta> - pi"
	+ by simp
	+ hence False
	+ using nondeg_yz
	+ using \<open>y' = cor ry * cis \<theta>\<close> \<open>z' = cor rz * cis \<phi>\<close> \<open>rz > 0\<close> \<open>ry > 0\<close>
	+ by auto
	+ }
	+ moreover
	+ {
	+ assume "\<phi> - \<theta> = 0"
	+ hence "\<phi> = \<theta>"
	+ by simp
	+ hence False
	+ using \<open>y' = cor ry * cis \<theta>\<close> \<open>z' = cor rz * cis \<phi>\<close> \<open>rz > 0\<close> \<open>ry > 0\<close>
	+ using nondeg_yz
	+ by auto
	+ }
	+ moreover
	+ {
	+ assume "\<phi> - \<theta> = pi"
	+ hence "\<phi> = \<theta> + pi"
	+ by simp
	+ hence False
	+ using \<open>y' = cor ry * cis \<theta>\<close> \<open>z' = cor rz * cis \<phi>\<close> \<open>rz > 0\<close> \<open>ry > 0\<close>
	+ using nondeg_yz
	+ by auto
	+ }
	+ ultimately
	+ show False
	+ by auto
	+ qed
	+
	+ have "u \<notin> circline_set x_axis"
	+ proof-
	+ have "\<not> is_real u'"
	+ using * polar in_disc
	+ using \<open>\<phi> \<noteq> 0\<close> \<open>\<phi> = arg u'\<close> \<open>\<phi> \<noteq> pi\<close> phi_sin(1) phi_sin(2)
	+ by (metis is_real_arg2)
	+ moreover
	+ have "u \<noteq> \<infinity>\<^sub>h"
	+ using in_disc
	+ by auto
	+ ultimately
	+ show ?thesis
	+ using * of_complex_inj[of u']
	+ unfolding circline_set_x_axis
	+ by auto
	+ qed
	+
	+ let ?yu = "poincare_line y u"
	+ have nondeg_yu: "y' * cnj u' \<noteq> cnj u' * u'"
	+ using nondeg_yz polar \<open>ru > 0\<close> \<open>rz > 0\<close> distinct
	+ by auto
	+
	+ {
	+ (* derive results simultaneously for both u and z *)
	+ fix r :: real
	+ assume "r > 0"
	+
	+ have den: "cor ry * cis \<theta> * cnj 1 * cnj (cor r * cis \<phi>) * 1 - cor r * cis \<phi> * cnj 1 * cnj (cor ry * cis \<theta>) * 1 \<noteq> 0"
	+ using \<open>0 < r\<close> \<open>0 < ry\<close> nondeg
	+ by auto
	+
	+ let ?A = "2 * r * ry * sin(\<phi> - \<theta>)"
	+ let ?B = "\<i> * (r * cis \<phi> * (1 + ry\<^sup>2) - ry * cis \<theta> * (1 + r\<^sup>2))"
	+ let ?ReB = "ry * (1 + r\<^sup>2) * sin \<theta> - r * (1 + ry\<^sup>2) * sin \<phi>"
	+
	+ have "Re (\<i> * (r * cis (-\<phi>) * ry * cis (\<theta>) - ry * cis (-\<theta>) * r * cis (\<phi>))) = ?A"
	+ by (simp add: sin_diff field_simps)
	+ moreover
	+ have "cor ry * cis (- \<theta>) * (cor ry * cis \<theta>) = ry\<^sup>2" "cor r * cis (- \<phi>) * (cor r * cis \<phi>) = r\<^sup>2"
	+ by (metis cis_inverse cis_neq_zero divide_complex_def cor_squared nonzero_mult_div_cancel_right power2_eq_square semiring_normalization_rules(15))+
	+ ultimately
	+ have 1: "poincare_line_cvec_cmat (of_complex_cvec (cor ry * cis \<theta>)) (of_complex_cvec (cor r * cis \<phi>)) = (?A, ?B, cnj ?B, ?A)"
	+ using den
	+ unfolding poincare_line_cvec_cmat_def of_complex_cvec_def Let_def prod.case
	+ by (simp add: field_simps)
	+
	+ have 2: "is_real ?A"
	+ by simp
	+ let ?mix = "cis \<theta> * cis (- \<phi>) - cis (- \<theta>) * cis \<phi>"
	+ have "is_imag ?mix"
	+ using eq_minus_cnj_iff_imag[of ?mix]
	+ by simp
	+ hence "Im ?mix \<noteq> 0"
	+ using nondeg
	+ using complex.expand[of ?mix 0]
	+ by auto
	+ hence 3: "Re ?A \<noteq> 0"
	+ using \<open>r > 0\<close> \<open>ry > 0\<close>
	+ by (simp add: sin_diff field_simps)
	+
	+ have "?A \<noteq> 0"
	+ using 2 3
	+ by auto
	+ hence 4: "cor ?A \<noteq> 0"
	+ using 2 3
	+ by (metis zero_complex.simps(1))
	+
	+ have 5: "?ReB / ?A = (sin \<theta>) / (2 * sin(\<phi> - \<theta>)) * (1/r + r) - (sin \<phi>) / (2 * sin (\<phi> - \<theta>)) * (1/ry + ry)"
	+ using \<open>ry > 0\<close> \<open>r > 0\<close>
	+ apply (subst diff_divide_distrib)
	+ apply (subst add_frac_num, simp)
	+ apply (subst add_frac_num, simp)
	+ apply (simp add: power2_eq_square mult.commute)
	+ apply (simp add: field_simps)
	+ done
	+
	+ have "poincare_line_cvec_cmat (of_complex_cvec (cor ry * cis \<theta>)) (of_complex_cvec (cor r * cis \<phi>)) = (?A, ?B, cnj ?B, ?A) \<and>
	+ is_real ?A \<and> Re ?A \<noteq> 0 \<and> ?A \<noteq> 0 \<and> cor ?A \<noteq> 0 \<and>
	+ Re ?B = ?ReB \<and>
	+ ?ReB / ?A = (sin \<theta>) / (2 * sin(\<phi> - \<theta>)) * (1/r + r) - (sin \<phi>) / (2 * sin (\<phi> - \<theta>)) * (1/ry + ry)"
	+ using 1 2 3 4 5
	+ by auto
	+ }
	+ note ** = this
	+
	+ let ?Ayz = "2 * rz * ry * sin (\<phi> - \<theta>)"
	+ let ?Byz = "\<i> * (rz * cis \<phi> * (1 + ry\<^sup>2) - ry * cis \<theta> * (1 + rz\<^sup>2))"
	+ let ?ReByz = "ry * (1 + rz\<^sup>2) * sin \<theta> - rz * (1 + ry\<^sup>2) * sin \<phi>"
	+ let ?Kz = "(sin \<theta>) / (2 * sin(\<phi> - \<theta>)) * (1/rz + rz) - (sin \<phi>) / (2 * sin (\<phi> - \<theta>)) * (1/ry + ry)"
	+ have yz: "poincare_line_cvec_cmat (of_complex_cvec (cor ry * cis \<theta>)) (of_complex_cvec (cor rz * cis \<phi>)) = (?Ayz, ?Byz, cnj ?Byz, ?Ayz)"
	+ "is_real ?Ayz" "Re ?Ayz \<noteq> 0" "?Ayz \<noteq> 0" "cor ?Ayz \<noteq> 0" "Re ?Byz = ?ReByz" and Kz: "?ReByz / ?Ayz = ?Kz"
	+ using **[OF \<open>0 < rz\<close>]
	+ by auto
	+
	+ let ?Ayu = "2 * ru * ry * sin (\<phi> - \<theta>)"
	+ let ?Byu = "\<i> * (ru * cis \<phi> * (1 + ry\<^sup>2) - ry * cis \<theta> * (1 + ru\<^sup>2))"
	+ let ?ReByu = "ry * (1 + ru\<^sup>2) * sin \<theta> - ru * (1 + ry\<^sup>2) * sin \<phi>"
	+ let ?Ku = "(sin \<theta>) / (2 * sin(\<phi> - \<theta>)) * (1/ru + ru) - (sin \<phi>) / (2 * sin (\<phi> - \<theta>)) * (1/ry + ry)"
	+ have yu: "poincare_line_cvec_cmat (of_complex_cvec (cor ry * cis \<theta>)) (of_complex_cvec (cor ru * cis \<phi>)) = (?Ayu, ?Byu, cnj ?Byu, ?Ayu)"
	+ "is_real ?Ayu" "Re ?Ayu \<noteq> 0" "?Ayu \<noteq> 0" "cor ?Ayu \<noteq> 0" "Re ?Byu = ?ReByu" and Ku: "?ReByu / ?Ayu = ?Ku"
	+ using **[OF \<open>0 < ru\<close>]
	+ by auto
	+
	+ have "?Ayz \<noteq> 0"
	+ using \<open>sin (\<phi> - \<theta>) \<noteq> 0\<close> \<open>ry > 0\<close> \<open>rz > 0\<close>
	+ by auto
	+
	+ have "Re ?Byz / ?Ayz < -1"
	+ using \<open>intersects_x_axis_positive ?yz\<close>
	+ * \<open>y' = cor ry * cis \<theta>\<close> \<open>z' = cor rz * cis \<phi>\<close> \<open>u' = cor ru * cis \<phi>\<close>
	+ apply simp
	+ apply (transfer fixing: ry rz ru \<theta> \<phi>)
	+ apply (transfer fixing: ry rz ru \<theta> \<phi>)
	+ proof-
	+ assume "intersects_x_axis_positive_cmat (poincare_line_cvec_cmat (of_complex_cvec (cor ry * cis \<theta>)) (of_complex_cvec (cor rz * cis \<phi>)))"
	+ thus "(ry * sin \<theta> * (1 + rz\<^sup>2) - rz * sin \<phi> * (1 + ry\<^sup>2)) / (2 * rz * ry * sin (\<phi> - \<theta>)) < - 1"
	+ using yz
	+ by simp
	+ qed
	+
	+ have "?ReByz / ?Ayz \<ge> ?ReByu / ?Ayu"
	+ proof (cases "sin \<phi> > 0")
	+ case True
	+ hence "sin \<theta> < 0"
	+ using \<open>sin \<phi> * sin \<theta> < 0\<close>
	+ by (smt mult_nonneg_nonneg)
	+
	+ have "?ReByz < 0"
	+ proof-
	+ have "ry * (1 + rz\<^sup>2) * sin \<theta> < 0"
	+ using \<open>ry > 0\<close> \<open>rz > 0\<close>
	+ using \<open>sin \<theta> < 0\<close>
	+ by (smt mult_pos_neg mult_pos_pos zero_less_power)
	+ moreover
	+ have "rz * (1 + ry\<^sup>2) * sin \<phi> > 0"
	+ using \<open>ry > 0\<close> \<open>rz > 0\<close>
	+ using \<open>sin \<phi> > 0\<close>
	+ by (smt mult_pos_neg mult_pos_pos zero_less_power)
	+ ultimately
	+ show ?thesis
	+ by simp
	+ qed
	+ have "?Ayz > 0"
	+ using \<open>Re ?Byz / ?Ayz < -1\<close> \<open>Re ?Byz = ?ReByz\<close> \<open>?ReByz < 0\<close>
	+ by (smt divide_less_0_iff)
	+ hence "sin (\<phi> - \<theta>) > 0"
	+ using \<open>ry > 0\<close> \<open>rz > 0\<close>
	+ by (smt mult_pos_pos zero_less_mult_pos)
	+
	+ have "1 / ru + ru \<ge> 1 / rz + rz"
	+ using Pasch_fun_mono[of ru rz] \<open>0 < ru\<close> \<open>ru \<le> rz\<close> \<open>rz < 1\<close>
	+ by simp
	+ hence "sin \<theta> * (1 / ru + ru) \<le> sin \<theta> * (1 / rz + rz)"
	+ using \<open>sin \<theta> < 0\<close>
	+ by auto
	+ thus ?thesis
	+ using \<open>ru > 0\<close> \<open>rz > 0\<close> \<open>ru \<le> rz\<close> \<open>rz < 1\<close> \<open>?Ayz > 0\<close> \<open>sin (\<phi> - \<theta>) > 0\<close>
	+ using divide_right_mono[of "sin \<theta> * (1 / ru + ru)" "sin \<theta> * (1 / rz + rz)" "2 * sin (\<phi> - \<theta>)"]
	+ by (subst Kz, subst Ku) simp
	+ next
	+ assume "\<not> sin \<phi> > 0"
	+ hence "sin \<phi> < 0"
	+ using \<open>sin \<phi> * sin \<theta> < 0\<close>
	+ by (cases "sin \<phi> = 0", simp_all)
	+ hence "sin \<theta> > 0"
	+ using \<open>sin \<phi> * sin \<theta> < 0\<close>
	+ by (smt mult_nonpos_nonpos)
	+ have "?ReByz > 0"
	+ proof-
	+ have "ry * (1 + rz\<^sup>2) * sin \<theta> > 0"
	+ using \<open>ry > 0\<close> \<open>rz > 0\<close>
	+ using \<open>sin \<theta> > 0\<close>
	+ by (smt mult_pos_neg mult_pos_pos zero_less_power)
	+ moreover
	+ have "rz * (1 + ry\<^sup>2) * sin \<phi> < 0"
	+ using \<open>ry > 0\<close> \<open>rz > 0\<close>
	+ using \<open>sin \<phi> < 0\<close>
	+ by (smt mult_pos_neg mult_pos_pos zero_less_power)
	+ ultimately
	+ show ?thesis
	+ by simp
	+ qed
	+ have "?Ayz < 0"
	+ using \<open>Re ?Byz / ?Ayz < -1\<close> \<open>?Ayz \<noteq> 0\<close> \<open>Re ?Byz = ?ReByz\<close> \<open>?ReByz > 0\<close>
	+ by (smt divide_less_0_iff)
	+ hence "sin (\<phi> - \<theta>) < 0"
	+ using \<open>ry > 0\<close> \<open>rz > 0\<close>
	+ by (smt mult_nonneg_nonneg)
	+
	+ have "1 / ru + ru \<ge> 1 / rz + rz"
	+ using Pasch_fun_mono[of ru rz] \<open>0 < ru\<close> \<open>ru \<le> rz\<close> \<open>rz < 1\<close>
	+ by simp
	+ hence "sin \<theta> * (1 / ru + ru) \<ge> sin \<theta> * (1 / rz + rz)"
	+ using \<open>sin \<theta> > 0\<close>
	+ by auto
	+ thus ?thesis
	+ using \<open>ru > 0\<close> \<open>rz > 0\<close> \<open>ru \<le> rz\<close> \<open>rz < 1\<close> \<open>?Ayz < 0\<close> \<open>sin (\<phi> - \<theta>) < 0\<close>
	+ using divide_right_mono_neg[of "sin \<theta> * (1 / rz + rz)" "sin \<theta> * (1 / ru + ru)" "2 * sin (\<phi> - \<theta>)"]
	+ by (subst Kz, subst Ku) simp
	+ qed
	+
	+ have "intersects_x_axis_positive ?yu"
	+ using * \<open>y' = cor ry * cis \<theta>\<close> \<open>z' = cor rz * cis \<phi>\<close> \<open>u' = cor ru * cis \<phi>\<close>
	+ apply simp
	+ apply (transfer fixing: ry rz ru \<theta> \<phi>)
	+ apply (transfer fixing: ry rz ru \<theta> \<phi>)
	+ proof-
	+ have "Re ?Byu / ?Ayu < -1"
	+ using \<open>Re ?Byz / ?Ayz < -1\<close> \<open>?ReByz / ?Ayz \<ge> ?ReByu / ?Ayu\<close>
	+ by (subst (asm) \<open>Re ?Byz = ?ReByz\<close>, subst \<open>Re ?Byu = ?ReByu\<close>) simp
	+ thus "intersects_x_axis_positive_cmat (poincare_line_cvec_cmat (of_complex_cvec (cor ry * cis \<theta>)) (of_complex_cvec (cor ru * cis \<phi>)))"
	+ using yu
	+ by simp
	+ qed
	+
	+ let ?a = "calc_x_axis_intersection ?yu"
	+ have "?a \<in> positive_x_axis" "?a \<in> circline_set ?yu" "?a \<in> unit_disc"
	+ using \<open>intersects_x_axis_positive ?yu\<close>
	+ using intersects_x_axis_positive_iff'[of ?yu] \<open>y \<noteq> u\<close>
	+ by auto
	+
	+ then obtain a' where a': "?a = of_complex a'" "is_real a'" "Re a' > 0" "Re a' < 1"
	+ unfolding positive_x_axis_def circline_set_x_axis
	+ by (auto simp add: cmod_eq_Re)
	+
	+ have "intersects_x_axis ?yz" "intersects_x_axis ?yu"
	+ using \<open>intersects_x_axis_positive ?yz\<close> \<open>intersects_x_axis_positive ?yu\<close>
	+ by auto
	+
	+ show "\<exists>a. a \<in> unit_disc \<and> poincare_between u a y \<and> poincare_between 0\<^sub>h a (of_complex v)"
	+ proof (rule_tac x="?a" in exI, safe)
	+ show "poincare_between u ?a y"
	+ using poincare_between_x_axis_intersection[of y u ?a]
	+ using calc_x_axis_intersection[OF is_poincare_line_poincare_line[OF \<open>y \<noteq> u\<close>] \<open>intersects_x_axis ?yu\<close>]
	+ using calc_x_axis_intersection_in_unit_disc[OF is_poincare_line_poincare_line[OF \<open>y \<noteq> u\<close>] \<open>intersects_x_axis ?yu\<close>]
	+ using in_disc \<open>y \<noteq> u\<close> \<open>y \<notin> circline_set x_axis\<close> \<open>u \<notin> circline_set x_axis\<close>
	+ using * \<open>\<phi> = arg u'\<close> \<open>\<theta> = arg y'\<close> \<open>\<phi> * \<theta> < 0\<close>
	+ by (subst poincare_between_rev, auto simp add: mult.commute)
	+ next
	+ show "poincare_between 0\<^sub>h ?a (of_complex v)"
	+ proof-
	+ have "-?ReByz / ?Ayz \<le> -?ReByu / ?Ayu"
	+ using \<open>?ReByz / ?Ayz \<ge> ?ReByu / ?Ayu\<close>
	+ by linarith
	+ have "outward ?yz ?yu"
	+ using * \<open>y' = cor ry * cis \<theta>\<close> \<open>z' = cor rz * cis \<phi>\<close> \<open>u' = cor ru * cis \<phi>\<close>
	+ apply simp
	+ apply (transfer fixing: ry rz ru \<theta> \<phi>)
	+ apply (transfer fixing: ry rz ru \<theta> \<phi>)
	+ apply (subst yz yu)+
	+ unfolding outward_cmat_def
	+ apply (simp only: Let_def prod.case)
	+ apply (subst yz yu)+
	+ using \<open>-?ReByz / ?Ayz \<le> -?ReByu / ?Ayu\<close>
	+ by simp
	+ hence "Re a' \<le> Re v"
	+ using \<open>?v = of_complex v\<close>
	+ using \<open>?a = of_complex a'\<close>
	+ using \<open>intersects_x_axis_positive ?yz\<close> \<open>intersects_x_axis_positive ?yu\<close>
	+ using outward[OF is_poincare_line_poincare_line[OF \<open>y \<noteq> z\<close>] is_poincare_line_poincare_line[OF \<open>y \<noteq> u\<close>]]
	+ by simp
	+ thus ?thesis
	+ using \<open>?v = of_complex v\<close>
	+ using poincare_between_x_axis_0uv[of "Re a'" "Re v"] a' v
	+ by simp
	+ qed
	+ next
	+ show "?a \<in> unit_disc"
	+ by fact
	+ qed
	+ qed
	+ next
	+ show "x \<in> unit_disc" "v \<in> unit_disc" "x \<noteq> v"
	+ using assms
	+ by auto
	+ next
	+ fix M x v
	+ let ?Mx = "moebius_pt M x" and ?Mv = "moebius_pt M v"
	+ assume 1: "unit_disc_fix M" "x \<in> unit_disc" "v \<in> unit_disc" "x \<noteq> v"
	+ assume 2: "?P ?Mx ?Mv"
	+ show "?P x v"
	+ proof safe
	+ fix y z u
	+ let ?My = "moebius_pt M y" and ?Mz = "moebius_pt M z" and ?Mu = "moebius_pt M u"
	+ assume "distinct [x, y, z, u, v]" "\<not> poincare_collinear {x, y, z}" "y \<in> unit_disc" "z \<in> unit_disc" "u \<in> unit_disc"
	+ "poincare_between x u z" "poincare_between y v z"
	+ hence "\<exists> Ma. Ma \<in> unit_disc \<and> poincare_between ?Mu Ma ?My \<and> poincare_between ?Mx Ma ?Mv"
	+ using 1 2[rule_format, of ?My ?Mz ?Mu]
	+ by simp
	+ then obtain Ma where Ma: "Ma \<in> unit_disc" "poincare_between ?Mu Ma ?My \<and> poincare_between ?Mx Ma ?Mv"
	+ by blast
	+ let ?a = "moebius_pt (-M) Ma"
	+ let ?Ma = "moebius_pt M ?a"
	+ have "?Ma = Ma"
	+ by (metis moebius_pt_invert uminus_moebius_def)
	+ hence "?Ma \<in> unit_disc" "poincare_between ?Mu ?Ma ?My \<and> poincare_between ?Mx ?Ma ?Mv"
	+ using Ma
	+ by auto
	+ thus "\<exists>a. a \<in> unit_disc \<and> poincare_between u a y \<and> poincare_between x a v"
	+ using unit_disc_fix_moebius_inv[OF \<open>unit_disc_fix M\<close>] \<open>unit_disc_fix M\<close> \<open>Ma \<in> unit_disc\<close>
	+ using \<open>u \<in> unit_disc\<close> \<open>v \<in> unit_disc\<close> \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close>
	+ by (rule_tac x="?a" in exI, simp del: moebius_pt_comp_inv_right)
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms
	+ by auto
	+qed
	+
	+text\<open>Pasch axiom, only degenerative cases.\<close>
	+lemma Pasch_deg:
	+ assumes "x \<in> unit_disc" and "y \<in> unit_disc" and "z \<in> unit_disc" and "u \<in> unit_disc" and "v \<in> unit_disc"
	+ assumes "\<not> distinct [x, y, z, u, v] \<or> poincare_collinear {x, y, z}"
	+ assumes "poincare_between x u z" and "poincare_between y v z"
	+ shows "\<exists> a. a \<in> unit_disc \<and> poincare_between u a y \<and> poincare_between x a v"
	+proof(cases "poincare_collinear {x, y, z}")
	+ case True
	+ hence "poincare_between x y z \<or> poincare_between y x z \<or> poincare_between y z x"
	+ using assms(1, 2, 3) poincare_collinear3_between poincare_between_rev by blast
	+ show ?thesis
	+ proof(cases "poincare_between x y z")
	+ case True
	+ have "poincare_between x y v"
	+ using True assms poincare_between_transitivity
	+ by (meson poincare_between_rev)
	+ thus ?thesis
	+ using assms(2)
	+ by (rule_tac x="y" in exI, simp)
	+ next
	+ case False
	+ hence "poincare_between y x z \<or> poincare_between y z x"
	+ using \<open>poincare_between x y z \<or> poincare_between y x z \<or> poincare_between y z x\<close>
	+ by simp
	+ show ?thesis
	+ proof(cases "poincare_between y x z")
	+ case True
	+ hence "poincare_between u x y"
	+ using assms
	+ by (meson poincare_between_rev poincare_between_transitivity)
	+ thus ?thesis
	+ using assms
	+ by (rule_tac x="x" in exI, simp)
	+ next
	+ case False
	+ hence "poincare_between y z x"
	+ using \<open>poincare_between y x z \<or> poincare_between y z x\<close>
	+ by auto
	+ hence "poincare_between x z v"
	+ using assms
	+ by (meson poincare_between_rev poincare_between_transitivity)
	+ hence "poincare_between x u v"
	+ using assms poincare_between_transitivity poincare_between_rev
	+ by (smt poincare_between_sum_distances)
	+ thus ?thesis
	+ using assms
	+ by (rule_tac x="u" in exI, simp)
	+ qed
	+ qed
	+next
	+ case False
	+ hence "\<not> distinct [x, y, z, u, v]"
	+ using assms(6) by auto
	+ show ?thesis
	+ proof(cases "u=z")
	+ case True
	+ thus ?thesis
	+ using assms
	+ apply(rule_tac x="v" in exI)
	+ by(simp add:poincare_between_rev)
	+ next
	+ case False (* "u \<noteq> z" *)
	+ hence "x \<noteq> z"
	+ using assms poincare_between_sandwich by blast
	+ show ?thesis
	+ proof(cases "v=z")
	+ case True
	+ thus ?thesis
	+ using assms
	+ by (rule_tac x="u" in exI, simp)
	+ next
	+ case False (* v \<noteq> z *)
	+ hence "y \<noteq> z"
	+ using assms poincare_between_sandwich by blast
	+ show ?thesis
	+ proof(cases "u = x")
	+ case True
	+ thus ?thesis
	+ using assms
	+ by (rule_tac x="x" in exI, simp)
	+ next
	+ case False (u \<noteq> x)
	+ have "x \<noteq> y"
	+ using assms \<open>\<not> poincare_collinear {x, y, z}\<close>
	+ by fastforce
	+ have "x \<noteq> v"
	+ using assms \<open>\<not> poincare_collinear {x, y, z}\<close>
	+ by (metis insert_commute poincare_between_poincare_collinear)
	+ have "u \<noteq> y"
	+ using assms \<open>\<not> poincare_collinear {x, y, z}\<close>
	+ using poincare_between_poincare_collinear by blast
	+ have "u \<noteq> v"
	+ proof(rule ccontr)
	+ assume "\<not> u \<noteq> v"
	+ hence "poincare_between x v z"
	+ using assms by auto
	+ hence "x \<in> circline_set (poincare_line z v)"
	+ using poincare_between_rev[of x v z]
	+ using poincare_between_poincare_line_uvz[of z v x]
	+ using assms \<open>v \<noteq> z\<close>
	+ by auto
	+ have "y \<in> circline_set (poincare_line z v)"
	+ using assms \<open>\<not> u \<noteq> v\<close>
	+ using poincare_between_rev[of y v z]
	+ using poincare_between_poincare_line_uvz[of z v y]
	+ using assms \<open>v \<noteq> z\<close>
	+ by auto
	+ have "z \<in> circline_set (poincare_line z v)"
	+ using ex_poincare_line_two_points[of z v] \<open>v \<noteq> z\<close>
	+ by auto
	+ have "is_poincare_line (poincare_line z v)"
	+ using \<open>v \<noteq> z\<close>
	+ by auto
	+ hence "poincare_collinear {x, y, z}"
	+ using \<open>x \<in> circline_set (poincare_line z v)\<close>
	+ using \<open>y \<in> circline_set (poincare_line z v)\<close>
	+ using \<open>z \<in> circline_set (poincare_line z v)\<close>
	+ unfolding poincare_collinear_def
	+ by (rule_tac x="poincare_line z v" in exI, simp)
	+ thus False
	+ using \<open>\<not> poincare_collinear {x, y, z}\<close> by simp
	+ qed
	+ have "v = y"
	+ using \<open>u \<noteq> v\<close> \<open>u \<noteq> y\<close> \<open>x \<noteq> v\<close> \<open>x \<noteq> y\<close> \<open>u \<noteq> x\<close> \<open>y \<noteq> z\<close> \<open>v \<noteq> z\<close> \<open>x \<noteq> z\<close> \<open>u \<noteq> z\<close>
	+ using \<open>\<not> distinct [x, y, z, u, v]\<close>
	+ by auto
	+ thus ?thesis
	+ using assms
	+ by (rule_tac x="y" in exI, simp)
	+ qed
	+ qed
	+ qed
	+qed
	+
	+text \<open>Axiom of Pasch\<close>
	+lemma Pasch:
	+ assumes "x \<in> unit_disc" and "y \<in> unit_disc" and "z \<in> unit_disc" and "u \<in> unit_disc" and "v \<in> unit_disc"
	+ assumes "poincare_between x u z" and "poincare_between y v z"
	+ shows "\<exists> a. a \<in> unit_disc \<and> poincare_between u a y \<and> poincare_between x a v"
	+proof(cases "distinct [x, y, z, u, v] \<and> \<not> poincare_collinear {x, y, z}")
	+ case True
	+ thus ?thesis
	+ using assms Pasch_nondeg by auto
	+next
	+ case False
	+ thus ?thesis
	+ using assms Pasch_deg by auto
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Segment construction axiom\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lemma segment_construction:
	+ assumes "x \<in> unit_disc" and "y \<in> unit_disc"
	+ assumes "a \<in> unit_disc" and "b \<in> unit_disc"
	+ shows "\<exists> z. z \<in> unit_disc \<and> poincare_between x y z \<and> poincare_distance y z = poincare_distance a b"
	+proof-
	+ obtain d where d: "d = poincare_distance a b"
	+ by auto
	+ have "d \<ge> 0"
	+ using assms
	+ by (simp add: d poincare_distance_ge0)
	+
	+ have "\<exists> z. z \<in> unit_disc \<and> poincare_between x y z \<and> poincare_distance y z = d" (is "?P x y")
	+ proof (cases "x = y")
	+ case True
	+ have "\<exists> z. z \<in> unit_disc \<and> poincare_distance x z = d"
	+ proof (rule wlog_zero)
	+ show "\<exists> z. z \<in> unit_disc \<and> poincare_distance 0\<^sub>h z = d"
	+ using ex_x_axis_poincare_distance_negative[of d] \<open>d \<ge> 0\<close>
	+ by blast
	+ next
	+ show "x \<in> unit_disc"
	+ by fact
	+ next
	+ fix a u
	+ assume "u \<in> unit_disc" "cmod a < 1"
	+ assume "\<exists>z. z \<in> unit_disc \<and> poincare_distance (moebius_pt (blaschke a) u) z = d"
	+ then obtain z where *: "z \<in> unit_disc" "poincare_distance (moebius_pt (blaschke a) u) z = d"
	+ by auto
	+ obtain z' where z': "z = moebius_pt (blaschke a) z'" "z' \<in> unit_disc"
	+ using \<open>z \<in> unit_disc\<close>
	+ using unit_disc_fix_iff[of "blaschke a"] \<open>cmod a < 1\<close>
	+ using blaschke_unit_disc_fix[of a]
	+ by blast
	+
	+ show "\<exists>z. z \<in> unit_disc \<and> poincare_distance u z = d"
	+ using * z' \<open>u : unit_disc\<close>
	+ using blaschke_unit_disc_fix[of a] \<open>cmod a < 1\<close>
	+ by (rule_tac x=z' in exI, simp)
	+ qed
	+ thus ?thesis
	+ using \<open>x = y\<close>
	+ unfolding poincare_between_def
	+ by auto
	+ next
	+ case False
	+ show ?thesis
	+ proof (rule wlog_positive_x_axis[where P="\<lambda> y x. ?P x y"])
	+ fix x
	+ assume "is_real x" "0 < Re x" "Re x < 1"
	+
	+ then obtain z where z: "is_real z" "Re z \<le> 0" "- 1 < Re z" "of_complex z \<in> unit_disc"
	+ "of_complex z \<in> unit_disc" "of_complex z \<in> circline_set x_axis" "poincare_distance 0\<^sub>h (of_complex z) = d"
	+ using ex_x_axis_poincare_distance_negative[of d] \<open>d \<ge> 0\<close>
	+ by auto
	+
	+ have "poincare_between (of_complex x) 0\<^sub>h (of_complex z)"
	+ proof (cases "z = 0")
	+ case True
	+ thus ?thesis
	+ unfolding poincare_between_def
	+ by auto
	+ next
	+ case False
	+ have "x \<noteq> 0"
	+ using \<open>is_real x\<close> \<open>Re x > 0\<close>
	+ by auto
	+ thus ?thesis
	+ using poincare_between_x_axis_u0v[of x z]
	+ using z \<open>is_real x\<close> \<open>x \<noteq> 0\<close> \<open>Re x > 0\<close> False
	+ using complex_eq_if_Re_eq mult_pos_neg
	+ by fastforce
	+ qed
	+ thus "?P (of_complex x) 0\<^sub>h"
	+ using \<open>poincare_distance 0\<^sub>h (of_complex z) = d\<close> \<open>of_complex z \<in> unit_disc\<close>
	+ by blast
	+ next
	+ show "x \<in> unit_disc" "y \<in> unit_disc"
	+ by fact+
	+ next
	+ show "y \<noteq> x" using \<open>x \<noteq> y\<close> by simp
	+ next
	+ fix M u v
	+ assume "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ assume "?P (moebius_pt M v) (moebius_pt M u)"
	+ then obtain z where *: "z \<in> unit_disc" "poincare_between (moebius_pt M v) (moebius_pt M u) z" "poincare_distance (moebius_pt M u) z = d"
	+ by auto
	+ obtain z' where z': "z = moebius_pt M z'" "z' \<in> unit_disc"
	+ using \<open>z \<in> unit_disc\<close>
	+ using unit_disc_fix_iff[of M] \<open>unit_disc_fix M\<close>
	+ by blast
	+ thus "?P v u"
	+ using * \<open>u \<in> unit_disc\<close> \<open>v \<in> unit_disc\<close> \<open>unit_disc_fix M\<close>
	+ by auto
	+ qed
	+ qed
	+ thus ?thesis
	+ using assms d
	+ by auto
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Five segment axiom\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lemma five_segment_axiom:
	+ assumes
	+ in_disc: "x \<in> unit_disc" "y \<in> unit_disc" "z \<in> unit_disc" "u \<in> unit_disc" and
	+ in_disc': "x' \<in> unit_disc" "y' \<in> unit_disc" "z' \<in> unit_disc" "u' \<in> unit_disc" and
	+ "x \<noteq> y" and
	+ betw: "poincare_between x y z" "poincare_between x' y' z'" and
	+ xy: "poincare_distance x y = poincare_distance x' y'" and
	+ xu: "poincare_distance x u = poincare_distance x' u'" and
	+ yu: "poincare_distance y u = poincare_distance y' u'" and
	+ yz: "poincare_distance y z = poincare_distance y' z'"
	+ shows
	+ "poincare_distance z u = poincare_distance z' u'"
	+proof-
	+ from assms obtain M where
	+ M: "unit_disc_fix_f M" "M x = x'" "M u = u'" "M y = y'"
	+ using unit_disc_fix_f_congruent_triangles[of x y u]
	+ by blast
	+ have "M z = z'"
	+ proof (rule unique_poincare_distance_on_ray[where u=x' and v=y' and y="M z" and z=z' and d="poincare_distance x z"])
	+ show "0 \<le> poincare_distance x z"
	+ using poincare_distance_ge0 in_disc
	+ by simp
	+ next
	+ show "x' \<noteq> y'"
	+ using M \<open>x \<noteq> y\<close>
	+ using in_disc in_disc' poincare_distance_eq_0_iff xy
	+ by auto
	+ next
	+ show "poincare_distance x' (M z) = poincare_distance x z"
	+ using M in_disc
	+ unfolding unit_disc_fix_f_def
	+ by auto
	+ next
	+ show "M z \<in> unit_disc"
	+ using M in_disc
	+ unfolding unit_disc_fix_f_def
	+ by auto
	+ next
	+ show "poincare_distance x' z' = poincare_distance x z"
	+ using xy yz betw
	+ using poincare_between_sum_distances[of x y z]
	+ using poincare_between_sum_distances[of x' y' z']
	+ using in_disc in_disc'
	+ by auto
	+ next
	+ show "poincare_between x' y' (M z)"
	+ using M
	+ using in_disc betw
	+ unfolding unit_disc_fix_f_def
	+ by auto
	+ qed fact+
	+ thus ?thesis
	+ using \<open>unit_disc_fix_f M\<close>
	+ using in_disc in_disc'
	+ \<open>M u = u'\<close>
	+ unfolding unit_disc_fix_f_def
	+ by auto
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Upper dimension axiom\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lemma upper_dimension_axiom:
	+ assumes in_disc: "x \<in> unit_disc" "y \<in> unit_disc" "z \<in> unit_disc" "u \<in> unit_disc" "v \<in> unit_disc"
	+ assumes "poincare_distance x u = poincare_distance x v"
	+ "poincare_distance y u = poincare_distance y v"
	+ "poincare_distance z u = poincare_distance z v"
	+ "u \<noteq> v"
	+ shows "poincare_between x y z \<or> poincare_between y z x \<or> poincare_between z x y"
	+proof (cases "x = y \<or> y = z \<or> x = z")
	+ case True
	+ thus ?thesis
	+ using in_disc
	+ by auto
	+next
	+ case False
	+ hence "x \<noteq> y" "x \<noteq> z" "y \<noteq> z"
	+ by auto
	+ let ?cong = "\<lambda> a b a' b'. poincare_distance a b = poincare_distance a' b'"
	+ have "\<forall> z u v. z \<in> unit_disc \<and> u \<in> unit_disc \<and> v \<in> unit_disc \<and>
	+ ?cong x u x v \<and> ?cong y u y v \<and> ?cong z u z v \<and> u \<noteq> v \<longrightarrow>
	+ poincare_collinear {x, y, z}" (is "?P x y")
	+ proof (rule wlog_positive_x_axis[where P="?P"])
	+ fix x
	+ assume x: "is_real x" "0 < Re x" "Re x < 1"
	+ hence "x \<noteq> 0"
	+ by auto
	+ have "0\<^sub>h \<in> circline_set x_axis"
	+ by simp
	+ show "?P 0\<^sub>h (of_complex x)"
	+ proof safe
	+ fix z u v
	+ assume in_disc: "z \<in> unit_disc" "u \<in> unit_disc" "v \<in> unit_disc"
	+ then obtain z' u' v' where zuv: "z = of_complex z'" "u = of_complex u'" "v = of_complex v'"
	+ using inf_or_of_complex[of z] inf_or_of_complex[of u] inf_or_of_complex[of v]
	+ by auto
	+
	+ assume cong: "?cong 0\<^sub>h u 0\<^sub>h v" "?cong (of_complex x) u (of_complex x) v" "?cong z u z v" "u \<noteq> v"
	+
	+ let ?r0 = "poincare_distance 0\<^sub>h u" and
	+ ?rx = "poincare_distance (of_complex x) u"
	+
	+ have "?r0 > 0" "?rx > 0"
	+ using in_disc cong
	+ using poincare_distance_eq_0_iff[of "0\<^sub>h" u] poincare_distance_ge0[of "0\<^sub>h" u]
	+ using poincare_distance_eq_0_iff[of "0\<^sub>h" v] poincare_distance_ge0[of "0\<^sub>h" v]
	+ using poincare_distance_eq_0_iff[of "of_complex x" u] poincare_distance_ge0[of "of_complex x" u]
	+ using poincare_distance_eq_0_iff[of "of_complex x" v] poincare_distance_ge0[of "of_complex x" v]
	+ using x
	+ by (auto simp add: cmod_eq_Re)
	+
	+ let ?pc0 = "poincare_circle 0\<^sub>h ?r0" and
	+ ?pcx = "poincare_circle (of_complex x) ?rx"
	+ have "u \<in> ?pc0 \<inter> ?pcx" "v \<in> ?pc0 \<inter> ?pcx"
	+ using in_disc cong
	+ by (auto simp add: poincare_circle_def)
	+ hence "u = conjugate v"
	+ using intersect_poincare_circles_x_axis[of 0 x ?r0 ?rx u v]
	+ using x \<open>x \<noteq> 0\<close> \<open>u \<noteq> v\<close> \<open>?r0 > 0\<close> \<open>?rx > 0\<close>
	+ by simp
	+
	+ let ?ru = "poincare_distance u z"
	+ have "?ru > 0"
	+ using poincare_distance_ge0[of u z] in_disc
	+ using cong
	+ using poincare_distance_eq_0_iff[of z u] poincare_distance_eq_0_iff[of z v]
	+ using poincare_distance_eq_0_iff
	+ by force
	+
	+ have "z \<in> poincare_circle u ?ru \<inter> poincare_circle v ?ru"
	+ using cong in_disc
	+ unfolding poincare_circle_def
	+ by (simp add: poincare_distance_sym)
	+
	+ hence "is_real z'"
	+ using intersect_poincare_circles_conjugate_centers[of u v ?ru z] \<open>u = conjugate v\<close> zuv
	+ using in_disc \<open>u \<noteq> v\<close> \<open>?ru > 0\<close>
	+ by simp
	+
	+ thus "poincare_collinear {0\<^sub>h, of_complex x, z}"
	+ using poincare_line_0_real_is_x_axis[of "of_complex x"] x \<open>x \<noteq> 0\<close> zuv \<open>0\<^sub>h \<in> circline_set x_axis\<close>
	+ unfolding poincare_collinear_def
	+ by (rule_tac x=x_axis in exI, auto simp add: circline_set_x_axis)
	+ qed
	+ next
	+ fix M x y
	+ assume 1: "unit_disc_fix M" "x \<in> unit_disc" "y \<in> unit_disc" "x \<noteq> y"
	+ assume 2: "?P (moebius_pt M x) (moebius_pt M y)"
	+ show "?P x y"
	+ proof safe
	+ fix z u v
	+ assume "z \<in> unit_disc" "u \<in> unit_disc" "v \<in> unit_disc"
	+ "?cong x u x v" "?cong y u y v" "?cong z u z v" "u \<noteq> v"
	+ hence "poincare_collinear {moebius_pt M x, moebius_pt M y, moebius_pt M z}"
	+ using 1 2[rule_format, of "moebius_pt M z" "moebius_pt M u" "moebius_pt M v"]
	+ by simp
	+ then obtain p where "is_poincare_line p" "{moebius_pt M x, moebius_pt M y, moebius_pt M z} \<subseteq> circline_set p"
	+ unfolding poincare_collinear_def
	+ by auto
	+ thus "poincare_collinear {x, y, z}"
	+ using \<open>unit_disc_fix M\<close>
	+ unfolding poincare_collinear_def
	+ by (rule_tac x="moebius_circline (-M) p" in exI, auto)
	+ qed
	+ qed fact+
	+
	+ thus ?thesis
	+ using assms
	+ using poincare_collinear3_between[of x y z]
	+ using poincare_between_rev
	+ by auto
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Lower dimension axiom\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lemma lower_dimension_axiom:
	+ shows "\<exists> a \<in> unit_disc. \<exists> b \<in> unit_disc. \<exists> c \<in> unit_disc.
	+ \<not> poincare_between a b c \<and> \<not> poincare_between b c a \<and> \<not> poincare_between c a b"
	+proof-
	+ let ?u = "of_complex (1/2)" and ?v = "of_complex (\<i>/2)"
	+ have 1: "0\<^sub>h \<in> unit_disc" and 2: "?u \<in> unit_disc" and 3: "?v \<in> unit_disc"
	+ by simp_all
	+ have *: "\<not> poincare_collinear {0\<^sub>h, ?u, ?v}"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ then obtain p where "is_poincare_line p" "{0\<^sub>h, ?u, ?v} \<subseteq> circline_set p"
	+ unfolding poincare_collinear_def
	+ by auto
	+ moreover
	+ have "of_complex (1 / 2) \<noteq> of_complex (\<i> / 2)"
	+ using of_complex_inj
	+ by fastforce
	+ ultimately
	+ have "0\<^sub>h \<in> circline_set (poincare_line ?u ?v)"
	+ using unique_poincare_line[of ?u ?v p]
	+ by auto
	+ thus False
	+ unfolding circline_set_def
	+ by simp (transfer, transfer, simp add: vec_cnj_def)
	+ qed
	+ show ?thesis
	+ apply (rule_tac x="0\<^sub>h" in bexI, rule_tac x="?u" in bexI, rule_tac x="?v" in bexI)
	+ apply (rule ccontr, auto)
	+ using *
	+ using poincare_between_poincare_collinear[OF 1 2 3]
	+ using poincare_between_poincare_collinear[OF 2 3 1]
	+ using poincare_between_poincare_collinear[OF 3 1 2]
	+ by (metis insert_commute)+
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Negated Euclidean axiom\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+lemma negated_euclidean_axiom_aux:
	+ assumes "on_circline H (of_complex (1/2 + \<i>/2))" and "is_poincare_line H"
	+ assumes "intersects_x_axis_positive H"
	+ shows "\<not> intersects_y_axis_positive H"
	+ using assms
	+proof (transfer, transfer)
	+ fix H
	+ assume hh: "hermitean H \<and> H \<noteq> mat_zero" "is_poincare_line_cmat H"
	+ obtain A B C D where "H = (A, B, C, D)"
	+ by (cases H, auto)
	+ hence *: "is_real A" "H = (A, B, cnj B, A)" "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
	+ using hermitean_elems[of A B C D] hh
	+ by auto
	+
	+ assume "intersects_x_axis_positive_cmat H"
	+ hence "Re A \<noteq> 0" "Re B / Re A < - 1"
	+ using *
	+ by auto
	+
	+ assume "on_circline_cmat_cvec H (of_complex_cvec (1 / 2 + \<i> / 2))"
	+ hence "6A + 4Re B + 4*Im B = 0"
	+ using *
	+ unfolding cor_mult
	+ apply (subst Re_express_cnj[of B])
	+ apply (subst Im_express_cnj[of B])
	+ apply (simp add: vec_cnj_def)
	+ apply (simp add: field_simps)
	+ done
	+ hence "Re (6A + 4Re B + 4*Im B) = 0"
	+ by simp
	+ hence "3Re A + 2Re B + 2*Im B = 0"
	+ using \<open>is_real A\<close>
	+ by simp
	+
	+ hence "3/2 + Re B/Re A + Im B/Re A = 0"
	+ using \<open>Re A \<noteq> 0\<close>
	+ by (simp add: field_simps)
	+
	+ hence "-Im B/Re A - 3/2 < -1"
	+ using \<open>Re B / Re A < -1\<close>
	+ by simp
	+ hence "Im B/Re A > -1/2"
	+ by (simp add: field_simps)
	+ thus "\<not> intersects_y_axis_positive_cmat H"
	+ using *
	+ by simp
	+qed
	+
	+lemma negated_euclidean_axiom:
	+ shows "\<exists> a b c d t.
	+ a \<in> unit_disc \<and> b \<in> unit_disc \<and> c \<in> unit_disc \<and> d \<in> unit_disc \<and> t \<in> unit_disc \<and>
	+ poincare_between a d t \<and> poincare_between b d c \<and> a \<noteq> d \<and>
	+ (\<forall> x y. x \<in> unit_disc \<and> y \<in> unit_disc \<and>
	+ poincare_between a b x \<and> poincare_between x t y \<longrightarrow> \<not> poincare_between a c y)"
	+proof-
	+ let ?a = "0\<^sub>h"
	+ let ?b = "of_complex (1/2)"
	+ let ?c = "of_complex (\<i>/2)"
	+ let ?dl = "(5 - sqrt 17) / 4"
	+ let ?d = "of_complex (?dl + \<i>*?dl)"
	+ let ?t = "of_complex (1/2 + \<i>/2)"
	+
	+ have "?dl \<noteq> 0"
	+ proof-
	+ have "(sqrt 17)\<^sup>2 \<noteq> 5\<^sup>2"
	+ by simp
	+ hence "sqrt 17 \<noteq> 5"
	+ by force
	+ thus ?thesis
	+ by simp
	+ qed
	+
	+ have "?d \<noteq> ?a"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "?dl + \<i>*?dl = 0"
	+ by simp
	+ hence "Re (?dl + \<i>*?dl) = 0"
	+ by simp
	+ thus False
	+ using \<open>?dl \<noteq> 0\<close>
	+ by simp
	+ qed
	+
	+ have "?dl > 0"
	+ proof-
	+ have "(sqrt 17)\<^sup>2 < 5\<^sup>2"
	+ by (simp add: power2_eq_square)
	+ hence "sqrt 17 < 5"
	+ by (rule power2_less_imp_less, simp)
	+ thus ?thesis
	+ by simp
	+ qed
	+
	+ have "?a \<noteq> ?b"
	+ by (metis divide_eq_0_iff of_complex_zero_iff zero_neq_numeral zero_neq_one)
	+
	+ have "?a \<noteq> ?c"
	+ by (metis complex_i_not_zero divide_eq_0_iff of_complex_zero_iff zero_neq_numeral)
	+
	+ show ?thesis
	+ proof (rule_tac x="?a" in exI, rule_tac x="?b" in exI, rule_tac x="?c" in exI, rule_tac x="?d" in exI, rule_tac x="?t" in exI, safe)
	+
	+
	+ show "?a \<in> unit_disc" "?b \<in> unit_disc" "?c \<in> unit_disc" "?t \<in> unit_disc"
	+ by (auto simp add: cmod_def power2_eq_square)
	+
	+ have cmod_d: "cmod (?dl + \<i>?dl) = ?dl sqrt 2"
	+ using \<open>?dl > 0\<close>
	+ unfolding cmod_def
	+ by (simp add: real_sqrt_mult)
	+
	+ show "?d \<in> unit_disc"
	+ proof-
	+ have "?dl < 1 / sqrt 2"
	+ proof-
	+ have "17\<^sup>2 < (5 * sqrt 17)\<^sup>2"
	+ by (simp add: field_simps)
	+ hence "17 < 5 * sqrt 17"
	+ by (rule power2_less_imp_less, simp)
	+ hence "?dl\<^sup>2 < (1 / sqrt 2)\<^sup>2"
	+ by (simp add: power2_eq_square field_simps)
	+ thus "?dl < 1 / sqrt 2"
	+ by (rule power2_less_imp_less, simp)
	+ qed
	+ thus ?thesis
	+ using cmod_d
	+ by (simp add: field_simps)
	+ qed
	+
	+ have cmod_d: "1 - (cmod (to_complex ?d))\<^sup>2 = (-17 + 5*sqrt 17) / 4" (is "_ = ?cmod_d")
	+ apply (simp only: to_complex_of_complex)
	+ apply (subst cmod_d)
	+ apply (simp add: power_mult_distrib)
	+ apply (simp add: power2_eq_square field_simps)
	+ done
	+
	+ have cmod_d_c: "(cmod (to_complex ?d - to_complex ?c))\<^sup>2 = (17 - 4*sqrt 17) / 4" (is "_ = ?cmod_dc")
	+ unfolding cmod_square
	+ by (simp add: field_simps)
	+
	+ have cmod_c: "1 - (cmod (to_complex ?c))\<^sup>2 = 3/4" (is "_ = ?cmod_c")
	+ by (simp add: power2_eq_square)
	+
	+ have xx: "\<And> x::real. x + x = 2*x"
	+ by simp
	+
	+ have "cmod ((to_complex ?b) - (to_complex ?d)) = cmod ((to_complex ?d) - (to_complex ?c))"
	+ by (simp add: cmod_def power2_eq_square field_simps)
	+ moreover
	+ have "cmod (to_complex ?b) = cmod (to_complex ?c)"
	+ by simp
	+ ultimately
	+ have *: "poincare_distance_formula' (to_complex ?b) (to_complex ?d) =
	+ poincare_distance_formula' (to_complex ?d) (to_complex ?c)"
	+ unfolding poincare_distance_formula'_def
	+ by simp
	+
	+ have **: "poincare_distance_formula' (to_complex ?d) (to_complex ?c) = (sqrt 17) / 3"
	+ unfolding poincare_distance_formula'_def
	+ proof (subst cmod_d, subst cmod_c, subst cmod_d_c)
	+ have "(sqrt 17 * 15)\<^sup>2 \<noteq> 51\<^sup>2"
	+ by simp
	+ hence "sqrt 17 * 15 \<noteq> 51"
	+ by force
	+ hence "sqrt 17 * 15 - 51 \<noteq> 0"
	+ by simp
	+
	+ have "(5 * sqrt 17)\<^sup>2 \<noteq> 17\<^sup>2"
	+ by simp
	+ hence "5 * sqrt 17 \<noteq> 17"
	+ by force
	+ hence "?cmod_d * ?cmod_c \<noteq> 0"
	+ by simp
	+ hence "1 + 2 * (?cmod_dc / (?cmod_d * ?cmod_c)) = (?cmod_d * ?cmod_c + 2 * ?cmod_dc) / (?cmod_d * ?cmod_c)"
	+ using add_frac_num[of "?cmod_d * ?cmod_c" "2 * ?cmod_dc" 1]
	+ by (simp add: field_simps)
	+ also have "... = (64 * (85 - sqrt 17 * 17)) / (64 * (sqrt 17 * 15 - 51))"
	+ by (simp add: field_simps)
	+ also have "... = (85 - sqrt 17 * 17) / (sqrt 17 * 15 - 51)"
	+ by (rule mult_divide_mult_cancel_left, simp)
	+ also have "... = sqrt 17 / 3"
	+ by (subst frac_eq_eq, fact, simp, simp add: field_simps)
	+ finally
	+ show "1 + 2 * (?cmod_dc / (?cmod_d * ?cmod_c)) = sqrt 17 / 3"
	+ .
	+ qed
	+
	+ have "sqrt 17 \<ge> 3"
	+ proof-
	+ have "(sqrt 17)\<^sup>2 \<ge> 3\<^sup>2"
	+ by simp
	+ thus ?thesis
	+ by (rule power2_le_imp_le, simp)
	+ qed
	+ thus "poincare_between ?b ?d ?c"
	+ unfolding poincare_between_sum_distances[OF \<open>?b \<in> unit_disc\<close> \<open>?d \<in> unit_disc\<close> \<open>?c \<in> unit_disc\<close>]
	+ unfolding poincare_distance_formula[OF \<open>?b \<in> unit_disc\<close> \<open>?d \<in> unit_disc\<close>]
	+ unfolding poincare_distance_formula[OF \<open>?d \<in> unit_disc\<close> \<open>?c \<in> unit_disc\<close>]
	+ unfolding poincare_distance_formula[OF \<open>?b \<in> unit_disc\<close> \<open>?c \<in> unit_disc\<close>]
	+ unfolding poincare_distance_formula_def
	+ apply (subst , subst xx, subst *, subst arcosh_double)
	+ apply (simp_all add: cmod_def power2_eq_square)
	+ done
	+
	+ show "poincare_between ?a ?d ?t"
	+ proof (subst poincare_between_0uv[OF \<open>?d \<in> unit_disc\<close> \<open>?t \<in> unit_disc\<close> \<open>?d \<noteq> ?a\<close>])
	+ show "?t \<noteq> 0\<^sub>h"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "1/2 + \<i>/2 = 0"
	+ by simp
	+ hence "Re (1/2 + \<i>/2) = 0"
	+ by simp
	+ thus False
	+ by simp
	+ qed
	+ next
	+ have "19\<^sup>2 \<le> (5 * sqrt 17)\<^sup>2"
	+ by simp
	+ hence "19 \<le> 5 * sqrt 17"
	+ by (rule power2_le_imp_le, simp)
	+ hence "cmod (to_complex ?d) \<le> cmod (to_complex ?t)"
	+ by (simp add: Let_def cmod_def power2_eq_square field_simps)
	+ moreover
	+ have "arg (to_complex ?d) = arg (to_complex ?t)"
	+ proof-
	+ have 1: "to_complex ?d = ((5 - sqrt 17) / 4) * (1 + \<i>)"
	+ by (simp add: field_simps)
	+
	+ have 2: "to_complex ?t = (cor (1/2)) * (1 + \<i>)"
	+ by (simp add: field_simps)
	+
	+ have "(sqrt 17)\<^sup>2 < 5\<^sup>2"
	+ by simp
	+ hence "sqrt 17 < 5"
	+ by (rule power2_less_imp_less, simp)
	+ hence 3: "(5 - sqrt 17) / 4 > 0"
	+ by simp
	+
	+ have 4: "(1::real) / 2 > 0"
	+ by simp
	+
	+ show ?thesis
	+ apply (subst 1, subst 2)
	+ apply (subst arg_mult_real_positive[OF 3])
	+ apply (subst arg_mult_real_positive[OF 4])
	+ by simp
	+ qed
	+ ultimately
	+ show "let d' = to_complex ?d; t' = to_complex ?t in arg d' = arg t' \<and> cmod d' \<le> cmod t'"
	+ by simp
	+ qed
	+
	+ show "?a = ?d \<Longrightarrow> False"
	+ using \<open>?d \<noteq> ?a\<close>
	+ by simp
	+
	+ fix x y
	+ assume "x \<in> unit_disc" "y \<in> unit_disc"
	+
	+ assume abx: "poincare_between ?a ?b x"
	+ hence "x \<in> circline_set x_axis"
	+ using poincare_between_poincare_line_uvz[of ?a ?b x] \<open>x \<in> unit_disc\<close> \<open>?a \<noteq> ?b\<close>
	+ using poincare_line_0_real_is_x_axis[of ?b]
	+ by (auto simp add: circline_set_x_axis)
	+
	+ have "x \<noteq> 0\<^sub>h"
	+ using abx poincare_between_sandwich[of ?a ?b] \<open>?a \<noteq> ?b\<close>
	+ by auto
	+
	+ have "x \<in> positive_x_axis"
	+ using \<open>x \<in> circline_set x_axis\<close> \<open>x \<noteq> 0\<^sub>h\<close> \<open>x \<in> unit_disc\<close>
	+ using abx poincare_between_x_axis_0uv[of "1/2" "Re (to_complex x)"]
	+ unfolding circline_set_x_axis positive_x_axis_def
	+ by (auto simp add: cmod_eq_Re abs_less_iff complex_eq_if_Re_eq)
	+
	+ assume acy: "poincare_between ?a ?c y"
	+ hence "y \<in> circline_set y_axis"
	+ using poincare_between_poincare_line_uvz[of ?a ?c y] \<open>y \<in> unit_disc\<close> \<open>?a \<noteq> ?c\<close>
	+ using poincare_line_0_imag_is_y_axis[of ?c]
	+ by (auto simp add: circline_set_y_axis)
	+
	+ have "y \<noteq> 0\<^sub>h"
	+ using acy poincare_between_sandwich[of ?a ?c] \<open>?a \<noteq> ?c\<close>
	+ by auto
	+
	+ have "y \<in> positive_y_axis"
	+ proof-
	+ have " \<And>x. \<lbrakk>x \<noteq> 0; poincare_between 0\<^sub>h (of_complex (\<i> / 2)) (of_complex x); is_imag x; - 1 < Im x\<rbrakk> \<Longrightarrow> 0 < Im x"
	+ by (smt add.left_neutral complex.expand divide_complex_def complex_eq divide_less_0_1_iff divide_less_eq_1_pos imaginary_unit.simps(1) mult.left_neutral of_real_1 of_real_add of_real_divide of_real_eq_0_iff one_add_one poincare_between_y_axis_0uv zero_complex.simps(1) zero_complex.simps(2) zero_less_divide_1_iff)
	+ thus ?thesis
	+ using \<open>y \<in> circline_set y_axis\<close> \<open>y \<noteq> 0\<^sub>h\<close> \<open>y \<in> unit_disc\<close>
	+ using acy
	+ unfolding circline_set_y_axis positive_y_axis_def
	+ by (auto simp add: cmod_eq_Im abs_less_iff)
	+ qed
	+
	+ have "x \<noteq> y"
	+ using \<open>x \<in> positive_x_axis\<close> \<open>y \<in> positive_y_axis\<close>
	+ unfolding positive_x_axis_def positive_y_axis_def circline_set_x_axis circline_set_y_axis
	+ by auto
	+
	+ assume xty: "poincare_between x ?t y"
	+
	+ let ?xy = "poincare_line x y"
	+
	+ have "?t \<in> circline_set ?xy"
	+ using xty poincare_between_poincare_line_uzv[OF \<open>x \<noteq> y\<close> \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close> \<open>?t \<in> unit_disc\<close>]
	+ by simp
	+
	+ moreover
	+
	+ have "?xy \<noteq> x_axis"
	+ using poincare_line_circline_set[OF \<open>x \<noteq> y\<close>] \<open>y \<in> positive_y_axis\<close>
	+ by (auto simp add: circline_set_x_axis positive_y_axis_def)
	+ hence "intersects_x_axis_positive ?xy"
	+ using intersects_x_axis_positive_iff[of "?xy"] \<open>x \<noteq> y\<close> \<open>x \<in> unit_disc\<close> \<open>x \<in> positive_x_axis\<close>
	+ by auto
	+
	+ moreover
	+
	+ have "?xy \<noteq> y_axis"
	+ using poincare_line_circline_set[OF \<open>x \<noteq> y\<close>] \<open>x \<in> positive_x_axis\<close>
	+ by (auto simp add: circline_set_y_axis positive_x_axis_def)
	+ hence "intersects_y_axis_positive ?xy"
	+ using intersects_y_axis_positive_iff[of "?xy"] \<open>x \<noteq> y\<close> \<open>y \<in> unit_disc\<close> \<open>y \<in> positive_y_axis\<close>
	+ by auto
	+
	+ ultimately
	+
	+ show False
	+ using negated_euclidean_axiom_aux[of ?xy] \<open>x \<noteq> y\<close>
	+ unfolding circline_set_def
	+ by auto
	+ qed
	+qed
	+
	+text \<open>Alternate form of the Euclidean axiom -- this one is much easier to prove\<close>
	+lemma negated_euclidean_axiom':
	+ shows "\<exists> a b c.
	+ a \<in> unit_disc \<and> b \<in> unit_disc \<and> c \<in> unit_disc \<and> \<not>(poincare_collinear {a, b, c}) \<and>
	+ \<not>(\<exists> x. x \<in> unit_disc \<and>
	+ poincare_distance a x = poincare_distance b x \<and>
	+ poincare_distance a x = poincare_distance c x)"
	+proof-
	+ let ?a = "of_complex (\<i>/2)"
	+ let ?b = "of_complex (-\<i>/2)"
	+ let ?c = "of_complex (1/5)"
	+
	+ have "(\<i>/2) \<noteq> (-\<i>/2)"
	+ by simp
	+ hence "?a \<noteq> ?b"
	+ by (metis to_complex_of_complex)
	+ have "(\<i>/2) \<noteq> (1/5)"
	+ by simp
	+ hence "?a \<noteq> ?c"
	+ by (metis to_complex_of_complex)
	+ have "(-\<i>/2) \<noteq> (1/5)"
	+ by (metis add.inverse_inverse cmod_divide div_by_1 divide_divide_eq_right inverse_eq_divide minus_divide_left mult.commute norm_ii norm_minus_cancel norm_numeral norm_one numeral_One numeral_eq_iff semiring_norm(88))
	+ hence "?b \<noteq> ?c"
	+ by (metis to_complex_of_complex)
	+
	+ have "?a \<in> unit_disc" "?b \<in> unit_disc" "?c \<in> unit_disc"
	+ by auto
	+
	+ moreover
	+
	+ have "\<not>(poincare_collinear {?a, ?b, ?c})"
	+ unfolding poincare_collinear_def
	+ proof(rule ccontr)
	+ assume " \<not> (\<nexists>p. is_poincare_line p \<and> {?a, ?b, ?c} \<subseteq> circline_set p)"
	+ then obtain p where "is_poincare_line p \<and> {?a, ?b, ?c} \<subseteq> circline_set p"
	+ by auto
	+ let ?ab = "poincare_line ?a ?b"
	+ have "p = ?ab"
	+ using \<open>is_poincare_line p \<and> {?a, ?b, ?c} \<subseteq> circline_set p\<close>
	+ using unique_poincare_line[of ?a ?b] \<open>?a \<noteq> ?b\<close> \<open>?a \<in> unit_disc\<close> \<open>?b \<in> unit_disc\<close>
	+ by auto
	+ have "?c \<notin> circline_set ?ab"
	+ proof(rule ccontr)
	+ assume "\<not> ?c \<notin> circline_set ?ab"
	+ have "poincare_between ?a 0\<^sub>h ?b"
	+ unfolding poincare_between_def
	+ using cross_ratio_0inf by auto
	+ hence "0\<^sub>h \<in> circline_set ?ab"
	+ using \<open>?a \<noteq> ?b\<close> \<open>?a \<in> unit_disc\<close> \<open>?b \<in> unit_disc\<close>
	+ using poincare_between_poincare_line_uzv zero_in_unit_disc
	+ by blast
	+ hence "?ab = poincare_line 0\<^sub>h ?a"
	+ using unique_poincare_line[of ?a ?b] \<open>?a \<noteq> ?b\<close> \<open>?a \<in> unit_disc\<close> \<open>?b \<in> unit_disc\<close>
	+ using \<open>is_poincare_line p \<and> {?a, ?b, ?c} \<subseteq> circline_set p\<close>
	+ using \<open>p = ?ab\<close> poincare_line_circline_set(1) unique_poincare_line
	+ by (metis add.inverse_neutral divide_minus_left of_complex_zero_iff zero_in_unit_disc)
	+ hence "(\<i>/2) * cnj(1/5) = cnj(\<i>/2) * (1/5)"
	+ using poincare_collinear_zero_iff[of "(\<i>/2)" "(1/5)"]
	+ using \<open>?a \<noteq> ?c\<close> \<open>\<not> ?c \<notin> circline_set ?ab\<close> \<open>?a \<in> unit_disc\<close> \<open>?c \<in> unit_disc\<close> \<open>p = ?ab\<close>
	+ using \<open>0\<^sub>h \<in> circline_set ?ab\<close> \<open>is_poincare_line p \<and> {?a, ?b, ?c} \<subseteq> circline_set p\<close>
	+ using poincare_collinear_def by auto
	+ thus False
	+ by simp
	+ qed
	+ thus False
	+ using \<open>p = ?ab\<close> \<open>is_poincare_line p \<and> {?a, ?b, ?c} \<subseteq> circline_set p\<close>
	+ by auto
	+ qed
	+
	+ moreover
	+
	+ have "\<not>(\<exists> x. x \<in> unit_disc \<and>
	+ poincare_distance ?a x = poincare_distance ?b x \<and>
	+ poincare_distance ?a x = poincare_distance ?c x)"
	+ proof(rule ccontr)
	+ assume "\<not> ?thesis"
	+ then obtain x where "x \<in> unit_disc" "poincare_distance ?a x = poincare_distance ?b x"
	+ "poincare_distance ?a x = poincare_distance ?c x"
	+ by blast
	+ let ?x = "to_complex x"
	+ have "poincare_distance_formula' (\<i>/2) ?x = poincare_distance_formula' (-\<i>/2) ?x"
	+ using \<open>poincare_distance ?a x = poincare_distance ?b x\<close>
	+ using \<open>x \<in> unit_disc\<close> \<open>?a \<in> unit_disc\<close> \<open>?b \<in> unit_disc\<close>
	+ by (metis cosh_dist to_complex_of_complex)
	+ hence "(cmod (\<i> / 2 - ?x))\<^sup>2 = (cmod (- \<i> / 2 - ?x))\<^sup>2"
	+ unfolding poincare_distance_formula'_def
	+ apply (simp add:field_simps)
	+ using \<open>x \<in> unit_disc\<close> unit_disc_cmod_square_lt_1 by fastforce
	+ hence "Im ?x = 0"
	+ unfolding cmod_def
	+ by (simp add: power2_eq_iff)
	+
	+ have "1 - (Re ?x)\<^sup>2 \<noteq> 0"
	+ using \<open>x \<in> unit_disc\<close> unit_disc_cmod_square_lt_1
	+ using cmod_power2 by force
	+ hence "24 - 24 * (Re ?x)\<^sup>2 \<noteq> 0"
	+ by simp
	+ have "poincare_distance_formula' (\<i>/2) ?x = poincare_distance_formula' (1/5) ?x"
	+ using \<open>poincare_distance ?a x = poincare_distance ?c x\<close>
	+ using \<open>x \<in> unit_disc\<close> \<open>?a \<in> unit_disc\<close> \<open>?c \<in> unit_disc\<close>
	+ by (metis cosh_dist to_complex_of_complex)
	+ hence "(2 + 8 * (Re ?x)\<^sup>2) /(3 - 3 * (Re ?x)\<^sup>2) = 2 * (1 - Re ?x * 5)\<^sup>2 / (24 - 24 * (Re ?x)\<^sup>2)" (is "?lhs = ?rhs")
	+ unfolding poincare_distance_formula'_def
	+ apply (simp add:field_simps)
	+ unfolding cmod_def
	+ using \<open>Im ?x = 0\<close>
	+ by (simp add:field_simps)
	+ hence : "?lhs (24 - 24 * (Re ?x)\<^sup>2) = ?rhs * (24 - 24 * (Re ?x)\<^sup>2) "
	+ using \<open>(24 - 24 * (Re ?x)\<^sup>2) \<noteq> 0\<close>
	+ by simp
	+ have "?lhs * (24 - 24 * (Re ?x)\<^sup>2) = (2 + 8 * (Re ?x)\<^sup>2) * 8"
	+ using \<open>(24 - 24 * (Re ?x)\<^sup>2) \<noteq> 0\<close> \<open>1 - (Re ?x)\<^sup>2 \<noteq> 0\<close>
	+ by (simp add:field_simps)
	+ have "?rhs * (24 - 24 * (Re ?x)\<^sup>2) = 2 * (1 - Re ?x * 5)\<^sup>2"
	+ using \<open>(24 - 24 * (Re ?x)\<^sup>2) \<noteq> 0\<close> \<open>1 - (Re ?x)\<^sup>2 \<noteq> 0\<close>
	+ by (simp add:field_simps)
	+ hence "(2 + 8 * (Re ?x)\<^sup>2) * 8 = 2 * (1 - Re ?x * 5)\<^sup>2"
	+ using * \<open>?lhs * (24 - 24 * (Re ?x)\<^sup>2) = (2 + 8 * (Re ?x)\<^sup>2) * 8\<close>
	+ by simp
	+ hence "7 * (Re ?x)\<^sup>2 + 10 * (Re ?x) + 7 = 0"
	+ by (simp add:field_simps comm_ring_1_class.power2_diff)
	+ thus False
	+ using discriminant_iff[of 7 "Re (to_complex x)" 10 7] discrim_def[of 7 10 7]
	+ by auto
	+ qed
	+
	+ ultimately show ?thesis
	+ apply (rule_tac x="?a" in exI)
	+ apply (rule_tac x="?b" in exI)
	+ apply (rule_tac x="?c" in exI)
	+ by auto
	+qed
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Continuity axiom\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text \<open>The set $\phi$ is on the left of the set $\psi$\<close>
	+abbreviation set_order where
	+ "set_order A \<phi> \<psi> \<equiv> \<forall>x\<in> unit_disc. \<forall>y\<in> unit_disc. \<phi> x \<and> \<psi> y \<longrightarrow> poincare_between A x y"
	+text \<open>The point $B$ is between the sets $\phi$ and $\psi$\<close>
	+abbreviation point_between_sets where
	+ "point_between_sets \<phi> B \<psi> \<equiv> \<forall>x\<in> unit_disc. \<forall>y\<in> unit_disc. \<phi> x \<and> \<psi> y \<longrightarrow> poincare_between x B y"
	+
	+lemma continuity:
	+ assumes "\<exists> A \<in> unit_disc. set_order A \<phi> \<psi>"
	+ shows "\<exists> B \<in> unit_disc. point_between_sets \<phi> B \<psi>"
	+proof (cases "(\<exists> x0 \<in> unit_disc. \<phi> x0) \<and> (\<exists> y0 \<in> unit_disc. \<psi> y0)")
	+ case False
	+ thus ?thesis
	+ using assms by blast
	+next
	+ case True
	+ then obtain Y0 where "\<psi> Y0" "Y0 \<in> unit_disc"
	+ by auto
	+ obtain A where *: "A \<in> unit_disc" "set_order A \<phi> \<psi>"
	+ using assms
	+ by auto
	+ show ?thesis
	+ proof(cases "\<forall> x \<in> unit_disc. \<phi> x \<longrightarrow> x = A")
	+ case True
	+ thus ?thesis
	+ using \<open>A \<in> unit_disc\<close>
	+ using poincare_between_nonstrict(1) by blast
	+ next
	+ case False
	+ then obtain X0 where "\<phi> X0" "X0 \<noteq> A" "X0 \<in> unit_disc"
	+ by auto
	+ have "Y0 \<noteq> A"
	+ proof(rule ccontr)
	+ assume "\<not> Y0 \<noteq> A"
	+ hence "\<forall> x \<in> unit_disc. \<phi> x \<longrightarrow> poincare_between A x A"
	+ using * \<open>\<psi> Y0\<close>
	+ by (cases A) force
	+ hence "\<forall> x \<in> unit_disc. \<phi> x \<longrightarrow> x = A"
	+ using * poincare_between_sandwich by blast
	+ thus False
	+ using False by auto
	+ qed
	+
	+ show ?thesis
	+ proof (cases "\<exists> B \<in> unit_disc. \<phi> B \<and> \<psi> B")
	+ case True
	+ then obtain B where "B \<in> unit_disc" "\<phi> B" "\<psi> B"
	+ by auto
	+ hence "\<forall> x \<in> unit_disc. \<phi> x \<longrightarrow> poincare_between A x B"
	+ using * by auto
	+ have "\<forall> y \<in> unit_disc. \<psi> y \<longrightarrow> poincare_between A B y"
	+ using * \<open>B \<in> unit_disc\<close> \<open>\<phi> B\<close>
	+ by auto
	+
	+ show ?thesis
	+ proof(rule+)
	+ show "B \<in> unit_disc"
	+ by fact
	+ next
	+ fix x y
	+ assume "x \<in> unit_disc" "y \<in> unit_disc" "\<phi> x \<and> \<psi> y"
	+ hence "poincare_between A x B" "poincare_between A B y"
	+ using \<open>\<forall> x \<in> unit_disc. \<phi> x \<longrightarrow> poincare_between A x B\<close>
	+ using \<open>\<forall> y \<in> unit_disc. \<psi> y \<longrightarrow> poincare_between A B y\<close>
	+ by simp+
	+ thus "poincare_between x B y"
	+ using \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close> \<open>B \<in> unit_disc\<close> \<open>A \<in> unit_disc\<close>
	+ using poincare_between_transitivity[of A x B y]
	+ by simp
	+ qed
	+ next
	+ case False
	+ have "poincare_between A X0 Y0"
	+ using \<open>\<phi> X0\<close> \<open>\<psi> Y0\<close> * \<open>Y0 \<in> unit_disc\<close> \<open>X0 \<in> unit_disc\<close>
	+ by auto
	+ have "\<forall> \<phi>. \<forall> \<psi>. set_order A \<phi> \<psi> \<and> \<not> (\<exists> B \<in> unit_disc. \<phi> B \<and> \<psi> B) \<and> \<phi> X0 \<and>
	+ (\<exists> y \<in> unit_disc. \<psi> y) \<and> (\<exists> x \<in> unit_disc. \<phi> x)
	+ \<longrightarrow> (\<exists> B \<in> unit_disc. point_between_sets \<phi> B \<psi>)"
	+ (is "?P A X0")
	+ proof (rule wlog_positive_x_axis[where P="?P"])
	+ show "A \<in> unit_disc"
	+ by fact
	+ next
	+ show "X0 \<in> unit_disc"
	+ by fact
	+ next
	+ show "A \<noteq> X0"
	+ using \<open>X0 \<noteq> A\<close> by simp
	+ next
	+ fix M u v
	+ let ?M = "\<lambda> x. moebius_pt M x"
	+ let ?Mu = "?M u" and ?Mv = "?M v"
	+ assume hip: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
	+ "?P ?Mu ?Mv"
	+ show "?P u v"
	+ proof safe
	+ fix \<phi> \<psi> x y
	+ assume "set_order u \<phi> \<psi>" "\<not> (\<exists>B\<in>unit_disc. \<phi> B \<and> \<psi> B)" "\<phi> v"
	+ "y \<in> unit_disc" "\<psi> y" "x \<in> unit_disc" "\<phi> x"
	+
	+ let ?M\<phi> = "\<lambda> X'. \<exists> X. \<phi> X \<and> ?M X = X'"
	+ let ?M\<psi> = "\<lambda> X'. \<exists> X. \<psi> X \<and> ?M X = X'"
	+
	+ obtain M\<phi> where "M\<phi> = ?M\<phi>" by simp
	+ obtain M\<psi> where "M\<psi> = ?M\<psi>" by simp
	+
	+ have "M\<phi> ?Mv"
	+ using \<open>\<phi> v\<close> using \<open>M\<phi> = ?M\<phi>\<close>
	+ by blast
	+ moreover
	+ have "\<not> (\<exists> B \<in>unit_disc. M\<phi> B \<and> M\<psi> B)"
	+ using \<open>\<not> (\<exists>B\<in>unit_disc. \<phi> B \<and> \<psi> B)\<close>
	+ using \<open>M\<phi> = ?M\<phi>\<close> \<open>M\<psi> = ?M\<psi>\<close>
	+ by (metis hip(1) moebius_pt_invert unit_disc_fix_discI unit_disc_fix_moebius_inv)
	+ moreover
	+ have "\<exists> y \<in> unit_disc. M\<psi> y"
	+ using \<open>y \<in> unit_disc\<close> \<open>\<psi> y\<close> \<open>M\<psi> = ?M\<psi>\<close> \<open>unit_disc_fix M\<close>
	+ by auto
	+ moreover
	+ have "set_order ?Mu ?M\<phi> ?M\<psi>"
	+ proof ((rule ballI)+, rule impI)
	+ fix Mx My
	+ assume "Mx \<in> unit_disc" "My \<in> unit_disc" "?M\<phi> Mx \<and> ?M\<psi> My"
	+ then obtain x y where "\<phi> x \<and> ?M x = Mx" "\<psi> y \<and> ?M y = My"
	+ by blast
	+
	+ hence "x \<in> unit_disc" "y \<in> unit_disc"
	+ using \<open>Mx \<in> unit_disc\<close> \<open>My \<in> unit_disc\<close> \<open>unit_disc_fix M\<close>
	+ by (metis moebius_pt_comp_inv_left unit_disc_fix_discI unit_disc_fix_moebius_inv)+
	+
	+ hence "poincare_between u x y"
	+ using \<open>set_order u \<phi> \<psi>\<close>
	+ using \<open>Mx \<in> unit_disc\<close> \<open>My \<in> unit_disc\<close> \<open>\<phi> x \<and> ?M x = Mx\<close> \<open>\<psi> y \<and> ?M y = My\<close>
	+ by blast
	+ then show "poincare_between ?Mu Mx My"
	+ using \<open>\<phi> x \<and> ?M x = Mx\<close> \<open>\<psi> y \<and> ?M y = My\<close>
	+ using \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close> \<open>u \<in> unit_disc\<close> \<open>unit_disc_fix M\<close>
	+ using unit_disc_fix_moebius_preserve_poincare_between by blast
	+ qed
	+
	+ hence "set_order ?Mu M\<phi> M\<psi>"
	+ using \<open>M\<phi> = ?M\<phi>\<close> \<open>M\<psi> = ?M\<psi>\<close>
	+ by simp
	+ ultimately
	+ have "\<exists> Mb \<in> unit_disc. point_between_sets M\<phi> Mb M\<psi>"
	+ using hip(5)
	+ by blast
	+ then obtain Mb where bbb:
	+ "Mb \<in> unit_disc" "point_between_sets ?M\<phi> Mb ?M\<psi>"
	+ using \<open>M\<phi> = ?M\<phi>\<close> \<open>M\<psi> = ?M\<psi>\<close>
	+ by auto
	+
	+ let ?b = "moebius_pt (moebius_inv M) Mb"
	+ show "\<exists> b \<in> unit_disc. point_between_sets \<phi> b \<psi>"
	+ proof (rule_tac x="?b" in bexI, (rule ballI)+, rule impI)
	+ fix x y
	+ assume "x \<in> unit_disc" "y \<in> unit_disc" "\<phi> x \<and> \<psi> y"
	+ hence "poincare_between u x y"
	+ using \<open>set_order u \<phi> \<psi>\<close>
	+ by blast
	+
	+ let ?Mx = "?M x" and ?My = "?M y"
	+
	+ have "?M\<phi> ?Mx" "?M\<psi> ?My"
	+ using \<open>\<phi> x \<and> \<psi> y\<close>
	+ by blast+
	+ have "?Mx \<in> unit_disc" "?My \<in> unit_disc"
	+ using \<open>x \<in> unit_disc\<close> \<open>unit_disc_fix M\<close> \<open>y \<in> unit_disc\<close>
	+ by auto
	+
	+ hence "poincare_between ?Mx Mb ?My"
	+ using \<open>?M\<phi> ?Mx\<close> \<open>?M\<psi> ?My\<close> \<open>?Mx \<in> unit_disc\<close> \<open>?My \<in> unit_disc\<close> bbb
	+ by auto
	+
	+ then show "poincare_between x ?b y"
	+ using \<open>unit_disc_fix M\<close>
	+ using \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close> \<open>Mb \<in> unit_disc\<close> \<open>?Mx \<in> unit_disc\<close> \<open>?My \<in> unit_disc\<close>
	+ using unit_disc_fix_moebius_preserve_poincare_between[of M x ?b y]
	+ by auto
	+ next
	+ show "?b \<in> unit_disc"
	+ using bbb \<open>unit_disc_fix M\<close>
	+ by auto
	+ qed
	+ qed
	+ next
	+ fix X
	+ assume xx: "is_real X" "0 < Re X" "Re X < 1"
	+ let ?X = "of_complex X"
	+ show "?P 0\<^sub>h ?X"
	+ proof ((rule allI)+, rule impI, (erule conjE)+)
	+ fix \<phi> \<psi>
	+ assume "set_order 0\<^sub>h \<phi> \<psi>" "\<not> (\<exists>B\<in>unit_disc. \<phi> B \<and> \<psi> B)" "\<phi> ?X"
	+ "\<exists>y\<in>unit_disc. \<psi> y" "\<exists>x\<in>unit_disc. \<phi> x"
	+ have "?X \<in> unit_disc"
	+ using xx
	+ by (simp add: cmod_eq_Re)
	+
	+ have \<psi>pos: "\<forall> y \<in> unit_disc. \<psi> y \<longrightarrow> (is_real (to_complex y) \<and> Re (to_complex y) > 0)"
	+ proof(rule ballI, rule impI)
	+ fix y
	+ let ?y = "to_complex y"
	+ assume "y \<in> unit_disc" "\<psi> y"
	+
	+ hence "poincare_between 0\<^sub>h ?X y"
	+ using \<open>set_order 0\<^sub>h \<phi> \<psi>\<close>
	+ using \<open>?X \<in> unit_disc\<close> \<open>\<phi> ?X\<close>
	+ by auto
	+
	+ thus "is_real ?y \<and> 0 < Re ?y"
	+ using xx \<open>?X \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close>
	+ by (metis (mono_tags, hide_lams) arg_0_iff of_complex_zero_iff poincare_between_0uv poincare_between_sandwich to_complex_of_complex unit_disc_to_complex_inj zero_in_unit_disc)
	+ qed
	+
	+ have \<phi>noneg: "\<forall> x \<in> unit_disc. \<phi> x \<longrightarrow> (is_real (to_complex x) \<and> Re (to_complex x) \<ge> 0)"
	+ proof(rule ballI, rule impI)
	+ fix x
	+ assume "x \<in> unit_disc" "\<phi> x"
	+
	+ obtain y where "y \<in> unit_disc" "\<psi> y"
	+ using \<open>\<exists> y \<in> unit_disc. \<psi> y\<close> by blast
	+
	+ let ?x = "to_complex x" and ?y = "to_complex y"
	+
	+ have "is_real ?y" "Re ?y > 0"
	+ using \<psi>pos \<open>\<psi> y\<close> \<open>y \<in> unit_disc\<close>
	+ by auto
	+
	+ have "poincare_between 0\<^sub>h x y"
	+ using \<open>set_order 0\<^sub>h \<phi> \<psi>\<close>
	+ using \<open>x \<in> unit_disc\<close> \<open>\<phi> x\<close> \<open>y\<in>unit_disc\<close> \<open>\<psi> y\<close>
	+ by auto
	+
	+ thus "is_real ?x \<and> 0 \<le> Re ?x"
	+ using \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close> \<open>is_real (to_complex y)\<close> \<open>\<psi> y\<close>
	+ using \<open>set_order 0\<^sub>h \<phi> \<psi>\<close>
	+ using \<open>\<phi> ?X\<close> \<open>?X \<in> unit_disc\<close> \<open>Re ?y > 0\<close>
	+ by (metis arg_0_iff le_less of_complex_zero poincare_between_0uv to_complex_of_complex zero_complex.simps(1) zero_complex.simps(2))
	+ qed
	+
	+ have \<phi>less\<psi>: "\<forall>x\<in>unit_disc. \<forall>y\<in>unit_disc. \<phi> x \<and> \<psi> y \<longrightarrow> Re (to_complex x) < Re (to_complex y)"
	+ proof((rule ballI)+, rule impI)
	+ fix x y
	+ let ?x = "to_complex x" and ?y = "to_complex y"
	+ assume "x \<in> unit_disc" "y \<in> unit_disc" "\<phi> x \<and> \<psi> y"
	+
	+ hence "poincare_between 0\<^sub>h x y"
	+ using \<open>set_order 0\<^sub>h \<phi> \<psi>\<close>
	+ by auto
	+ moreover
	+ have "is_real ?x" "Re ?x \<ge> 0"
	+ using \<phi>noneg
	+ using \<open>x \<in> unit_disc\<close> \<open>\<phi> x \<and> \<psi> y\<close> by auto
	+ moreover
	+ have "is_real ?y" "Re ?y > 0"
	+ using \<psi>pos
	+ using \<open>y \<in> unit_disc\<close> \<open>\<phi> x \<and> \<psi> y\<close> by auto
	+ ultimately
	+ have "Re ?x \<le> Re ?y"
	+ using \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close>
	+ by (metis Re_complex_of_real arg_0_iff le_less of_complex_zero poincare_between_0uv rcis_cmod_arg rcis_zero_arg to_complex_of_complex)
	+
	+ have "Re ?x \<noteq> Re ?y"
	+ using \<open>\<phi> x \<and> \<psi> y\<close> \<open>is_real ?x\<close> \<open>is_real ?y\<close>
	+ using \<open>\<not> (\<exists>B\<in>unit_disc. \<phi> B \<and> \<psi> B)\<close> \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close>
	+ by (metis complex.expand unit_disc_to_complex_inj)
	+
	+ thus "Re ?x < Re ?y"
	+ using \<open>Re ?x \<le> Re ?y\<close> by auto
	+ qed
	+
	+ have "\<exists> b \<in> unit_disc. \<forall> x \<in> unit_disc. \<forall> y \<in> unit_disc.
	+ is_real (to_complex b) \<and>
	+ (\<phi> x \<and> \<psi> y \<longrightarrow> (Re (to_complex x) \<le> Re (to_complex b) \<and> Re (to_complex b) \<le> Re (to_complex y)))"
	+ proof-
	+ let ?Phi = "{x. (of_complex (cor x)) \<in> unit_disc \<and> \<phi> (of_complex (cor x))}"
	+
	+ have "\<forall> x \<in> unit_disc. \<phi> x \<longrightarrow> Re (to_complex x) \<le> Sup ?Phi"
	+ proof(safe)
	+ fix x
	+ let ?x = "to_complex x"
	+ assume "x \<in> unit_disc" "\<phi> x"
	+ hence "is_real ?x" "Re ?x \<ge> 0"
	+ using \<phi>noneg
	+ by auto
	+ hence "cor (Re ?x) = ?x"
	+ using complex_of_real_Re by blast
	+ hence "of_complex (cor (Re ?x)) \<in> unit_disc"
	+ using \<open>x \<in> unit_disc\<close>
	+ by (metis inf_notin_unit_disc of_complex_to_complex)
	+ moreover
	+ have "\<phi> (of_complex (cor (Re ?x)))"
	+ using \<open>cor (Re ?x) = ?x\<close> \<open>\<phi> x\<close> \<open>x \<in> unit_disc\<close>
	+ by (metis inf_notin_unit_disc of_complex_to_complex)
	+ ultimately
	+ have "Re ?x \<in> ?Phi"
	+ by auto
	+
	+ have "\<exists>M. \<forall>x \<in> ?Phi. x \<le> M"
	+ using \<phi>less\<psi>
	+ using \<open>\<exists> y \<in> unit_disc. \<psi> y\<close>
	+ by (metis (mono_tags, lifting) Re_complex_of_real le_less mem_Collect_eq to_complex_of_complex)
	+
	+ thus "Re ?x \<le> Sup ?Phi"
	+ using cSup_upper[of "Re ?x" ?Phi]
	+ unfolding bdd_above_def
	+ using \<open>Re ?x \<in> ?Phi\<close>
	+ by auto
	+ qed
	+
	+ have "\<forall> y \<in> unit_disc. \<psi> y \<longrightarrow> Sup ?Phi \<le> Re (to_complex y)"
	+ proof (safe)
	+ fix y
	+ let ?y = "to_complex y"
	+ assume "\<psi> y" "y \<in> unit_disc"
	+ show "Sup ?Phi \<le> Re ?y"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "Re ?y < Sup ?Phi"
	+ by auto
	+
	+ have "\<exists> x. \<phi> (of_complex (cor x)) \<and> (of_complex (cor x)) \<in> unit_disc"
	+ proof -
	+ obtain x' where "x' \<in> unit_disc" "\<phi> x'"
	+ using \<open>\<exists> x \<in> unit_disc. \<phi> x\<close> by blast
	+ let ?x' = "to_complex x'"
	+ have "is_real ?x'"
	+ using \<open>x' \<in> unit_disc\<close> \<open>\<phi> x'\<close>
	+ using \<phi>noneg
	+ by auto
	+ hence "cor (Re ?x') = ?x'"
	+ using complex_of_real_Re by blast
	+ hence "x' = of_complex (cor (Re ?x'))"
	+ using \<open>x' \<in> unit_disc\<close>
	+ by (metis inf_notin_unit_disc of_complex_to_complex)
	+ show ?thesis
	+ apply (rule_tac x="Re ?x'" in exI)
	+ using \<open>x' \<in> unit_disc\<close>
	+ apply (subst (asm) \<open>x' = of_complex (cor (Re ?x'))\<close>, simp)
	+ using \<open>\<phi> x'\<close>
	+ by (subst (asm) (2) \<open>x' = of_complex (cor (Re ?x'))\<close>, simp)
	+ qed
	+
	+ hence "?Phi \<noteq> {}"
	+ by auto
	+
	+ then obtain x where "\<phi> (of_complex (cor x))" "Re ?y < x"
	+ "(of_complex (cor x)) \<in> unit_disc"
	+ using \<open>Re ?y < Sup ?Phi\<close>
	+ using less_cSupE[of "Re ?y" ?Phi]
	+ by auto
	+ moreover
	+ have "Re ?y < Re (to_complex (of_complex (cor x)))"
	+ using \<open>Re ?y < x\<close>
	+ by simp
	+ ultimately
	+ show False
	+ using \<phi>less\<psi>
	+ using \<open>\<psi> y\<close> \<open>y \<in> unit_disc\<close>
	+ by (metis less_not_sym)
	+ qed
	+ qed
	+
	+ thus ?thesis
	+ using \<open>\<forall> x \<in> unit_disc. \<phi> x \<longrightarrow> Re (to_complex x) \<le> Sup ?Phi\<close>
	+ apply (rule_tac x="(of_complex (cor (Sup ?Phi)))" in bexI, simp)
	+ using \<open>\<exists>y\<in>unit_disc. \<psi> y\<close> \<open>\<phi> ?X\<close> \<open>?X \<in> unit_disc\<close>
	+ using \<open>\<forall>y\<in>unit_disc. \<psi> y \<longrightarrow> is_real (to_complex y) \<and> 0 < Re (to_complex y)\<close>
	+ by (smt complex_of_real_Re inf_notin_unit_disc norm_of_real of_complex_to_complex to_complex_of_complex unit_disc_iff_cmod_lt_1 xx(2))
	+ qed
	+
	+ then obtain B where "B \<in> unit_disc" "is_real (to_complex B)"
	+ "\<forall>x\<in>unit_disc. \<forall>y\<in>unit_disc. \<phi> x \<and> \<psi> y \<longrightarrow> Re (to_complex x) \<le> Re (to_complex B) \<and>
	+ Re (to_complex B) \<le> Re (to_complex y)"
	+ by blast
	+
	+ show "\<exists> b \<in> unit_disc. point_between_sets \<phi> b \<psi>"
	+ proof (rule_tac x="B" in bexI)
	+ show "B \<in> unit_disc"
	+ by fact
	+ next
	+ show "point_between_sets \<phi> B \<psi>"
	+ proof ((rule ballI)+, rule impI)
	+ fix x y
	+ let ?x = "to_complex x" and ?y = "to_complex y" and ?B = "to_complex B"
	+ assume "x \<in> unit_disc" "y \<in> unit_disc" "\<phi> x \<and> \<psi> y"
	+
	+ hence "Re ?x \<le> Re ?B \<and> Re ?B \<le> Re ?y"
	+ using \<open>\<forall>x\<in>unit_disc. \<forall>y\<in>unit_disc. \<phi> x \<and> \<psi> y \<longrightarrow> Re (to_complex x) \<le> Re ?B \<and>
	+ Re (to_complex B) \<le> Re (to_complex y)\<close>
	+ by auto
	+ moreover
	+ have "is_real ?x" "Re ?x \<ge> 0"
	+ using \<phi>noneg
	+ using \<open>x \<in> unit_disc\<close> \<open>\<phi> x \<and> \<psi> y\<close>
	+ by auto
	+ moreover
	+ have "is_real ?y" "Re ?y > 0"
	+ using \<psi>pos
	+ using \<open>y \<in> unit_disc\<close> \<open>\<phi> x \<and> \<psi> y\<close>
	+ by auto
	+ moreover
	+ have "cor (Re ?x) = ?x"
	+ using complex_of_real_Re \<open>is_real ?x\<close> by blast
	+ hence "x = of_complex (cor (Re ?x))"
	+ using \<open>x \<in> unit_disc\<close>
	+ by (metis inf_notin_unit_disc of_complex_to_complex)
	+ moreover
	+ have "cor (Re ?y) = ?y"
	+ using complex_of_real_Re \<open>is_real ?y\<close> by blast
	+ hence "y = of_complex (cor (Re ?y))"
	+ using \<open>y \<in> unit_disc\<close>
	+ by (metis inf_notin_unit_disc of_complex_to_complex)
	+ moreover
	+ have "cor (Re ?B) = ?B"
	+ using complex_of_real_Re \<open>is_real (to_complex B)\<close> by blast
	+ hence "B = of_complex (cor (Re ?B))"
	+ using \<open>B \<in> unit_disc\<close>
	+ by (metis inf_notin_unit_disc of_complex_to_complex)
	+ ultimately
	+ show "poincare_between x B y"
	+ using \<open>is_real (to_complex B)\<close> \<open>x \<in> unit_disc\<close> \<open>y \<in> unit_disc\<close> \<open>B \<in> unit_disc\<close>
	+ using poincare_between_x_axis_uvw[of "Re (to_complex x)" "Re (to_complex B)" "Re (to_complex y)"]
	+ by (smt Re_complex_of_real arg_0_iff poincare_between_nonstrict(1) rcis_cmod_arg rcis_zero_arg unit_disc_iff_cmod_lt_1)
	+ qed
	+ qed
	+ qed
	+ qed
	+ thus ?thesis
	+ using False \<open>\<phi> X0\<close> \<open>\<psi> Y0\<close> * \<open>Y0 \<in> unit_disc\<close> \<open>X0 \<in> unit_disc\<close>
	+ by auto
	+ qed
	+ qed
	+qed
	+
	+
	+(* ------------------------------------------------------------------ *)
	+subsection\<open>Limiting parallels axiom\<close>
	+(* ------------------------------------------------------------------ *)
	+
	+text \<open>Auxiliary definitions\<close>
	+
	+definition poincare_on_line where
	+ "poincare_on_line p a b \<longleftrightarrow> poincare_collinear {p, a, b}"
	+
	+definition poincare_on_ray where
	+ "poincare_on_ray p a b \<longleftrightarrow> poincare_between a p b \<or> poincare_between a b p"
	+
	+definition poincare_in_angle where
	+ "poincare_in_angle p a b c \<longleftrightarrow>
	+ b \<noteq> a \<and> b \<noteq> c \<and> p \<noteq> b \<and> (\<exists> x \<in> unit_disc. poincare_between a x c \<and> x \<noteq> a \<and> x \<noteq> c \<and> poincare_on_ray p b x)"
	+
	+definition poincare_ray_meets_line where
	+ "poincare_ray_meets_line a b c d \<longleftrightarrow> (\<exists> x \<in> unit_disc. poincare_on_ray x a b \<and> poincare_on_line x c d)"
	+
	+text \<open>All points on ray are collinear\<close>
	+lemma poincare_on_ray_poincare_collinear:
	+ assumes "p \<in> unit_disc" and "a \<in> unit_disc" and "b \<in> unit_disc" and "poincare_on_ray p a b"
	+ shows "poincare_collinear {p, a, b}"
	+ using assms poincare_between_poincare_collinear
	+ unfolding poincare_on_ray_def
	+ by (metis insert_commute)
	+
	+text \<open>H-isometries preserve all defined auxiliary relations\<close>
	+
	+lemma unit_disc_fix_preserves_poincare_on_line [simp]:
	+ assumes "unit_disc_fix M" and "p \<in> unit_disc" "a \<in> unit_disc" "b \<in> unit_disc"
	+ shows "poincare_on_line (moebius_pt M p) (moebius_pt M a) (moebius_pt M b) \<longleftrightarrow> poincare_on_line p a b"
	+ using assms
	+ unfolding poincare_on_line_def
	+ by auto
	+
	+lemma unit_disc_fix_preserves_poincare_on_ray [simp]:
	+ assumes "unit_disc_fix M" "p \<in> unit_disc" "a \<in> unit_disc" "b \<in> unit_disc"
	+ shows "poincare_on_ray (moebius_pt M p) (moebius_pt M a) (moebius_pt M b) \<longleftrightarrow> poincare_on_ray p a b"
	+ using assms
	+ unfolding poincare_on_ray_def
	+ by auto
	+
	+lemma unit_disc_fix_preserves_poincare_in_angle [simp]:
	+ assumes "unit_disc_fix M" "p \<in> unit_disc" "a \<in> unit_disc" "b \<in> unit_disc" "c \<in> unit_disc"
	+ shows "poincare_in_angle (moebius_pt M p) (moebius_pt M a) (moebius_pt M b) (moebius_pt M c) \<longleftrightarrow> poincare_in_angle p a b c" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof
	+ assume "?lhs"
	+ then obtain Mx where *: "Mx \<in> unit_disc"
	+ "poincare_between (moebius_pt M a) Mx (moebius_pt M c)"
	+ "Mx \<noteq> moebius_pt M a" "Mx \<noteq> moebius_pt M c" "poincare_on_ray (moebius_pt M p) (moebius_pt M b) Mx"
	+ "moebius_pt M b \<noteq> moebius_pt M a" "moebius_pt M b \<noteq> moebius_pt M c" "moebius_pt M p \<noteq> moebius_pt M b"
	+ unfolding poincare_in_angle_def
	+ by auto
	+ obtain x where "Mx = moebius_pt M x" "x \<in> unit_disc"
	+ by (metis "*"(1) assms(1) image_iff unit_disc_fix_iff)
	+ thus ?rhs
	+ using * assms
	+ unfolding poincare_in_angle_def
	+ by auto
	+next
	+ assume ?rhs
	+ then obtain x where *: "x \<in> unit_disc"
	+ "poincare_between a x c"
	+ "x \<noteq> a" "x \<noteq> c" "poincare_on_ray p b x"
	+ "b \<noteq> a" "b \<noteq> c" "p \<noteq> b"
	+ unfolding poincare_in_angle_def
	+ by auto
	+ thus ?lhs
	+ using assms
	+ unfolding poincare_in_angle_def
	+ by auto (rule_tac x="moebius_pt M x" in bexI, auto)
	+qed
	+
	+lemma unit_disc_fix_preserves_poincare_ray_meets_line [simp]:
	+ assumes "unit_disc_fix M" "a \<in> unit_disc" "b \<in> unit_disc" "c \<in> unit_disc" "d \<in> unit_disc"
	+ shows "poincare_ray_meets_line (moebius_pt M a) (moebius_pt M b) (moebius_pt M c) (moebius_pt M d) \<longleftrightarrow> poincare_ray_meets_line a b c d" (is "?lhs \<longleftrightarrow> ?rhs")
	+proof
	+ assume ?lhs
	+ then obtain Mx where *: "Mx \<in> unit_disc" "poincare_on_ray Mx (moebius_pt M a) (moebius_pt M b)"
	+ "poincare_on_line Mx (moebius_pt M c) (moebius_pt M d)"
	+ unfolding poincare_ray_meets_line_def
	+ by auto
	+ obtain x where "Mx = moebius_pt M x" "x \<in> unit_disc"
	+ by (metis "*"(1) assms(1) image_iff unit_disc_fix_iff)
	+ thus ?rhs
	+ using assms *
	+ unfolding poincare_ray_meets_line_def poincare_on_line_def
	+ by auto
	+next
	+ assume ?rhs
	+ then obtain x where *: "x \<in> unit_disc" "poincare_on_ray x a b"
	+ "poincare_on_line x c d"
	+ unfolding poincare_ray_meets_line_def
	+ by auto
	+ thus ?lhs
	+ using assms *
	+ unfolding poincare_ray_meets_line_def poincare_on_line_def
	+ by auto (rule_tac x="moebius_pt M x" in bexI, auto)
	+qed
	+
	+text \<open>H-lines that intersect on the absolute do not meet (they do not share a common h-point)\<close>
	+lemma tangent_not_meet:
	+ assumes "x1 \<in> unit_disc" and "x2 \<in> unit_disc" and "x1 \<noteq> x2" and "\<not> poincare_collinear {0\<^sub>h, x1, x2}"
	+ assumes "i \<in> ideal_points (poincare_line x1 x2)" "a \<in> unit_disc" "a \<noteq> 0\<^sub>h" "poincare_collinear {0\<^sub>h, a, i}"
	+ shows "\<not> poincare_ray_meets_line 0\<^sub>h a x1 x2"
	+proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ then obtain x where "x \<in> unit_disc" "poincare_on_ray x 0\<^sub>h a" "poincare_collinear {x, x1, x2}"
	+ unfolding poincare_ray_meets_line_def poincare_on_line_def
	+ by auto
	+
	+ have "poincare_collinear {0\<^sub>h, a, x}"
	+ using `poincare_on_ray x 0\<^sub>h a` `x \<in> unit_disc` `a \<in> unit_disc`
	+ by (meson poincare_between_poincare_collinear poincare_between_rev poincare_on_ray_def poincare_on_ray_poincare_collinear zero_in_unit_disc)
	+
	+ have "x \<noteq> 0\<^sub>h"
	+ using `\<not> poincare_collinear {0\<^sub>h, x1, x2}` `poincare_collinear {x, x1, x2}`
	+ unfolding poincare_collinear_def
	+ by (auto simp add: assms(2) assms(3) poincare_between_rev)
	+
	+ let ?l1 = "poincare_line 0\<^sub>h a"
	+ let ?l2 = "poincare_line x1 x2"
	+
	+ have "i \<in> circline_set unit_circle"
	+ using `i \<in> ideal_points (poincare_line x1 x2)`
	+ using assms(3) ideal_points_on_unit_circle is_poincare_line_poincare_line by blast
	+
	+ have "i \<in> circline_set ?l1"
	+ using `poincare_collinear {0\<^sub>h, a, i}`
	+ unfolding poincare_collinear_def
	+ using \<open>a \<in> unit_disc\<close> \<open>a \<noteq> 0\<^sub>h\<close>
	+ by (metis insert_subset unique_poincare_line zero_in_unit_disc)
	+
	+ moreover
	+
	+ have "x \<in> circline_set ?l1"
	+ using `a \<in> unit_disc` `a \<noteq> 0\<^sub>h` `poincare_collinear {0\<^sub>h, a, x}` `x \<in> unit_disc`
	+ by (metis poincare_collinear3_between poincare_between_poincare_line_uvz poincare_between_poincare_line_uzv poincare_line_sym zero_in_unit_disc)
	+
	+ moreover
	+
	+ have "inversion x \<in> circline_set ?l1"
	+ using `poincare_collinear {0\<^sub>h, a, x}`
	+ using poincare_line_inversion_full[of "0\<^sub>h" a x] `a \<in> unit_disc` `a \<noteq> 0\<^sub>h` `x \<in> unit_disc`
	+ by (metis poincare_collinear3_between is_poincare_line_inverse_point is_poincare_line_poincare_line poincare_between_poincare_line_uvz poincare_between_poincare_line_uzv poincare_line_sym zero_in_unit_disc)
	+
	+ moreover
	+
	+ have "x \<in> circline_set ?l2"
	+ using `poincare_collinear {x, x1, x2}` `x1 \<noteq> x2` `x1 \<in> unit_disc` `x2 \<in> unit_disc` `x \<in> unit_disc`
	+ by (metis insert_commute inversion_noteq_unit_disc poincare_between_poincare_line_uvz poincare_between_poincare_line_uzv poincare_collinear3_iff poincare_line_sym_general)
	+
	+ moreover
	+
	+ hence "inversion x \<in> circline_set ?l2"
	+ using `x1 \<noteq> x2` `x1 \<in> unit_disc` `x2 \<in> unit_disc` `x \<in> unit_disc`
	+ using poincare_line_inversion_full[of x1 x2 x]
	+ unfolding circline_set_def
	+ by auto
	+
	+ moreover
	+
	+ have "i \<in> circline_set ?l2"
	+ using `x1 \<noteq> x2` `x1 \<in> unit_disc` `x2 \<in> unit_disc`
	+ using `i \<in> ideal_points ?l2`
	+ by (simp add: ideal_points_on_circline)
	+
	+ moreover
	+
	+ have "x \<noteq> inversion x"
	+ using `x \<in> unit_disc`
	+ using inversion_noteq_unit_disc by fastforce
	+
	+ moreover
	+
	+ have "x \<noteq> i"
	+ using `x \<in> unit_disc`
	+ using \<open>i \<in> circline_set unit_circle\<close> circline_set_def inversion_noteq_unit_disc
	+ by fastforce+
	+
	+ moreover
	+
	+ have "inversion x \<noteq> i"
	+ using \<open>i \<in> circline_set unit_circle\<close> \<open>x \<noteq> i\<close> circline_set_def inversion_unit_circle
	+ by fastforce
	+
	+ ultimately
	+
	+ have "?l1 = ?l2"
	+ using unique_circline_set[of x "inversion x" i]
	+ by blast
	+
	+ hence "0\<^sub>h \<in> circline_set ?l2"
	+ by (metis \<open>a \<noteq> 0\<^sub>h\<close> poincare_line_circline_set(1))
	+
	+ thus False
	+ using `\<not> poincare_collinear {0\<^sub>h, x1, x2}`
	+ unfolding poincare_collinear_def
	+ using \<open>poincare_collinear {x, x1, x2}\<close> \<open>x1 \<noteq> x2\<close> `x1 \<in> unit_disc` `x2 \<in> unit_disc` poincare_collinear_def unique_poincare_line
	+ by auto
	+qed
	+
	+lemma limiting_parallels:
	+ assumes "a \<in> unit_disc" and "x1 \<in> unit_disc" and "x2 \<in> unit_disc" and "\<not> poincare_on_line a x1 x2"
	+ shows "\<exists>a1\<in>unit_disc. \<exists>a2\<in>unit_disc.
	+ \<not> poincare_on_line a a1 a2 \<and>
	+ \<not> poincare_ray_meets_line a a1 x1 x2 \<and> \<not> poincare_ray_meets_line a a2 x1 x2 \<and>
	+ (\<forall>a'\<in>unit_disc. poincare_in_angle a' a1 a a2 \<longrightarrow> poincare_ray_meets_line a a' x1 x2)" (is "?P a x1 x2")
	+proof-
	+ have "\<not> poincare_collinear {a, x1, x2}"
	+ using `\<not> poincare_on_line a x1 x2`
	+ unfolding poincare_on_line_def
	+ by simp
	+
	+ have "\<forall> x1 x2. x1 \<in> unit_disc \<and> x2 \<in> unit_disc \<and> \<not> poincare_collinear {a, x1, x2} \<longrightarrow> ?P a x1 x2" (is "?Q a")
	+ proof (rule wlog_zero[OF `a \<in> unit_disc`])
	+ fix a u
	+ assume *: "u \<in> unit_disc" "cmod a < 1"
	+ hence uf: "unit_disc_fix (blaschke a)"
	+ by simp
	+ assume **: "?Q (moebius_pt (blaschke a) u)"
	+ show "?Q u"
	+ proof safe
	+ fix x1 x2
	+ let ?M = "moebius_pt (blaschke a)"
	+ assume xx: "x1 \<in> unit_disc" "x2 \<in> unit_disc" "\<not> poincare_collinear {u, x1, x2}"
	+ hence MM: "?M x1 \<in> unit_disc \<and> ?M x2\<in> unit_disc \<and> \<not> poincare_collinear {?M u, ?M x1, ?M x2}"
	+ using *
	+ by auto
	+ show "?P u x1 x2" (is "\<exists>a1\<in>unit_disc. \<exists>a2\<in>unit_disc. ?P' a1 a2 u x1 x2")
	+ proof-
	+ obtain Ma1 Ma2 where MM: "Ma1 \<in> unit_disc" "Ma2 \<in> unit_disc" "?P' Ma1 Ma2 (?M u) (?M x1) (?M x2)"
	+ using **[rule_format, OF MM]
	+ by blast
	+ hence MM': "\<forall>a'\<in>unit_disc. poincare_in_angle a' Ma1 (?M u) Ma2 \<longrightarrow> poincare_ray_meets_line (?M u) a' (?M x1) (?M x2)"
	+ by auto
	+ obtain a1 a2 where a: "a1 \<in> unit_disc" "a2 \<in> unit_disc" "?M a1 = Ma1" "?M a2 = Ma2"
	+ using uf
	+ by (metis \<open>Ma1 \<in> unit_disc\<close> \<open>Ma2 \<in> unit_disc\<close> image_iff unit_disc_fix_iff)
	+
	+ have "\<forall>a'\<in>unit_disc. poincare_in_angle a' a1 u a2 \<longrightarrow> poincare_ray_meets_line u a' x1 x2"
	+ proof safe
	+ fix a'
	+ assume "a' \<in> unit_disc" "poincare_in_angle a' a1 u a2"
	+ thus "poincare_ray_meets_line u a' x1 x2"
	+ using MM(1-2) MM'[rule_format, of "?M a'"] * uf a xx
	+ by (meson unit_disc_fix_discI unit_disc_fix_preserves_poincare_in_angle unit_disc_fix_preserves_poincare_ray_meets_line)
	+ qed
	+
	+ hence "?P' a1 a2 u x1 x2"
	+ using MM * uf xx a
	+ by auto
	+
	+ thus ?thesis
	+ using `a1 \<in> unit_disc` `a2 \<in> unit_disc`
	+ by blast
	+ qed
	+ qed
	+ next
	+ show "?Q 0\<^sub>h"
	+ proof safe
	+ fix x1 x2
	+ assume "x1 \<in> unit_disc" "x2 \<in> unit_disc"
	+ assume "\<not> poincare_collinear {0\<^sub>h, x1, x2}"
	+ show "?P 0\<^sub>h x1 x2"
	+ proof-
	+ let ?lx = "poincare_line x1 x2"
	+
	+ have "x1 \<noteq> x2"
	+ using `x1 \<in> unit_disc` `x2 \<in> unit_disc``\<not> poincare_collinear {0\<^sub>h, x1, x2}`
	+ using poincare_collinear3_between
	+ by auto
	+
	+ have lx: "is_poincare_line ?lx"
	+ using is_poincare_line_poincare_line[OF `x1 \<noteq> x2`]
	+ by simp
	+
	+ obtain i1 i2 where "ideal_points ?lx = {i1, i2}"
	+ by (meson \<open>x1 \<noteq> x2\<close> is_poincare_line_poincare_line obtain_ideal_points)
	+
	+ let ?li = "poincare_line i1 i2"
	+ let ?i1 = "to_complex i1"
	+ let ?i2 = "to_complex i2"
	+
	+ have "i1 \<in> unit_circle_set" "i2 \<in> unit_circle_set"
	+ using lx \<open>ideal_points ?lx = {i1, i2}\<close>
	+ unfolding unit_circle_set_def
	+ by (metis ideal_points_on_unit_circle insertI1, metis ideal_points_on_unit_circle insertI1 insertI2)
	+
	+ have "i1 \<noteq> i2"
	+ using \<open>ideal_points ?lx = {i1, i2}\<close> \<open>x1 \<in> unit_disc\<close> \<open>x1 \<noteq> x2\<close> \<open>x2 \<in> unit_disc\<close> ideal_points_different(1)
	+ by blast
	+
	+ let ?a1 = "of_complex (?i1 / 2)"
	+ let ?a2 = "of_complex (?i2 / 2)"
	+ let ?la = "poincare_line ?a1 ?a2"
	+
	+ have "?a1 \<in> unit_disc" "?a2 \<in> unit_disc"
	+ using `i1 \<in> unit_circle_set` `i2 \<in> unit_circle_set`
	+ unfolding unit_circle_set_def unit_disc_def disc_def circline_set_def
	+ by auto (transfer, transfer, case_tac i1, case_tac i2, simp add: vec_cnj_def)+
	+
	+ have "?a1 \<noteq> 0\<^sub>h" "?a2 \<noteq> 0\<^sub>h"
	+ using `i1 \<in> unit_circle_set` `i2 \<in> unit_circle_set`
	+ unfolding unit_circle_set_def
	+ by auto
	+
	+ have "?a1 \<noteq> ?a2"
	+ using `i1 \<noteq> i2`
	+ by (metis \<open>i1 \<in> unit_circle_set\<close> \<open>i2 \<in> unit_circle_set\<close> circline_set_def divide_cancel_right inversion_infty inversion_unit_circle mem_Collect_eq of_complex_to_complex of_complex_zero to_complex_of_complex unit_circle_set_def zero_neq_numeral)
	+
	+ have "poincare_collinear {0\<^sub>h, ?a1, i1}"
	+ unfolding poincare_collinear_def
	+ using `?a1 \<noteq> 0\<^sub>h`[symmetric] is_poincare_line_poincare_line[of "0\<^sub>h" ?a1]
	+ unfolding circline_set_def
	+ apply (rule_tac x="poincare_line 0\<^sub>h ?a1" in exI, auto)
	+ apply (transfer, transfer, auto simp add: vec_cnj_def)
	+ done
	+
	+ have "poincare_collinear {0\<^sub>h, ?a2, i2}"
	+ unfolding poincare_collinear_def
	+ using `?a2 \<noteq> 0\<^sub>h`[symmetric] is_poincare_line_poincare_line[of "0\<^sub>h" ?a2]
	+ unfolding circline_set_def
	+ apply (rule_tac x="poincare_line 0\<^sub>h ?a2" in exI, auto)
	+ apply (transfer, transfer, auto simp add: vec_cnj_def)
	+ done
	+
	+ have "\<not> poincare_ray_meets_line 0\<^sub>h ?a1 x1 x2"
	+ using tangent_not_meet[of x1 x2 i1 ?a1]
	+ using `x1 \<in> unit_disc` `x2 \<in> unit_disc` `?a1 \<in> unit_disc` `x1 \<noteq> x2` `\<not> poincare_collinear {0\<^sub>h, x1, x2}`
	+ using `ideal_points ?lx = {i1, i2}` `?a1 \<noteq> 0\<^sub>h` `poincare_collinear {0\<^sub>h, ?a1, i1}`
	+ by simp
	+
	+ moreover
	+
	+ have "\<not> poincare_ray_meets_line 0\<^sub>h ?a2 x1 x2"
	+ using tangent_not_meet[of x1 x2 i2 ?a2]
	+ using `x1 \<in> unit_disc` `x2 \<in> unit_disc` `?a2 \<in> unit_disc` `x1 \<noteq> x2` `\<not> poincare_collinear {0\<^sub>h, x1, x2}`
	+ using `ideal_points ?lx = {i1, i2}` `?a2 \<noteq> 0\<^sub>h` `poincare_collinear {0\<^sub>h, ?a2, i2}`
	+ by simp
	+
	+ moreover
	+
	+ have "\<forall>a' \<in> unit_disc. poincare_in_angle a' ?a1 0\<^sub>h ?a2 \<longrightarrow> poincare_ray_meets_line 0\<^sub>h a' x1 x2"
	+ unfolding poincare_in_angle_def
	+ proof safe
	+ fix a' a
	+ assume *: "a' \<in> unit_disc" "a \<in> unit_disc" "poincare_on_ray a' 0\<^sub>h a" "a' \<noteq> 0\<^sub>h"
	+ "poincare_between ?a1 a ?a2" "a \<noteq> ?a1" "a \<noteq> ?a2"
	+ show "poincare_ray_meets_line 0\<^sub>h a' x1 x2"
	+ proof-
	+ have "\<forall> a' a1 a2 x1 x2 i1 i2.
	+ a' \<in> unit_disc \<and> x1 \<in> unit_disc \<and> x2 \<in> unit_disc \<and> x1 \<noteq> x2 \<and>
	+ \<not> poincare_collinear {0\<^sub>h, x1, x2} \<and> ideal_points (poincare_line x1 x2) = {i1, i2} \<and>
	+ a1 = of_complex (to_complex i1 / 2) \<and> a2 = of_complex (to_complex i2 / 2) \<and>
	+ i1 \<noteq> i2 \<and> a1 \<noteq> a2 \<and> poincare_collinear {0\<^sub>h, a1, i1} \<and> poincare_collinear {0\<^sub>h, a2, i2} \<and>
	+ a1 \<in> unit_disc \<and> a2 \<in> unit_disc \<and> i1 \<in> unit_circle_set \<and> i2 \<in> unit_circle_set \<and>
	+ poincare_on_ray a' 0\<^sub>h a \<and> a' \<noteq> 0\<^sub>h \<and> poincare_between a1 a a2 \<and> a \<noteq> a1 \<and> a \<noteq> a2 \<longrightarrow>
	+ poincare_ray_meets_line 0\<^sub>h a' x1 x2" (is "\<forall> a' a1 a2 x1 x2 i1 i2. ?R 0\<^sub>h a' a1 a2 x1 x2 i1 i2 a")
	+ proof (rule wlog_rotation_to_positive_x_axis[OF `a \<in> unit_disc`])
	+ let ?R' = "\<lambda> a zero. \<forall> a' a1 a2 x1 x2 i1 i2. ?R zero a' a1 a2 x1 x2 i1 i2 a"
	+ fix xa
	+ assume xa: "is_real xa" "0 < Re xa" "Re xa < 1"
	+ let ?a = "of_complex xa"
	+ show "?R' ?a 0\<^sub>h"
	+ proof safe
	+ fix a' a1 a2 x1 x2 i1 i2
	+ let ?i1 = "to_complex i1" and ?i2 = "to_complex i2"
	+ let ?a1 = "of_complex (?i1 / 2)" and ?a2 = "of_complex (?i2 / 2)"
	+ let ?la = "poincare_line ?a1 ?a2" and ?lx = "poincare_line x1 x2" and ?li = "poincare_line i1 i2"
	+ assume "a' \<in> unit_disc" "x1 \<in> unit_disc" "x2 \<in> unit_disc" "x1 \<noteq> x2"
	+ assume "\<not> poincare_collinear {0\<^sub>h, x1, x2}" "ideal_points ?lx = {i1, i2}"
	+ assume "poincare_on_ray a' 0\<^sub>h ?a" "a' \<noteq> 0\<^sub>h"
	+ assume "poincare_between ?a1 ?a ?a2" "?a \<noteq> ?a1" "?a \<noteq> ?a2"
	+ assume "i1 \<noteq> i2" "?a1 \<noteq> ?a2" "poincare_collinear {0\<^sub>h, ?a1, i1}" "poincare_collinear {0\<^sub>h, ?a2, i2}"
	+ assume "?a1 \<in> unit_disc" "?a2 \<in> unit_disc"
	+ assume "i1 \<in> unit_circle_set" "i2 \<in> unit_circle_set"
	+ show "poincare_ray_meets_line 0\<^sub>h a' x1 x2"
	+ proof-
	+ have "?lx = ?li"
	+ using \<open>ideal_points ?lx = {i1, i2}\<close> \<open>x1 \<noteq> x2\<close> ideal_points_line_unique
	+ by auto
	+
	+ have lx: "is_poincare_line ?lx"
	+ using is_poincare_line_poincare_line[OF `x1 \<noteq> x2`]
	+ by simp
	+
	+ have "x1 \<in> circline_set ?lx" "x2 \<in> circline_set ?lx"
	+ using lx \<open>x1 \<noteq> x2\<close>
	+ by auto
	+
	+ have "?lx \<noteq> x_axis"
	+ using `\<not> poincare_collinear {0\<^sub>h, x1, x2}` `x1 \<in> circline_set ?lx` `x2 \<in> circline_set ?lx` lx
	+ unfolding poincare_collinear_def
	+ by auto
	+
	+ have "0\<^sub>h \<notin> circline_set ?lx"
	+ using `\<not> poincare_collinear {0\<^sub>h, x1, x2}` lx `x1 \<in> circline_set ?lx` `x2 \<in> circline_set ?lx`
	+ unfolding poincare_collinear_def
	+ by auto
	+
	+ have "xa \<noteq> 0" "?a \<noteq> 0\<^sub>h"
	+ using xa
	+ by auto
	+ hence "0\<^sub>h \<noteq> ?a"
	+ by metis
	+
	+ have "?a \<in> positive_x_axis"
	+ using xa
	+ unfolding positive_x_axis_def
	+ by simp
	+
	+ have "?a \<in> unit_disc"
	+ using xa
	+ by (auto simp add: cmod_eq_Re)
	+
	+ have "?a \<in> circline_set ?la"
	+ using `poincare_between ?a1 ?a ?a2`
	+ using \<open>?a1 \<noteq> ?a2\<close> \<open>?a \<in> unit_disc\<close> \<open>?a1 \<in> unit_disc\<close> \<open>?a2 \<in> unit_disc\<close> poincare_between_poincare_line_uzv
	+ by blast
	+
	+ have "?a1 \<in> circline_set ?la" "?a2 \<in> circline_set ?la"
	+ by (auto simp add: \<open>?a1 \<noteq> ?a2\<close>)
	+
	+ have la: "is_poincare_line ?la"
	+ using is_poincare_line_poincare_line[OF `?a1 \<noteq> ?a2`]
	+ by simp
	+
	+ have inv: "inversion i1 = i1" "inversion i2 = i2"
	+ using `i1 \<in> unit_circle_set` `i2 \<in> unit_circle_set`
	+ by (auto simp add: circline_set_def unit_circle_set_def)
	+
	+ have "i1 \<noteq> \<infinity>\<^sub>h" "i2 \<noteq> \<infinity>\<^sub>h"
	+ using inv
	+ by auto
	+
	+ have "?a1 \<notin> circline_set x_axis \<and> ?a2 \<notin> circline_set x_axis"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "?a1 \<in> circline_set x_axis \<or> ?a2 \<in> circline_set x_axis"
	+ by auto
	+ hence "?la = x_axis"
	+ proof
	+ assume "?a1 \<in> circline_set x_axis"
	+ hence "{?a, ?a1} \<subseteq> circline_set ?la \<inter> circline_set x_axis"
	+ using `?a \<in> circline_set ?la` `?a1 \<in> circline_set ?la``?a \<in> positive_x_axis`
	+ using circline_set_x_axis_I xa(1)
	+ by blast
	+ thus "?la = x_axis"
	+ using unique_is_poincare_line[of ?a ?a1 ?la x_axis]
	+ using `?a1 \<in> unit_disc` `?a \<in> unit_disc` la `?a \<noteq> ?a1`
	+ by auto
	+ next
	+ assume "?a2 \<in> circline_set x_axis"
	+ hence "{?a, ?a2} \<subseteq> circline_set ?la \<inter> circline_set x_axis"
	+ using `?a \<in> circline_set ?la` `?a2 \<in> circline_set ?la` `?a \<in> positive_x_axis`
	+ using circline_set_x_axis_I xa(1)
	+ by blast
	+ thus "?la = x_axis"
	+ using unique_is_poincare_line[of ?a ?a2 ?la x_axis]
	+ using `?a2 \<in> unit_disc` `?a \<in> unit_disc` la `?a \<noteq> ?a2`
	+ by auto
	+ qed
	+
	+ hence "i1 \<in> circline_set x_axis \<and> i2 \<in> circline_set x_axis"
	+ using `?a1 \<in> circline_set ?la` `?a2 \<in> circline_set ?la`
	+ by (metis \<open>i1 \<noteq> \<infinity>\<^sub>h\<close> \<open>i2 \<noteq> \<infinity>\<^sub>h\<close> \<open>of_complex (to_complex i1 / 2) \<in> unit_disc\<close> \<open>of_complex (to_complex i2 / 2) \<in> unit_disc\<close> \<open>poincare_collinear {0\<^sub>h, of_complex (to_complex i1 / 2), i1}\<close> \<open>poincare_collinear {0\<^sub>h, of_complex (to_complex i2 / 2), i2}\<close> divide_eq_0_iff inf_not_of_complex inv(1) inv(2) inversion_noteq_unit_disc of_complex_to_complex of_complex_zero_iff poincare_collinear3_poincare_lines_equal_general poincare_line_0_real_is_x_axis poincare_line_circline_set(2) zero_in_unit_disc zero_neq_numeral)
	+
	+ thus False
	+ using `?lx \<noteq> x_axis` unique_is_poincare_line_general[of i1 i2 ?li x_axis] `i1 \<noteq> i2` inv `?lx = ?li`
	+ by auto
	+ qed
	+
	+ hence "?la \<noteq> x_axis"
	+ using \<open>?a1 \<noteq> ?a2\<close> poincare_line_circline_set(1)
	+ by fastforce
	+
	+ have "intersects_x_axis_positive ?la"
	+ using intersects_x_axis_positive_iff[of ?la] `?la \<noteq> x_axis` `?a \<in> circline_set ?la` la
	+ using `?a \<in> unit_disc` `?a \<in> positive_x_axis`
	+ by auto
	+
	+ have "intersects_x_axis ?lx"
	+ proof-
	+ have "arg (to_complex ?a1) * arg (to_complex ?a2) < 0"
	+ using `poincare_between ?a1 ?a ?a2` `?a1 \<in> unit_disc` `?a2 \<in> unit_disc`
	+ using poincare_between_x_axis_intersection[of ?a1 ?a2 "of_complex xa"]
	+ using `?a1 \<noteq> ?a2` `?a \<in> unit_disc` `?a1 \<notin> circline_set x_axis \<and> ?a2 \<notin> circline_set x_axis` `?a \<in> positive_x_axis`
	+ using `?a \<in> circline_set ?la`
	+ unfolding positive_x_axis_def
	+ by simp
	+
	+ moreover
	+
	+ have "\<And> x y x' y' :: real. \<lbrakk>sgn x' = sgn x; sgn y' = sgn y\<rbrakk> \<Longrightarrow> xy < 0 \<longleftrightarrow> x'y' < 0"
	+ by (metis sgn_less sgn_mult)
	+
	+ ultimately
	+
	+ have "Im (to_complex ?a1) * Im (to_complex ?a2) < 0"
	+ using arg_Im_sgn[of "to_complex ?a1"] arg_Im_sgn[of "to_complex ?a2"]
	+ using `?a1 \<in> unit_disc` `?a2 \<in> unit_disc` `?a1 \<notin> circline_set x_axis \<and> ?a2 \<notin> circline_set x_axis`
	+ using inf_or_of_complex[of ?a1] inf_or_of_complex[of ?a2] circline_set_x_axis
	+ by (metis circline_set_x_axis_I to_complex_of_complex)
	+
	+ thus ?thesis
	+ using ideal_points_intersects_x_axis[of ?lx i1 i2]
	+ using `ideal_points ?lx = {i1, i2}` lx `?lx \<noteq> x_axis`
	+ by simp
	+ qed
	+
	+ have "intersects_x_axis_positive ?lx"
	+ proof-
	+ have "cmod ?i1 = 1" "cmod ?i2 = 1"
	+ using \<open>i1 \<in> unit_circle_set\<close> \<open>i2 \<in> unit_circle_set\<close>
	+ unfolding unit_circle_set_def
	+ by auto
	+
	+ let ?a1' = "?i1 / 2" and ?a2' = "?i2 / 2"
	+ let ?Aa1 = "\<i> * (?a1' * cnj ?a2' - ?a2' * cnj ?a1')" and
	+ ?Ba1 = "\<i> * (?a2' * cor ((cmod ?a1')\<^sup>2 + 1) - ?a1' * cor ((cmod ?a2')\<^sup>2 + 1))"
	+
	+ have "?Aa1 \<noteq> 0 \<or> ?Ba1 \<noteq> 0"
	+ using `cmod (to_complex i1) = 1` `cmod (to_complex i2) = 1` `?a1 \<noteq> ?a2`
	+ by (auto simp add: power_divide complex_mult_cnj_cmod)
	+
	+ have "is_real ?Aa1"
	+ by simp
	+
	+ have "?a1 \<noteq> inversion ?a2"
	+ using \<open>?a1 \<in> unit_disc\<close> \<open>?a2 \<in> unit_disc\<close> inversion_noteq_unit_disc by fastforce
	+
	+ hence "Re ?Ba1 / Re ?Aa1 < -1"
	+ using `intersects_x_axis_positive ?la` `?a1 \<noteq> ?a2`
	+ using intersects_x_axis_positive_mk_circline[of ?Aa1 ?Ba1] `?Aa1 \<noteq> 0 \<or> ?Ba1 \<noteq> 0` `is_real ?Aa1`
	+ using poincare_line_non_homogenous[of ?a1 ?a2]
	+ by (simp add: Let_def)
	+
	+ moreover
	+
	+ let ?i1' = "to_complex i1" and ?i2' = "to_complex i2"
	+ let ?Ai1 = "\<i> * (?i1' * cnj ?i2' - ?i2' * cnj ?i1')" and
	+ ?Bi1 = "\<i> * (?i2' * cor ((cmod ?i1')\<^sup>2 + 1) - ?i1' * cor ((cmod ?i2')\<^sup>2 + 1))"
	+
	+ have "?Ai1 \<noteq> 0 \<or> ?Bi1 \<noteq> 0"
	+ using `cmod (to_complex i1) = 1` `cmod (to_complex i2) = 1` `?a1 \<noteq> ?a2`
	+ by (auto simp add: power_divide complex_mult_cnj_cmod)
	+
	+ have "is_real ?Ai1"
	+ by simp
	+
	+ have "sgn (Re ?Bi1 / Re ?Ai1) = sgn (Re ?Ba1 / Re ?Aa1)"
	+ proof-
	+ have "Re ?Bi1 / Re ?Ai1 = (Im ?i1 * 2 - Im ?i2 * 2) /
	+ (Im ?i2 * (Re ?i1 * 2) - Im ?i1 * (Re ?i2 * 2))"
	+ using `cmod ?i1 = 1` `cmod ?i2 = 1`
	+ by (auto simp add: complex_mult_cnj_cmod field_simps)
	+ also have "... = (Im ?i1 - Im ?i2) /
	+ (Im ?i2 * (Re ?i1) - Im ?i1 * (Re ?i2))" (is "... = ?expr")
	+ apply (subst left_diff_distrib[symmetric])
	+ apply (subst semiring_normalization_rules(18))+
	+ apply (subst left_diff_distrib[symmetric])
	+ by (metis mult.commute mult_divide_mult_cancel_left_if zero_neq_numeral)
	+ finally have 1: "Re ?Bi1 / Re ?Ai1 = (Im ?i1 - Im ?i2) / (Im ?i2 * (Re ?i1) - Im ?i1 * (Re ?i2))"
	+ .
	+
	+
	+ have "Re ?Ba1 / Re ?Aa1 = (Im ?i1 * 20 - Im ?i2 * 20) /
	+ (Im ?i2 * (Re ?i1 * 16) - Im ?i1 * (Re ?i2 * 16))"
	+ using `cmod (to_complex i1) = 1` `cmod (to_complex i2) = 1`
	+ by (auto simp add: complex_mult_cnj_cmod field_simps)
	+ also have "... = (20 / 16) * ((Im ?i1 - Im ?i2) /
	+ (Im ?i2 * (Re ?i1) - Im ?i1 * (Re ?i2)))"
	+ apply (subst left_diff_distrib[symmetric])+
	+ apply (subst semiring_normalization_rules(18))+
	+ apply (subst left_diff_distrib[symmetric])+
	+ by (metis (no_types, hide_lams) field_class.field_divide_inverse mult.commute times_divide_times_eq)
	+ finally have 2: "Re ?Ba1 / Re ?Aa1 = (5 / 4) * ((Im ?i1 - Im ?i2) / (Im ?i2 * (Re ?i1) - Im ?i1 * (Re ?i2)))"
	+ by simp
	+
	+ have "?expr \<noteq> 0"
	+ using `Re ?Ba1 / Re ?Aa1 < -1`
	+ apply (subst (asm) 2)
	+ by linarith
	+ thus ?thesis
	+ apply (subst 1, subst 2)
	+ apply (simp only: sgn_mult)
	+ by simp
	+ qed
	+
	+
	+ moreover
	+
	+ have "i1 \<noteq> inversion i2"
	+ by (simp add: \<open>i1 \<noteq> i2\<close> inv(2))
	+
	+ have "(Re ?Bi1 / Re ?Ai1)\<^sup>2 > 1"
	+ proof-
	+ have "?Ai1 = 0 \<or> (Re ?Bi1)\<^sup>2 > (Re ?Ai1)\<^sup>2"
	+ using `intersects_x_axis ?lx`
	+ using `i1 \<noteq> i2` `i1 \<noteq> \<infinity>\<^sub>h` `i2 \<noteq> \<infinity>\<^sub>h` `i1 \<noteq> inversion i2`
	+ using intersects_x_axis_mk_circline[of ?Ai1 ?Bi1] `?Ai1 \<noteq> 0 \<or> ?Bi1 \<noteq> 0` `is_real ?Ai1`
	+ using poincare_line_non_homogenous[of i1 i2] `?lx = ?li`
	+ by metis
	+
	+ moreover
	+ have "?Ai1 \<noteq> 0"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ hence "0\<^sub>h \<in> circline_set ?li"
	+ unfolding circline_set_def
	+ apply simp
	+ apply (transfer, transfer, case_tac i1, case_tac i2)
	+ by (auto simp add: vec_cnj_def field_simps)
	+ thus False
	+ using `0\<^sub>h \<notin> circline_set ?lx` `?lx = ?li`
	+ by simp
	+ qed
	+
	+ ultimately
	+
	+ have "(Re ?Bi1)\<^sup>2 > (Re ?Ai1)\<^sup>2"
	+ by auto
	+
	+ moreover
	+
	+ have "Re ?Ai1 \<noteq> 0"
	+ using `is_real ?Ai1` `?Ai1 \<noteq> 0`
	+ by (simp add: complex_eq_iff)
	+
	+ ultimately
	+
	+ show ?thesis
	+ by (simp add: power_divide)
	+ qed
	+
	+ moreover
	+
	+ {
	+ fix x1 x2 :: real
	+ assume "sgn x1 = sgn x2" "x1 < -1" "x2\<^sup>2 > 1"
	+ hence "x2 < -1"
	+ by (smt one_power2 real_sqrt_abs real_sqrt_less_iff sgn_neg sgn_pos)
	+ }
	+
	+ ultimately
	+
	+ have "Re ?Bi1 / Re ?Ai1 < -1"
	+ by metis
	+
	+ thus ?thesis
	+ using `i1 \<noteq> i2` `i1 \<noteq> \<infinity>\<^sub>h` `i2 \<noteq> \<infinity>\<^sub>h` `i1 \<noteq> inversion i2`
	+ using intersects_x_axis_positive_mk_circline[of ?Ai1 ?Bi1] `?Ai1 \<noteq> 0 \<or> ?Bi1 \<noteq> 0` `is_real ?Ai1`
	+ using poincare_line_non_homogenous[of i1 i2] `?lx = ?li`
	+ by (simp add: Let_def)
	+ qed
	+
	+ then obtain x where x: "x \<in> unit_disc" "x \<in> circline_set ?lx \<inter> positive_x_axis"
	+ using intersects_x_axis_positive_iff[OF lx `?lx \<noteq> x_axis`]
	+ by auto
	+
	+ have "poincare_on_ray x 0\<^sub>h a' \<and> poincare_collinear {x1, x2, x}"
	+ proof
	+ show "poincare_collinear {x1, x2, x}"
	+ using x lx `x1 \<in> circline_set ?lx` `x2 \<in> circline_set ?lx`
	+ unfolding poincare_collinear_def
	+ by auto
	+ next
	+ show "poincare_on_ray x 0\<^sub>h a'"
	+ unfolding poincare_on_ray_def
	+ proof-
	+ have "a' \<in> circline_set x_axis"
	+ using `poincare_on_ray a' 0\<^sub>h ?a` xa `0\<^sub>h \<noteq> ?a` `xa \<noteq> 0` `a' \<in> unit_disc`
	+ unfolding poincare_on_ray_def
	+ using poincare_line_0_real_is_x_axis[of "of_complex xa"]
	+ using poincare_between_poincare_line_uvz[of "0\<^sub>h" "of_complex xa" a']
	+ using poincare_between_poincare_line_uzv[of "0\<^sub>h" "of_complex xa" a']
	+ by (auto simp add: cmod_eq_Re)
	+
	+ then obtain xa' where xa': "a' = of_complex xa'" "is_real xa'"
	+ using `a' \<in> unit_disc`
	+ using circline_set_def on_circline_x_axis
	+ by auto
	+
	+ hence "-1 < Re xa'" "Re xa' < 1" "xa' \<noteq> 0"
	+ using `a' \<in> unit_disc` `a' \<noteq> 0\<^sub>h`
	+ by (auto simp add: cmod_eq_Re)
	+
	+ hence "Re xa' > 0" "Re xa' < 1" "is_real xa'"
	+ using `poincare_on_ray a' 0\<^sub>h (of_complex xa)`
	+ using poincare_between_x_axis_0uv[of "Re xa'" "Re xa"]
	+ using poincare_between_x_axis_0uv[of "Re xa" "Re xa'"]
	+ using circline_set_positive_x_axis_I[of "Re xa'"]
	+ using xa xa' complex_of_real_Re
	+ unfolding poincare_on_ray_def
	+ by (smt of_real_0, linarith, blast)
	+
	+ moreover
	+
	+ obtain xx where "is_real xx" "Re xx > 0" "Re xx < 1" "x = of_complex xx"
	+ using x
	+ unfolding positive_x_axis_def
	+ using circline_set_def cmod_eq_Re on_circline_x_axis
	+ by auto
	+
	+ ultimately
	+
	+ show "poincare_between 0\<^sub>h x a' \<or> poincare_between 0\<^sub>h a' x"
	+ using `a' = of_complex xa'`
	+ by (smt \<open>a' \<in> unit_disc\<close> arg_0_iff poincare_between_0uv poincare_between_def to_complex_of_complex x(1))
	+ qed
	+
	+ qed
	+
	+ thus ?thesis
	+ using `x \<in> unit_disc`
	+ unfolding poincare_ray_meets_line_def poincare_on_line_def
	+ by (metis insert_commute)
	+ qed
	+ qed
	+ next
	+ show "a \<noteq> 0\<^sub>h"
	+ proof (rule ccontr)
	+ assume "\<not> ?thesis"
	+ then obtain k where "k<0" "to_complex ?a1 = cor k * to_complex ?a2"
	+ using poincare_between_u0v[OF `?a1 \<in> unit_disc` `?a2 \<in> unit_disc` `?a1 \<noteq> 0\<^sub>h` `?a2 \<noteq> 0\<^sub>h`]
	+ using `poincare_between ?a1 a ?a2`
	+ by auto
	+ hence "to_complex i1 = cor k * to_complex i2" "k < 0"
	+ by auto
	+ hence "0\<^sub>h \<in> circline_set (poincare_line x1 x2)"
	+ using ideal_points_proportional[of "poincare_line x1 x2" i1 i2 k] `ideal_points (poincare_line x1 x2) = {i1, i2}`
	+ using is_poincare_line_poincare_line[OF `x1 \<noteq> x2`]
	+ by simp
	+ thus False
	+ using `\<not> poincare_collinear {0\<^sub>h, x1, x2}`
	+ using is_poincare_line_poincare_line[OF `x1 \<noteq> x2`]
	+ unfolding poincare_collinear_def
	+ by (meson \<open>x1 \<noteq> x2\<close> empty_subsetI insert_subset poincare_line_circline_set(1) poincare_line_circline_set(2))
	+ qed
	+ next
	+ fix \<phi> u
	+ let ?R' = "\<lambda> a zero. \<forall> a' a1 a2 x1 x2 i1 i2. ?R zero a' a1 a2 x1 x2 i1 i2 a"
	+ let ?M = "moebius_pt (moebius_rotation \<phi>)"
	+ assume : "u \<in> unit_disc" "u \<noteq> 0\<^sub>h" and *: "?R' (?M u) 0\<^sub>h"
	+ have uf: "unit_disc_fix (moebius_rotation \<phi>)"
	+ by simp
	+ have "?M 0\<^sub>h = 0\<^sub>h"
	+ by auto
	+ hence **: "?R' (?M u) (?M 0\<^sub>h)"
	+ using **
	+ by simp
	+ show "?R' u 0\<^sub>h"
	+ proof (rule allI)+
	+ fix a' a1 a2 x1 x2 i1 i2
	+ have i1: "i1 \<in> unit_circle_set \<longrightarrow> moebius_pt (moebius_rotation \<phi>) (of_complex (to_complex i1 / 2)) = of_complex (to_complex (moebius_pt (moebius_rotation \<phi>) i1) / 2)"
	+ using unit_circle_set_def by force
	+
	+ have i2: "i2 \<in> unit_circle_set \<longrightarrow> moebius_pt (moebius_rotation \<phi>) (of_complex (to_complex i2 / 2)) = of_complex (to_complex (moebius_pt (moebius_rotation \<phi>) i2) / 2)"
	+ using unit_circle_set_def by force
	+
	+ show "?R 0\<^sub>h a' a1 a2 x1 x2 i1 i2 u"
	+ using *[rule_format, of "?M a'" "?M x1" "?M x2" "?M i1" "?M i2" "?M a1" "?M a2"] uf
	+ apply (auto simp del: moebius_pt_moebius_rotation_zero moebius_pt_moebius_rotation)
	+ using i1 i2
	+ by simp
	+ qed
	+ qed
	+ thus ?thesis
	+ using `a' \<in> unit_disc` `x1 \<in> unit_disc` `x2 \<in> unit_disc` `x1 \<noteq> x2`
	+ using `\<not> poincare_collinear {0\<^sub>h, x1, x2}` `ideal_points ?lx = {i1, i2}` `i1 \<noteq> i2`
	+ using `?a1 \<noteq> ?a2` `poincare_collinear {0\<^sub>h, ?a1, i1}` `poincare_collinear {0\<^sub>h, ?a2, i2}`
	+ using `?a1 \<in> unit_disc` `?a2 \<in> unit_disc` `i1 \<in> unit_circle_set` `i2 \<in> unit_circle_set`
	+ using `poincare_on_ray a' 0\<^sub>h a` `a' \<noteq> 0\<^sub>h` `poincare_between ?a1 a ?a2` `a \<noteq> ?a1` `a \<noteq> ?a2`
	+ by blast
	+ qed
	+ qed
	+
	+ moreover
	+
	+ have "\<not> poincare_on_line 0\<^sub>h ?a1 ?a2"
	+ proof
	+ assume *: "poincare_on_line 0\<^sub>h ?a1 ?a2"
	+ hence "poincare_collinear {0\<^sub>h, ?a1, ?a2}"
	+ unfolding poincare_on_line_def
	+ by simp
	+ hence "poincare_line 0\<^sub>h ?a1 = poincare_line 0\<^sub>h ?a2"
	+ using poincare_collinear3_poincare_lines_equal_general[of "0\<^sub>h" ?a1 ?a2]
	+ using \<open>?a1 \<in> unit_disc\<close> \<open>?a1 \<noteq> 0\<^sub>h\<close> \<open>?a2 \<in> unit_disc\<close> \<open>?a2 \<noteq> 0\<^sub>h\<close>
	+ by (metis inversion_noteq_unit_disc zero_in_unit_disc)
	+
	+ have "i1 \<in> circline_set (poincare_line 0\<^sub>h ?a1)"
	+ using `poincare_collinear {0\<^sub>h, ?a1, i1}`
	+ using poincare_collinear3_poincare_line_general[of i1 "0\<^sub>h" ?a1]
	+ using \<open>?a1 \<in> unit_disc\<close> `?a1 \<noteq> 0\<^sub>h`
	+ by (metis insert_commute inversion_noteq_unit_disc zero_in_unit_disc)
	+ moreover
	+ have "i2 \<in> circline_set (poincare_line 0\<^sub>h ?a1)"
	+ using `poincare_collinear {0\<^sub>h, ?a2, i2}`
	+ using poincare_collinear3_poincare_line_general[of i2 "0\<^sub>h" ?a2]
	+ using \<open>?a2 \<in> unit_disc\<close> `?a2 \<noteq> 0\<^sub>h` \<open>poincare_line 0\<^sub>h ?a1 = poincare_line 0\<^sub>h ?a2\<close>
	+ by (metis insert_commute inversion_noteq_unit_disc zero_in_unit_disc)
	+
	+ ultimately
	+
	+ have "poincare_collinear {0\<^sub>h, i1, i2}"
	+ using \<open>?a1 \<in> unit_disc\<close> \<open>?a1 \<noteq> 0\<^sub>h\<close> \<open>poincare_collinear {0\<^sub>h, ?a1, i1}\<close>
	+ by (smt insert_subset poincare_collinear_def unique_poincare_line zero_in_unit_disc)
	+ hence "0\<^sub>h \<in> circline_set (poincare_line i1 i2)"
	+ using poincare_collinear3_poincare_line_general[of "0\<^sub>h" i1 i2]
	+ using \<open>i1 \<noteq> i2\<close> \<open>i2 \<in> unit_circle_set\<close> unit_circle_set_def
	+ by force
	+
	+ moreover
	+
	+ have "?lx = ?li"
	+ using \<open>ideal_points ?lx = {i1, i2}\<close> \<open>x1 \<noteq> x2\<close> ideal_points_line_unique
	+ by auto
	+
	+ ultimately
	+
	+ show False
	+ using \<open>\<not> poincare_collinear {0\<^sub>h, x1, x2}\<close>
	+ using \<open>x1 \<noteq> x2\<close> poincare_line_poincare_collinear3_general
	+ by auto
	+ qed
	+
	+ ultimately
	+
	+ show ?thesis
	+ using `?a1 \<in> unit_disc` `?a2 \<in> unit_disc`
	+ by blast
	+ qed
	+ qed
	+ qed
	+ thus ?thesis
	+ using `x1 \<in> unit_disc` `x2 \<in> unit_disc` `\<not> poincare_collinear {a, x1, x2}`
	+ by blast
	+qed
	+
	+subsection\<open>Interpretation of locales\<close>
	+
	+global_interpretation PoincareTarskiAbsolute: TarskiAbsolute where cong = p_congruent and betw = p_between
	+ defines p_on_line = PoincareTarskiAbsolute.on_line and
	+ p_on_ray = PoincareTarskiAbsolute.on_ray and
	+ p_in_angle = PoincareTarskiAbsolute.in_angle and
	+ p_ray_meets_line = PoincareTarskiAbsolute.ray_meets_line
	+proof-
	+ show "TarskiAbsolute p_congruent p_between"
	+ proof
	+ text\<open> 1. Reflexivity of congruence \<close>
	+ fix x y
	+ show "p_congruent x y y x"
	+ unfolding p_congruent_def
	+ by transfer (simp add: poincare_distance_sym)
	+ next
	+ text\<open> 2. Transitivity of congruence \<close>
	+ fix x y z u v w
	+ show "p_congruent x y z u \<and> p_congruent x y v w \<longrightarrow> p_congruent z u v w"
	+ by (transfer, simp)
	+ next
	+ text\<open> 3. Identity of congruence \<close>
	+ fix x y z
	+ show "p_congruent x y z z \<longrightarrow> x = y"
	+ unfolding p_congruent_def
	+ by transfer (simp add: poincare_distance_eq_0_iff)
	+ next
	+ text\<open> 4. Segment construction \<close>
	+ fix x y a b
	+ show "\<exists> z. p_between x y z \<and> p_congruent y z a b"
	+ using segment_construction
	+ unfolding p_congruent_def
	+ by transfer (simp, blast)
	+ next
	+ text\<open> 5. Five segment \<close>
	+ fix x y z x' y' z' u u'
	+ show "x \<noteq> y \<and> p_between x y z \<and> p_between x' y' z' \<and>
	+ p_congruent x y x' y' \<and> p_congruent y z y' z' \<and>
	+ p_congruent x u x' u' \<and> p_congruent y u y' u' \<longrightarrow>
	+ p_congruent z u z' u'"
	+ unfolding p_congruent_def
	+ apply transfer
	+ using five_segment_axiom
	+ by meson
	+ next
	+ text\<open> 6. Identity of betweeness \<close>
	+ fix x y
	+ show "p_between x y x \<longrightarrow> x = y"
	+ by transfer (simp add: poincare_between_sum_distances poincare_distance_eq_0_iff poincare_distance_sym)
	+ next
	+ text\<open> 7. Pasch \<close>
	+ fix x y z u v
	+ show "p_between x u z \<and> p_between y v z \<longrightarrow> (\<exists> a. p_between u a y \<and> p_between x a v)"
	+ apply transfer
	+ using Pasch
	+ by blast
	+ next
	+ text\<open> 8. Lower dimension \<close>
	+ show "\<exists> a. \<exists> b. \<exists> c. \<not> p_between a b c \<and> \<not> p_between b c a \<and> \<not> p_between c a b"
	+ apply (transfer)
	+ using lower_dimension_axiom
	+ by simp
	+ next
	+ text\<open> 9. Upper dimension \<close>
	+ fix x y z u v
	+ show "p_congruent x u x v \<and> p_congruent y u y v \<and> p_congruent z u z v \<and> u \<noteq> v \<longrightarrow>
	+ p_between x y z \<or> p_between y z x \<or> p_between z x y"
	+ unfolding p_congruent_def
	+ by (transfer, simp add: upper_dimension_axiom)
	+ qed
	+qed
	+
	+
	+interpretation PoincareTarskiHyperbolic: TarskiHyperbolic
	+ where cong = p_congruent and betw = p_between
	+proof
	+ text\<open> 10. Euclid negation \<close>
	+ show "\<exists> a b c d t. p_between a d t \<and> p_between b d c \<and> a \<noteq> d \<and>
	+ (\<forall> x y. p_between a b x \<and> p_between a c y \<longrightarrow> \<not> p_between x t y)"
	+ using negated_euclidean_axiom
	+ by transfer (auto, blast)
	+next
	+ fix a x1 x2
	+ assume "\<not> TarskiAbsolute.on_line p_between a x1 x2"
	+ hence "\<not> p_on_line a x1 x2"
	+ using TarskiAbsolute.on_line_def[OF PoincareTarskiAbsolute.TarskiAbsolute_axioms]
	+ using PoincareTarskiAbsolute.on_line_def
	+ by simp
	+ text\<open> 11. Limiting parallels \<close>
	+ thus "\<exists>a1 a2.
	+ \<not> TarskiAbsolute.on_line p_between a a1 a2 \<and>
	+ \<not> TarskiAbsolute.ray_meets_line p_between a a1 x1 x2 \<and>
	+ \<not> TarskiAbsolute.ray_meets_line p_between a a2 x1 x2 \<and>
	+ (\<forall>a'. TarskiAbsolute.in_angle p_between a' a1 a a2 \<longrightarrow> TarskiAbsolute.ray_meets_line p_between a a' x1 x2)"
	+ unfolding TarskiAbsolute.in_angle_def[OF PoincareTarskiAbsolute.TarskiAbsolute_axioms]
	+ unfolding TarskiAbsolute.on_ray_def[OF PoincareTarskiAbsolute.TarskiAbsolute_axioms]
	+ unfolding TarskiAbsolute.ray_meets_line_def[OF PoincareTarskiAbsolute.TarskiAbsolute_axioms]
	+ unfolding TarskiAbsolute.on_ray_def[OF PoincareTarskiAbsolute.TarskiAbsolute_axioms]
	+ unfolding TarskiAbsolute.on_line_def[OF PoincareTarskiAbsolute.TarskiAbsolute_axioms]
	+ unfolding PoincareTarskiAbsolute.on_line_def
	+ apply transfer
	+ proof-
	+ fix a x1 x2
	+ assume *: "a \<in> unit_disc" "x1 \<in> unit_disc" "x2 \<in> unit_disc"
	+ "\<not> (poincare_between a x1 x2 \<or> poincare_between x1 a x2 \<or> poincare_between x1 x2 a)"
	+ hence "\<not> poincare_on_line a x1 x2"
	+ using poincare_collinear3_iff[of a x1 x2]
	+ using poincare_between_rev poincare_on_line_def by blast
	+ hence "\<exists>a1\<in>unit_disc.
	+ \<exists>a2\<in>unit_disc.
	+ \<not> poincare_on_line a a1 a2 \<and>
	+ \<not> poincare_ray_meets_line a a1 x1 x2 \<and>
	+ \<not> poincare_ray_meets_line a a2 x1 x2 \<and>
	+ (\<forall>a'\<in>unit_disc.
	+ poincare_in_angle a' a1 a a2 \<longrightarrow>
	+ poincare_ray_meets_line a a' x1 x2)"
	+ using limiting_parallels[of a x1 x2] *
	+ by blast
	+ then obtain a1 a2 where **: "a1\<in>unit_disc" "a2\<in>unit_disc" "\<not> poincare_on_line a a1 a2"
	+ "\<not> poincare_ray_meets_line a a2 x1 x2"
	+ "\<not> poincare_ray_meets_line a a1 x1 x2"
	+ "\<forall>a'\<in>unit_disc.
	+ poincare_in_angle a' a1 a a2 \<longrightarrow>
	+ poincare_ray_meets_line a a' x1 x2"
	+ by blast
	+ have "\<not> (\<exists>x\<in>{z. z \<in> unit_disc}.
	+ (poincare_between a x a1 \<or>
	+ poincare_between a a1 x) \<and>
	+ (poincare_between x x1 x2 \<or>
	+ poincare_between x1 x x2 \<or>
	+ poincare_between x1 x2 x))"
	+ using `\<not> poincare_ray_meets_line a a1 x1 x2`
	+ unfolding poincare_on_line_def poincare_ray_meets_line_def poincare_on_ray_def
	+ using poincare_collinear3_iff[of _ x1 x2] poincare_between_rev *(2, 3)
	+ by auto
	+ moreover
	+ have "\<not> (\<exists>x\<in>{z. z \<in> unit_disc}.
	+ (poincare_between a x a2 \<or>
	+ poincare_between a a2 x) \<and>
	+ (poincare_between x x1 x2 \<or>
	+ poincare_between x1 x x2 \<or>
	+ poincare_between x1 x2 x))"
	+ using `\<not> poincare_ray_meets_line a a2 x1 x2`
	+ unfolding poincare_on_line_def poincare_ray_meets_line_def poincare_on_ray_def
	+ using poincare_collinear3_iff[of _ x1 x2] poincare_between_rev *(2, 3)
	+ by auto
	+ moreover
	+ have "\<not> (poincare_between a a1 a2 \<or> poincare_between a1 a a2 \<or> poincare_between a1 a2 a)"
	+ using `\<not> poincare_on_line a a1 a2` poincare_collinear3_iff[of a a1 a2]
	+ using (1) *(1-2)
	+ unfolding poincare_on_line_def
	+ by simp
	+ moreover
	+ have "(\<forall>a'\<in>{z. z \<in> unit_disc}.
	+ a \<noteq> a1 \<and>
	+ a \<noteq> a2 \<and>
	+ a' \<noteq> a \<and>
	+ (\<exists>x\<in>{z. z \<in> unit_disc}.
	+ poincare_between a1 x a2 \<and>
	+ x \<noteq> a1 \<and>
	+ x \<noteq> a2 \<and>
	+ (poincare_between a a' x \<or>
	+ poincare_between a x a')) \<longrightarrow>
	+ (\<exists>x\<in>{z. z \<in> unit_disc}.
	+ (poincare_between a x a' \<or>
	+ poincare_between a a' x) \<and>
	+ (poincare_between x x1 x2 \<or>
	+ poincare_between x1 x x2 \<or>
	+ poincare_between x1 x2 x)))"
	+ using **(6)
	+ unfolding poincare_on_line_def poincare_in_angle_def poincare_ray_meets_line_def poincare_on_ray_def
	+ using poincare_collinear3_iff[of _ x1 x2] poincare_between_rev *(2, 3)
	+ by auto
	+ ultimately
	+ show "\<exists>a1\<in>{z. z \<in> unit_disc}.
	+ \<exists>a2\<in>{z. z \<in> unit_disc}.
	+ \<not> (poincare_between a a1 a2 \<or> poincare_between a1 a a2 \<or> poincare_between a1 a2 a) \<and>
	+ \<not> (\<exists>x\<in>{z. z \<in> unit_disc}.
	+ (poincare_between a x a1 \<or>
	+ poincare_between a a1 x) \<and>
	+ (poincare_between x x1 x2 \<or>
	+ poincare_between x1 x x2 \<or>
	+ poincare_between x1 x2 x)) \<and>
	+ \<not> (\<exists>x\<in>{z. z \<in> unit_disc}.
	+ (poincare_between a x a2 \<or>
	+ poincare_between a a2 x) \<and>
	+ (poincare_between x x1 x2 \<or>
	+ poincare_between x1 x x2 \<or>
	+ poincare_between x1 x2 x)) \<and>
	+ (\<forall>a'\<in>{z. z \<in> unit_disc}.
	+ a \<noteq> a1 \<and>
	+ a \<noteq> a2 \<and>
	+ a' \<noteq> a \<and>
	+ (\<exists>x\<in>{z. z \<in> unit_disc}.
	+ poincare_between a1 x a2 \<and>
	+ x \<noteq> a1 \<and>
	+ x \<noteq> a2 \<and>
	+ (poincare_between a a' x \<or>
	+ poincare_between a x a')) \<longrightarrow>
	+ (\<exists>x\<in>{z. z \<in> unit_disc}.
	+ (poincare_between a x a' \<or>
	+ poincare_between a a' x) \<and>
	+ (poincare_between x x1 x2 \<or>
	+ poincare_between x1 x x2 \<or>
	+ poincare_between x1 x2 x)))"
	+ using **(1, 2)
	+ by auto
	+ qed
	+qed
	+
	+interpretation PoincareElementaryTarskiHyperbolic: ElementaryTarskiHyperbolic p_congruent p_between
	+proof
	+ text\<open> 12. Continuity \<close>
	+ fix \<phi> \<psi>
	+ assume "\<exists> a. \<forall> x. \<forall> y. \<phi> x \<and> \<psi> y \<longrightarrow> p_between a x y"
	+ thus "\<exists> b. \<forall> x. \<forall> y. \<phi> x \<and> \<psi> y \<longrightarrow> p_between x b y"
	+ apply transfer
	+ using continuity
	+ by auto
	+qed
	+
	+end
	diff --git a/thys/Poincare_Disc/ROOT b/thys/Poincare_Disc/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/ROOT
	@@ -0,0 +1,21 @@
	+chapter AFP
	+
	+session Poincare_Disc (AFP) = HOL +
	+ options [timeout = 1200]
	+ sessions
	+ "Complex_Geometry"
	+ theories
	+ Hyperbolic_Functions
	+ Tarski
	+ Poincare_Lines
	+ Poincare_Lines_Ideal_Points
	+ Poincare_Distance
	+ Poincare_Circles
	+ Poincare_Between
	+ Poincare_Lines_Axis_Intersections
	+ Poincare_Perpendicular
	+ Poincare
	+ Poincare_Tarski
	+ document_files
	+ "root.bib"
	+ "root.tex"
	diff --git a/thys/Poincare_Disc/Tarski.thy b/thys/Poincare_Disc/Tarski.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/Tarski.thy
	@@ -0,0 +1,61 @@
	+section\<open>Tarski axioms\<close>
	+
	+text \<open>In this section we introduce axioms of Tarski \cite{tarski} trough a series of locales.\<close>
	+
	+theory Tarski
	+imports Main
	+begin
	+
	+text \<open>The first locale assumes all Tarski axioms except for the Euclid's axiom and the continuity
	+axiom and corresponds to absolute geometry.\<close>
	+
	+locale TarskiAbsolute =
	+ fixes cong :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool"
	+ fixes betw :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool"
	+ assumes cong_reflexive: "cong x y y x"
	+ assumes cong_transitive: "cong x y z u \<and> cong x y v w \<longrightarrow> cong z u v w"
	+ assumes cong_identity: "cong x y z z \<longrightarrow> x = y"
	+ assumes segment_construction: "\<exists> z. betw x y z \<and> cong y z a b"
	+ assumes five_segment: "x \<noteq> y \<and> betw x y z \<and> betw x' y' z' \<and> cong x y x' y' \<and> cong y z y' z' \<and> cong x u x' u' \<and> cong y u y' u' \<longrightarrow> cong z u z' u'"
	+ assumes betw_identity: "betw x y x \<longrightarrow> x = y"
	+ assumes Pasch: "betw x u z \<and> betw y v z \<longrightarrow> (\<exists> a. betw u a y \<and> betw x a v)"
	+ assumes lower_dimension: "\<exists> a. \<exists> b. \<exists> c. \<not> betw a b c \<and> \<not> betw b c a \<and> \<not> betw c a b"
	+ assumes upper_dimension: "cong x u x v \<and> cong y u y v \<and> cong z u z v \<and> u \<noteq> v \<longrightarrow> betw x y z \<or> betw y z x \<or> betw z x y"
	+begin
	+
	+text \<open>The following definitions are used to specify axioms in the following locales.\<close>
	+
	+text \<open>Point $p$ is on line $ab$.\<close>
	+definition on_line where
	+ "on_line p a b \<longleftrightarrow> betw p a b \<or> betw a p b \<or> betw a b p"
	+
	+text \<open>Point $p$ is on ray $ab$.\<close>
	+definition on_ray where
	+ "on_ray p a b \<longleftrightarrow> betw a p b \<or> betw a b p"
	+
	+text \<open>Point $p$ is inside angle $abc$.\<close>
	+definition in_angle where
	+ "in_angle p a b c \<longleftrightarrow> b \<noteq> a \<and> b \<noteq> c \<and> p \<noteq> b \<and> (\<exists> x. betw a x c \<and> x \<noteq> a \<and> x \<noteq> c \<and> on_ray p b x)"
	+
	+text \<open>Ray $r_ar_b$ meets the line $l_al_b$.\<close>
	+definition ray_meets_line where
	+ "ray_meets_line ra rb la lb \<longleftrightarrow> (\<exists> x. on_ray x ra rb \<and> on_line x la lb)"
	+
	+end
	+
	+text\<open>The second locales adds the negation of Euclid's axiom and limiting parallels and corresponds
	+to hyperbolic geometry.\<close>
	+
	+locale TarskiHyperbolic = TarskiAbsolute +
	+ assumes euclid_negation: "\<exists> a b c d t. betw a d t \<and> betw b d c \<and> a \<noteq> d \<and> (\<forall> x y. betw a b x \<and> betw a c y \<longrightarrow> \<not> betw x t y)"
	+ assumes limiting_parallels: "\<not> on_line a x1 x2 \<Longrightarrow>
	+ (\<exists> a1 a2. \<not> on_line a a1 a2 \<and>
	+ \<not> ray_meets_line a a1 x1 x2 \<and>
	+ \<not> ray_meets_line a a2 x1 x2 \<and>
	+ (\<forall> a'. in_angle a' a1 a a2 \<longrightarrow> ray_meets_line a a' x1 x2))"
	+
	+text\<open>The third locale adds the continuity axiom and corresponds to elementary hyperbolic geometry.\<close>
	+locale ElementaryTarskiHyperbolic = TarskiHyperbolic +
	+ assumes continuity: "\<lbrakk>\<exists> a. \<forall> x. \<forall> y. \<phi> x \<and> \<psi> y \<longrightarrow> betw a x y\<rbrakk> \<Longrightarrow> \<exists> b. \<forall> x. \<forall> y. \<phi> x \<and> \<psi> y \<longrightarrow> betw x b y"
	+
	+end
	diff --git a/thys/Poincare_Disc/document/root.bib b/thys/Poincare_Disc/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Poincare_Disc/document/root.bib
	@@ -0,0 +1,87 @@
	+@book{tarski,
	+ author = {Wolfram Schwabhäuser and Wanda Szmielew and Alfred Tarski},
	+ title = {{Metamathematische Methoden in der Geometrie}},
	+ publisher = {Springer-Verlag},
	+ year = {1983},
	+ address = {Berlin}
	+}
	+
	+@article{amai-complexplane,
	+ year={2015},
	+ author = "Mari{\'c}, Filip and Simi{\'c}, Danijela",
	+ doi = "10.1007/s10472-014-9436-4",
	+ issn = "1012-2443",
	+ journal = "Annals of Mathematics and Artificial Intelligence",
	+ keywords = "Interactive theorem proving; Complex plane geometry; Möbius transformations; 68T15; 51B10; 97I80",
	+ number = "3-4",
	+ pages = "271–308",
	+ publisher = "Springer International Publishing",
	+ title = "{Formalizing Complex Plane Geometry}",
	+ url = "http://dx.doi.org/10.1007/s10472-014-9436-4",
	+ volume = "74"
	+}
	+
	+@book{schwerdtfeger,
	+ title={{Geometry of Complex Numbers: Circle Geometry, Moebius Transformation, Non-euclidean Geometry}},
	+ author={Schwerdtfeger, Hans},
	+ year={1979},
	+ publisher={Courier Corporation}
	+}
	+
	+@mastersthesis{makarios,
	+ title = {{A Mechanical Verification of the Independence of Tarski's Euclidean Axiom}},
	+ author = {Makarios, Timothy James McKenzie},
	+ school = {Victoria University of Wellington},
	+ year = {2012},
	+ note = {Master Thesis}
	+}
	+
	+@Inbook{lobachevsky1840geometrische,
	+author="Lobatschewsky, Nicolaus",
	+title="Geometrische Untersuchungen zur Theorie der Parallellinien",
	+bookTitle="Gau{\ss} und die Anf{\"a}nge der nicht-euklidischen Geometrie",
	+year="1985",
	+publisher="Springer Vienna",
	+address="Vienna",
	+pages="159--223",
	+abstract="In der Geometrie fand ich einige Unvollkom-menheiten, welche ich f{\"u}r den Grund halte, warum diese Missenschaft, so lange sie nicht in die Analysis {\"u}bergeht, bis ietzt keinen Schritt vorw{\"a}rts thun konnte aus demienigen Zustande, in welchem sie uns von Guclid {\"u}berkommen ist. Zu den Unvollkommenheiten rechne ich die Dunkelheit in den ersten Begriffen von den geometrischen Gr{\"o}{\ss}en, in der Art und Meise wie man sich die Ausmessung dieser Gr{\"o}{\ss}en vorstellt, und endlich die wichtige L{\"u}cke in der Theorie der Parallelen, welche auszuf{\"u}llen, alle Anstrengungen der Wathematiker bis ietzt vergeblich waren. Die Bem{\"u}hungen Legnedre's haben zu doeser Theorie nichts hinzugef{\"u}gt, indem er gen{\"o}thigt war, den einzigen strengen Gang zu derlassen, sich auf einen Seitenweg zu wenden, und zu H{\"u}lfss{\"a}tzen seine Zuflucht zu nehmen, welche er sich unbegr{\"u}ndeter Weise bemihet als nothwendige Ariome darzustellen.",
	+isbn="978-3-7091-9511-6",
	+doi="10.1007/978-3-7091-9511-6_4",
	+url="https://doi.org/10.1007/978-3-7091-9511-6_4"
	+}
	+
	+@article{coghetto2018klein1,
	+ title={{Klein-Beltrami Model. Part I}},
	+ author={Coghetto, Roland},
	+ journal={Formalized Mathematics},
	+ volume={26},
	+ number={1},
	+ pages={21--32},
	+ year={2018},
	+ publisher={Sciendo}
	+}
	+
	+@article{coghetto2018klein2,
	+ title={{Klein-Beltrami Model. Part II}},
	+ author={Coghetto, Roland},
	+ journal={Formalized Mathematics},
	+ volume={26},
	+ number={1},
	+ pages={33--48},
	+ year={2018},
	+ publisher={Sciendo}
	+}
	+
	+
	+
	+@article{afp-complex-geometry,
	+ author = {Filip Marić and Danijela Simić},
	+ title = {Complex Geometry},
	+ journal = {Archive of Formal Proofs},
	+ month = dec,
	+ year = 2019,
	+ note = {\url{http://isa-afp.org/entries/Complex_Geometry.html},
	+ Formal proof development},
	+ ISSN = {2150-914x},
	+}
	+
	diff --git a/thys/Poincare_Disc/document/root.tex b/thys/Poincare_Disc/document/root.tex
	new file mode 100755
	--- /dev/null
	+++ b/thys/Poincare_Disc/document/root.tex
	@@ -0,0 +1,79 @@
	+\documentclass[8pt,a4paper]{article}
	+\usepackage[margin=2cm]{geometry}
	+\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}
	+
	+\usepackage{amsmath}
	+
	+\begin{document}
	+
	+\title{Poincar\'e Disc Model}
	+\author{Danijela Simi\'c \and
	+ Filip Mari\'c \and
	+ Pierre Boutry}
	+\maketitle
	+
	+\begin{abstract}
	+ We describe formalization of the Poincar\'e disc model of hyperbolic
	+ geometry within the Isabelle/HOL proof assistant. The model is
	+ defined within the extended complex plane (one dimensional complex
	+ projective space $\mathbb{C}P^1$), formalized in the AFP entry
	+ ``Complex Geometry'' \cite{afp-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).
	+\end{abstract}
	+
	+\tableofcontents
	+
	+% sane default for proof documents
	+\parindent 0pt\parskip 0.5ex
	+
	+\clearpage
	+% generated text of all theories
	+\input{session}
	+
	+% optional bibliography
	+\clearpage
	+\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,509 +1,519 @@
	AODV
	Auto2_HOL
	Auto2_Imperative_HOL
	AVL-Trees
	AWN
	Abortable_Linearizable_Modules
	Abs_Int_ITP2012
	Abstract-Hoare-Logics
	Abstract-Rewriting
	Abstract_Completeness
	Abstract_Soundness
	Adaptive_State_Counting
	Affine_Arithmetic
	Aggregation_Algebras
	Akra_Bazzi
	Algebraic_Numbers
	Algebraic_VCs
	Allen_Calculus
	Amortized_Complexity
	AnselmGod
	Applicative_Lifting
	+Approximation_Algorithms
	Architectural_Design_Patterns
	Aristotles_Assertoric_Syllogistic
	+Arith_Prog_Rel_Primes
	ArrowImpossibilityGS
	AutoFocus-Stream
	Automatic_Refinement
	AxiomaticCategoryTheory
	BDD
	BNF_Operations
	Bell_Numbers_Spivey
	Berlekamp_Zassenhaus
	Bernoulli
	Bertrands_Postulate
	+Bicategory
	BinarySearchTree
	Binding_Syntax_Theory
	Binomial-Heaps
	Binomial-Queues
	BNF_CC
	Bondy
	Boolean_Expression_Checkers
	Bounded_Deducibility_Security
	Buchi_Complementation
	Budan_Fourier
	Buffons_Needle
	Buildings
	BytecodeLogicJmlTypes
	C2KA_DistributedSystems
	CAVA_Automata
	CAVA_LTL_Modelchecker
	CCS
	CISC-Kernel
	CRDT
	CYK
	CakeML
	CakeML_Codegen
	Call_Arity
	Card_Equiv_Relations
	Card_Multisets
	Card_Number_Partitions
	Card_Partitions
	Cartan_FP
	Case_Labeling
	Catalan_Numbers
	Category
	Category2
	Category3
	Cauchy
	Cayley_Hamilton
	Certification_Monads
	Chord_Segments
	Circus
	Clean
	ClockSynchInst
	+Closest_Pair_Points
	CofGroups
	Coinductive
	Coinductive_Languages
	Collections
	Comparison_Sort_Lower_Bound
	Compiling-Exceptions-Correctly
	Completeness
	Complete_Non_Orders
	+Complex_Geometry
	Complx
	ComponentDependencies
	ConcurrentGC
	ConcurrentIMP
	Concurrent_Ref_Alg
	Concurrent_Revisions
	Consensus_Refined
	Constructive_Cryptography
	Constructor_Funs
	Containers
	CoreC++
	Core_DOM
	Count_Complex_Roots
	CryptHOL
	CryptoBasedCompositionalProperties
	DFS_Framework
	DPT-SAT-Solver
	DataRefinementIBP
	Datatype_Order_Generator
	Decl_Sem_Fun_PL
	Decreasing-Diagrams
	Decreasing-Diagrams-II
	Deep_Learning
	Density_Compiler
	Dependent_SIFUM_Refinement
	Dependent_SIFUM_Type_Systems
	Depth-First-Search
	Derangements
	Deriving
	Descartes_Sign_Rule
	Dict_Construction
	Differential_Dynamic_Logic
	Differential_Game_Logic
	Dijkstra_Shortest_Path
	Diophantine_Eqns_Lin_Hom
	Dirichlet_L
	Dirichlet_Series
	Discrete_Summation
	DiscretePricing
	DiskPaxos
	DynamicArchitectures
	Dynamic_Tables
	E_Transcendental
	Echelon_Form
	EdmondsKarp_Maxflow
	Efficient-Mergesort
	Elliptic_Curves_Group_Law
	Encodability_Process_Calculi
	Epistemic_Logic
	Ergodic_Theory
	Error_Function
	Euler_MacLaurin
	Euler_Partition
	Example-Submission
	Factored_Transition_System_Bounding
	Farkas
	FFT
	FLP
	FOL-Fitting
	FOL_Harrison
	FOL_Seq_Calc1
	Falling_Factorial_Sum
	FeatherweightJava
	Featherweight_OCL
	Fermat3_4
	FileRefinement
	FinFun
	Finger-Trees
	Finite_Automata_HF
	First_Order_Terms
	First_Welfare_Theorem
	Fishburn_Impossibility
	Fisher_Yates
	Flow_Networks
	Floyd_Warshall
	Flyspeck-Tame
	FocusStreamsCaseStudies
	Formal_SSA
	Formula_Derivatives
	Fourier
	Free-Boolean-Algebra
	Free-Groups
	FunWithFunctions
	FunWithTilings
	Functional-Automata
	Functional_Ordered_Resolution_Prover
	GPU_Kernel_PL
	Gabow_SCC
	Game_Based_Crypto
	Gauss-Jordan-Elim-Fun
	Gauss_Jordan
	+Gauss_Sums
	GenClock
	General-Triangle
	Generalized_Counting_Sort
	Generic_Deriving
	Generic_Join
	GewirthPGCProof
	Girth_Chromatic
	GoedelGod
	GraphMarkingIBP
	Graph_Saturation
	Graph_Theory
	Green
	Groebner_Bases
	Groebner_Macaulay
	Gromov_Hyperbolicity
	Group-Ring-Module
	HOL-CSP
	HOLCF-Prelude
	HRB-Slicing
	Heard_Of
	HereditarilyFinite
	Hermite
	Hidden_Markov_Models
	Higher_Order_Terms
	Hoare_Time
	HotelKeyCards
	Huffman
	Hybrid_Logic
	Hybrid_Multi_Lane_Spatial_Logic
	Hybrid_Systems_VCs
	HyperCTL
	IEEE_Floating_Point
	IMAP-CRDT
	IMO2019
	IMP2
	IMP2_Binary_Heap
	IP_Addresses
	Imperative_Insertion_Sort
	Impossible_Geometry
	Incompleteness
	Incredible_Proof_Machine
	Inductive_Confidentiality
	InfPathElimination
	InformationFlowSlicing
	InformationFlowSlicing_Inter
	Integration
	Interval_Arithmetic_Word32
	Iptables_Semantics
	Irrationality_J_Hancl
	Isabelle_C
	Isabelle_Meta_Model
	Jacobson_Basic_Algebra
	Jinja
	JinjaThreads
	JiveDataStoreModel
	Jordan_Hoelder
	Jordan_Normal_Form
	KAD
	KAT_and_DRA
	KBPs
	KD_Tree
	Key_Agreement_Strong_Adversaries
	Kleene_Algebra
	Knot_Theory
	Knuth_Morris_Pratt
	Koenigsberg_Friendship
	Kruskal
	Kuratowski_Closure_Complement
	LLL_Basis_Reduction
	LLL_Factorization
	LOFT
	LTL
	LTL_to_DRA
	LTL_to_GBA
	LTL_Master_Theorem
	Lam-ml-Normalization
	LambdaAuth
	LambdaMu
	Lambda_Free_KBOs
	Lambda_Free_RPOs
	Landau_Symbols
	Laplace_Transform
	Latin_Square
	LatticeProperties
	Lambda_Free_EPO
	Launchbury
	Lazy-Lists-II
	Lazy_Case
	Lehmer
	Lifting_Definition_Option
	LightweightJava
	LinearQuantifierElim
	Linear_Inequalities
	Linear_Programming
	Linear_Recurrences
	Liouville_Numbers
	List-Index
	List-Infinite
	List_Interleaving
	List_Inversions
	List_Update
	LocalLexing
	Localization_Ring
	Locally-Nameless-Sigma
	Lowe_Ontological_Argument
	Lower_Semicontinuous
	Lp
	MFMC_Countable
	MSO_Regex_Equivalence
	Markov_Models
	Marriage
	Mason_Stothers
	Matrix
	Matrix_Tensor
	Matroids
	Max-Card-Matching
	Median_Of_Medians_Selection
	Menger
	+Mersenne_Primes
	MFOTL_Monitor
	MiniML
	Minimal_SSA
	Minkowskis_Theorem
	Minsky_Machines
	Modal_Logics_for_NTS
	Modular_Assembly_Kit_Security
	Monad_Memo_DP
	Monad_Normalisation
	MonoBoolTranAlgebra
	MonoidalCategory
	Monomorphic_Monad
	MuchAdoAboutTwo
	Multirelations
	Multi_Party_Computation
	Myhill-Nerode
	Name_Carrying_Type_Inference
	Nat-Interval-Logic
	Native_Word
	Nested_Multisets_Ordinals
	Network_Security_Policy_Verification
	Neumann_Morgenstern_Utility
	No_FTL_observers
	Nominal2
	Noninterference_CSP
	Noninterference_Concurrent_Composition
	Noninterference_Generic_Unwinding
	Noninterference_Inductive_Unwinding
	Noninterference_Ipurge_Unwinding
	Noninterference_Sequential_Composition
	NormByEval
	Nullstellensatz
	Octonions
	Open_Induction
	OpSets
	Optics
	Optimal_BST
	Orbit_Stabiliser
	Order_Lattice_Props
	Ordered_Resolution_Prover
	Ordinal
	Ordinals_and_Cardinals
	Ordinary_Differential_Equations
	PCF
	PLM
	Pell
	POPLmark-deBruijn
	PSemigroupsConvolution
	Pairing_Heap
	Paraconsistency
	Parity_Game
	Partial_Function_MR
	Partial_Order_Reduction
	Password_Authentication_Protocol
	Perfect-Number-Thm
	Perron_Frobenius
	Pi_Calculus
	Pi_Transcendental
	Planarity_Certificates
	Polynomial_Factorization
	Polynomial_Interpolation
	Polynomials
	Poincare_Bendixson
	+Poincare_Disc
	Pop_Refinement
	Posix-Lexing
	Possibilistic_Noninterference
	Pratt_Certificate
	Presburger-Automata
	Prim_Dijkstra_Simple
	Prime_Distribution_Elementary
	Prime_Harmonic_Series
	Prime_Number_Theorem
	Priority_Queue_Braun
	Priority_Search_Trees
	Probabilistic_Noninterference
	Probabilistic_Prime_Tests
	Probabilistic_System_Zoo
	Probabilistic_Timed_Automata
	Probabilistic_While
	Projective_Geometry
	Program-Conflict-Analysis
	Promela
	Proof_Strategy_Language
	PropResPI
	Propositional_Proof_Systems
	Prpu_Maxflow
	PseudoHoops
	Psi_Calculi
	Ptolemys_Theorem
	QHLProver
	QR_Decomposition
	Quantales
	Quaternions
	Quick_Sort_Cost
	RIPEMD-160-SPARK
	ROBDD
	RSAPSS
	Ramsey-Infinite
	Random_BSTs
	Randomised_BSTs
	Random_Graph_Subgraph_Threshold
	Randomised_Social_Choice
	Rank_Nullity_Theorem
	Real_Impl
	Recursion-Theory-I
	Refine_Imperative_HOL
	Refine_Monadic
	RefinementReactive
	Regex_Equivalence
	Regular-Sets
	Regular_Algebras
	Relation_Algebra
	Rep_Fin_Groups
	Residuated_Lattices
	Resolution_FOL
	Rewriting_Z
	Ribbon_Proofs
	Robbins-Conjecture
	Root_Balanced_Tree
	Routing
	Roy_Floyd_Warshall
	Safe_OCL
	SATSolverVerification
	SDS_Impossibility
	SIFPL
	SIFUM_Type_Systems
	SPARCv8
	Secondary_Sylow
	Security_Protocol_Refinement
	Selection_Heap_Sort
	SenSocialChoice
	Separata
	Separation_Algebra
	Separation_Logic_Imperative_HOL
	SequentInvertibility
	Shivers-CFA
	ShortestPath
	Show
	Sigma_Commit_Crypto
	Signature_Groebner
	Simpl
	Simple_Firewall
	Simplex
	Skew_Heap
	+Skip_Lists
	Slicing
	Smooth_Manifolds
	Sort_Encodings
	Source_Coding_Theorem
	Special_Function_Bounds
	Splay_Tree
	Sqrt_Babylonian
	Stable_Matching
	Statecharts
	Stellar_Quorums
	Stern_Brocot
	Stewart_Apollonius
	Stirling_Formula
	Stochastic_Matrices
	Stone_Algebras
	Stone_Kleene_Relation_Algebras
	Stone_Relation_Algebras
	Store_Buffer_Reduction
	Stream-Fusion
	Stream_Fusion_Code
	Strong_Security
	Sturm_Sequences
	Sturm_Tarski
	Stuttering_Equivalence
	Subresultants
	+Subset_Boolean_Algebras
	SumSquares
	SuperCalc
	Surprise_Paradox
	Symmetric_Polynomials
	Szpilrajn
	TESL_Language
	TLA
	Tail_Recursive_Functions
	Tarskis_Geometry
	Taylor_Models
	Timed_Automata
	Topology
	TortoiseHare
	Transcendence_Series_Hancl_Rucki
	Transformer_Semantics
	Transition_Systems_and_Automata
	Transitive-Closure
	Transitive-Closure-II
	Treaps
	Tree-Automata
	Tree_Decomposition
	Triangle
	Trie
	Twelvefold_Way
	Tycon
	Types_Tableaus_and_Goedels_God
	Universal_Turing_Machine
	UPF
	UPF_Firewall
	UpDown_Scheme
	UTP
	Valuation
	VectorSpace
	Verified-Prover
	VerifyThis2018
	VerifyThis2019
	Vickrey_Clarke_Groves
	VolpanoSmith
	WHATandWHERE_Security
	WebAssembly
	Weight_Balanced_Trees
	Well_Quasi_Orders
	Winding_Number_Eval
	Word_Lib
	WorkerWrapper
	XML
	Zeta_Function
	Zeta_3_Irrational
	ZFC_in_HOL
	pGCL
	diff --git a/thys/Skip_Lists/Draft.thy b/thys/Skip_Lists/Draft.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Skip_Lists/Draft.thy
	@@ -0,0 +1,266 @@
	+theory Draft
	+imports Skip_List
	+begin
	+
	+
	+
	+locale abstract_sl' =
	+ fixes
	+ val :: "'a \<Rightarrow> 'b" and
	+ down :: "'a \<Rightarrow> 'a option" and
	+ right :: "'a \<Rightarrow> 'a option" and
	+ V :: "'a set"
	+
	+locale abstract_sl = abstract_sl' +
	+ assumes f: "finite V"
	+begin
	+
	+
	+function acyclic where
	+ "acyclic visited a = (let visited' = visited \<union> {a} in (if visited' \<subseteq> V \<and> a \<notin> visited then
	+ (case down a of Some d \<Rightarrow> acyclic (visited \<union> {a}) d \| None \<Rightarrow> True) else False))"
	+ by auto
	+termination
	+ by (relation "Wellfounded.measure (\<lambda>(visited, v). card V - card visited)")
	+ (use f in \<open>auto simp add: finite_subset intro!: psubset_card_mono diff_less_mono2\<close>)
	+
	+
	+
	+
	+locale abstract_sl = abstract_sl' +
	+ fixes wf_sl
	+ assumes ""
	+
	+
	+datatype ('a::linorder) slttt = SL 'a "nat option" "nat option"
	+
	+
	+term "map_of [(0, SL 1 (Some 1) (Some 3)), (1, SL 1 None (Some 2)), (2, SL 8 None (Some 4))]"
	+
	+function lookup :: "'a::linorder \<Rightarrow> 'a list list \<Rightarrow> bool" where
	+ "lookup x [] = False" \|
	+ "lookup x ((y#ys)#ls) = (if x = y then True else
	+ (if y < x then lookup x (ys#(map (dropWhile (\<lambda>z. z \<le> y)) ls)) else
	+ lookup x ls))" \|
	+ "lookup x ([] # ls) = lookup x ls"
	+ by pat_completeness auto
	+termination
	+proof (relation "(\<lambda>(a,xs). length (concat xs)) <mlex> (\<lambda>(a,xs). length xs) <mlex> {}",
	+ goal_cases)
	+ case 1
	+ then show ?case by(intro wf_mlex wf_empty)
	+next
	+ case (2 a y ys ls)
	+ have "length (concat (map (dropWhile (\<lambda>z. z \<le> y)) ls)) \<le> (length (concat ls))"
	+ by (auto simp add: length_concat length_dropWhile_le intro!: sum_list_mono)
	+ then show ?case by (intro mlex_less) auto
	+next
	+ case (3 x y ys ls)
	+ then show ?case by (intro mlex_less) auto
	+next
	+ case (4 x ls)
	+ then show ?case by (rule mlex_leq) (auto intro!: mlex_less)
	+qed
	+
	+definition sl where "sl ls = (list_all distinct ls \<and> list_all sorted ls \<and> sorted_wrt subseq ls)"
	+
	+
	+lemma subseq_dropWhile: "subseq xs ys \<Longrightarrow> subseq (dropWhile P xs) ys"
	+ by (induction xs ys rule: list_emb.induct) (auto)
	+
	+lemma subseq_dropWhile': "subseq xs ys \<Longrightarrow> subseq (dropWhile P xs) (dropWhile P ys)"
	+ by (induction xs ys rule: list_emb.induct) (use subseq_dropWhile in auto)
	+
	+lemma sl_map_dropWhile: "sl ls \<Longrightarrow> sl (map (dropWhile P) ls)"
	+ by (induction ls) (use subseq_dropWhile' in \<open>auto simp add: sorted_dropWhile sl_def\<close>)
	+
	+definition set_sl where "set_sl ls = \<Union> (set ` set ls)"
	+
	+lemma set_sl_Cons:
	+ "set xs \<subseteq> set xs' \<Longrightarrow> set_sl ls \<subseteq> set_sl ls' \<Longrightarrow> set_sl (xs # ls) \<subseteq> set_sl (xs' # ls')"
	+ unfolding set_sl_def by (auto)
	+
	+lemma subseq_subset: "subseq xs ys \<Longrightarrow> set xs \<subseteq> set ys"
	+ by (induction xs ys rule: list_emb.induct) (auto)
	+
	+lemma subseq_sorted: "subseq xs ys \<Longrightarrow> sorted ys \<Longrightarrow> sorted xs"
	+ by (induction xs ys rule: list_emb.induct) (use subseq_subset in auto)
	+
	+lemma subseq_distinct: "subseq xs ys \<Longrightarrow> distinct ys \<Longrightarrow> distinct xs"
	+ by (induction xs ys rule: list_emb.induct) (use subseq_subset in auto)
	+
	+lemma set_dropWhile: "set (dropWhile P ls) \<subseteq> set ls"
	+ by (induction ls) auto
	+
	+lemma "lookup x ls \<Longrightarrow> x \<in> set_sl ls"
	+ using set_dropWhile
	+ by (induction x ls rule: lookup.induct) (fastforce split: if_splits simp add: set_sl_def)+
	+
	+lemma "subseq xs ys \<Longrightarrow> distinct ys \<Longrightarrow> distinct xs"
	+ by (induction xs ys rule: list_emb.induct) (use subseq_subset in auto)
	+
	+lemma subseq_dropWhile_leq:
	+ assumes "sorted ys" "distinct ys" "subseq xs ys" "xs = x'#xs'"
	+ shows "subseq xs' (dropWhile (\<lambda>z. z \<le> x') ys)"
	+using assms proof (induction ys arbitrary: xs x' xs')
	+ case Nil
	+ then show ?case by simp
	+next
	+ case (Cons y ys xs x' xs')
	+ have ?case if "x' = y" "xs' \<noteq> []"
	+ using that Cons by (cases ys) (auto)
	+ moreover have ?case if "x' < y"
	+ proof -
	+ have "subseq xs' (y # ys)"
	+ using Cons subseq_Cons' by metis
	+ then show ?thesis
	+ using that Cons by (auto)
	+ qed
	+ ultimately show ?case using Cons by (cases "x' = y") (auto)
	+qed
	+
	+lemma sorted_dropWhile_filter: "sorted ls \<Longrightarrow> dropWhile (\<lambda>x. x \<le> y) ls = filter (\<lambda>x. x > y) ls"
	+ by (induction ls) (auto simp add: less_le_trans)
	+
	+lemma sl_dropWhile_filter: "sl ls \<Longrightarrow> map (dropWhile (\<lambda>x. x \<le> y)) ls = map (filter (\<lambda>x. x > y)) ls"
	+ by (auto simp add: sl_def list_all_iff intro!: map_cong sorted_dropWhile_filter)
	+
	+lemma "sl ls \<Longrightarrow> x \<in> set_sl ls \<Longrightarrow> lookup x ls"
	+(* TODO: clean up *)
	+proof (induction x ls rule: lookup.induct)
	+ case (1 x)
	+ then show ?case by (fastforce split: if_splits simp add: set_sl_def)
	+next
	+ case (2 x y ys ls)
	+ consider (a) "x = y" \| (b) "y < x" \| (c) "x < y"
	+ by fastforce
	+ then show ?case
	+ proof (cases)
	+ case b
	+ have "sl (ys # map (dropWhile (\<lambda>z. z \<le> y)) ls)"
	+ proof (cases ls)
	+ case Nil
	+ then show ?thesis using 2 by (auto simp add: sl_def)
	+ next
	+ case (Cons l' ls')
	+ have I:"sl (map (dropWhile (\<lambda>z. z \<le> y)) ls)"
	+ using 2 by (auto intro!: sl_map_dropWhile) (simp add: sl_def)
	+ have "subseq ys (dropWhile (\<lambda>z. z \<le> y) l')"
	+ using 2 Cons by (auto simp add: sl_def intro!: subseq_dropWhile_leq)
	+ then show ?thesis
	+ using Cons I by (auto simp add: sl_def list_all_iff subseq_sorted subseq_distinct)
	+ qed
	+ moreover have "set_sl (ys # map (dropWhile (\<lambda>z. z \<le> y)) ls) = set_sl (ys # map (filter (\<lambda>z. y < z)) ls)"
	+ using 2 by (subst sl_dropWhile_filter) (auto simp add: sl_def)
	+ ultimately show ?thesis
	+ using b 2 by (auto simp add: set_sl_def intro!: 2)
	+ next
	+ case c
	+ then have "x \<in> set_sl ls"
	+ using 2 subseq_subset by (cases ls) (auto simp add: set_sl_def sl_def)
	+ then have "lookup x ls"
	+ using c 2 by (auto simp add: set_sl_def sl_def intro!: 2)
	+ then show ?thesis
	+ using c 2 by (auto)
	+ qed (auto)
	+next
	+ case (3 x ls)
	+ then show ?case by (fastforce split: if_splits simp add: set_sl_def sl_def)
	+qed
	+
	+fun sl_insert' where
	+ "sl_insert' x (Suc n) (l#ls) = insort x l # sl_insert' x n ls" \|
	+ "sl_insert' x 0 (l#ls) = insort x l # ls" \|
	+ "sl_insert' x (Suc n) [] = [x] # sl_insert' x n []" \|
	+ "sl_insert' x 0 [] = [[x]]"
	+
	+definition sl_insert where
	+ "sl_insert x n ls = (if lookup x ls then ls else rev (sl_insert' x n (rev ls)))"
	+
	+lemma sl_rev:
	+ "sl (rev ls) = (list_all distinct ls \<and> list_all sorted ls \<and> sorted_wrt (\<lambda>x y. subseq y x) ls)"
	+ by (auto simp add: sl_def sorted_wrt_rev)
	+
	+lemma subseq_sorted_wrt: "sorted_wrt P xs \<Longrightarrow> subseq ys xs \<Longrightarrow> sorted_wrt P ys"
	+proof (induction ys)
	+ case (Cons y ys)
	+ then have "P y y'" if "y' \<in> set ys" for y'
	+ using that subseq_subset by (induction xs) (auto split: if_splits)
	+ then show ?case
	+ using Cons by (auto simp add: subseq_Cons')
	+qed (auto)
	+
	+lemma sl_subseq_sl: "sl ls \<Longrightarrow> subseq ls' ls \<Longrightarrow> sl ls'"
	+ using subseq_subset subseq_sorted_wrt by (fastforce simp add: sl_def list_all_iff)
	+
	+lemma subseq_rev: "subseq xs ys \<Longrightarrow> subseq (rev xs) (rev ys)"
	+ by (induction xs ys rule: list_emb.induct) (auto)
	+
	+lemma subseq_insort_key: "subseq xs (insort_key P x xs)"
	+ by (induction xs) (auto)
	+
	+lemma 1111: assumes "l \<in> set (sl_insert' x n ls)"
	+ shows "(\<exists>l' \<in> set ls. l = insort x l') \<or> l = [x] \<or> l \<in> set ls"
	+ using assms by (induction x n ls rule: sl_insert'.induct) (auto)
	+
	+lemma 28: "subseq xs ys \<Longrightarrow> sorted ys \<Longrightarrow> subseq (insort x xs) (insort x ys)"
	+proof (induction xs ys rule: list_emb.induct)
	+ case (list_emb_Cons xs ys y)
	+ then have "\<forall>x\<in>set xs. y \<le> x"
	+ using subseq_subset by (auto)
	+ then have "insort x xs = x # xs" if "x \<le> y"
	+ using that by (subst insort_is_Cons) (auto simp add: insort_is_Cons)
	+ then show ?case
	+ using list_emb_Cons by (auto)
	+qed (auto simp add: set_insort_key subseq_singleton_left)
	+
	+
	+
	+lemma
	+ assumes "sl ls"
	+ shows "sl (sl_insert x n ls)"
	+proof -
	+ let ?sws = "sorted_wrt (\<lambda>x y. subseq y x)"
	+ let ?sort = "(\<lambda>ls. list_all sorted ls \<and> sorted_wrt (\<lambda>x y. subseq y x) ls)"
	+ have "?sort (sl_insert' x n xs)" if "?sort xs" for xs
	+ using that proof (induction x n xs rule: sl_insert'.induct)
	+ case (1 x n y ys)
	+ have "subseq l' (insort x y)" if "l' \<in> set (sl_insert' x n ys) " for l'
	+ using 1 that apply - apply(drule 1111[of l']) apply(auto)
	+ defer
	+ apply(subst subseq_singleton_left)
	+ apply (simp add: set_insort_key)
	+ apply(subgoal_tac "subseq l' y")
	+ using subseq_insort_key[of y]
	+ using subseq_order.order_trans apply blast
	+ using 1 apply(blast)
	+ apply(rule 28)
	+ by (auto)
	+ then show ?case
	+ using 1 sorted_insort by (auto)
	+ next
	+ case (2 x l ls)
	+ then have "subseq l' l" if "l' \<in> set ls" for l'
	+ using that by (auto)
	+ moreover have "subseq l (insort x l)"
	+ by (simp add: subseq_insort_key)
	+ ultimately have "subseq l' (insort x l)" if "l' \<in> set ls" for l'
	+ using that by fastforce
	+ then show ?case
	+ using 2 sorted_insort by (auto)
	+ next
	+ case (3 x n)
	+ then show ?case
	+ by (cases n) (auto)
	+ qed (auto)
	+ then show ?thesis
	+ using assms sorry
	+qed
	+
	+notepad
	+begin
	+ have 1: "a + b \<le> c" (is "?x + ?y \<le> ?z") for a b c::nat
	+ sorry
	+ let ?y = 1
	+
	+end
	diff --git a/thys/Skip_Lists/Geometric_PMF.thy b/thys/Skip_Lists/Geometric_PMF.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Skip_Lists/Geometric_PMF.thy
	@@ -0,0 +1,342 @@
	+(*
	+ File: Pi_pmf.thy
	+ Authors: Manuel Eberl, Max W. Haslbeck
	+*)
	+section \<open>Theorems about the Geometric Distribution\<close>
	+theory Geometric_PMF
	+ imports
	+ "HOL-Probability.Probability"
	+ Pi_pmf
	+ "Monad_Normalisation.Monad_Normalisation"
	+begin
	+
	+lemma geometric_sums_times_n:
	+ fixes c::"'a::{banach,real_normed_field}"
	+ assumes "norm c < 1"
	+ shows "(\<lambda>n. c^n * of_nat n) sums (c / (1 - c)\<^sup>2)"
	+proof -
	+ have "(\<lambda>n. c * z ^ n) sums (c / (1 - z))" if "norm z < 1" for z
	+ using geometric_sums sums_mult that by fastforce
	+ moreover have "((\<lambda>z. c / (1 - z)) has_field_derivative (c / (1 - c)\<^sup>2)) (at c)"
	+ using assms by (auto intro!: derivative_eq_intros simp add: semiring_normalization_rules)
	+ ultimately have "(\<lambda>n. diffs (\<lambda>n. c) n * c ^ n) sums (c / (1 - c)\<^sup>2)"
	+ using assms by (intro termdiffs_sums_strong)
	+ then have "(\<lambda>n. of_nat (Suc n) * c ^ (Suc n)) sums (c / (1 - c)\<^sup>2)"
	+ unfolding diffs_def by (simp add: power_eq_if mult.assoc)
	+ then show ?thesis
	+ by (subst (asm) sums_Suc_iff) (auto simp add: mult.commute)
	+qed
	+
	+lemma geometric_sums_times_norm:
	+ fixes c::"'a::{banach,real_normed_field}"
	+ assumes "norm c < 1"
	+ shows "(\<lambda>n. norm (c^n * of_nat n)) sums (norm c / (1 - norm c)\<^sup>2)"
	+proof -
	+ have "norm (c^n * of_nat n) = (norm c) ^ n * of_nat n" for n::nat
	+ by (simp add: norm_power norm_mult)
	+ then show ?thesis
	+ using geometric_sums_times_n[of "norm c"] assms
	+ by force
	+qed
	+
	+lemma integrable_real_geometric_pmf:
	+ assumes "p \<in> {0<..1}"
	+ shows "integrable (geometric_pmf p) real"
	+proof -
	+ have "summable (\<lambda>x. p * ((1 - p) ^ x * real x))"
	+ using geometric_sums_times_norm[of "1 - p"] assms
	+ by (intro summable_mult) (auto simp: sums_iff)
	+ thus ?thesis
	+ unfolding measure_pmf_eq_density using assms
	+ by (subst integrable_density) (auto simp: integrable_count_space_nat_iff mult_ac)
	+qed
	+
	+lemma expectation_geometric_pmf:
	+ assumes "p \<in> {0<..1}"
	+ shows "measure_pmf.expectation (geometric_pmf p) real = (1 - p) / p"
	+proof -
	+ have "(\<lambda>n. p * ((1 - p) ^ n * n)) sums (p * ((1 - p) / p^2))"
	+ using assms geometric_sums_times_n[of "1-p"] by (intro sums_mult) auto
	+ moreover have "(\<lambda>n. p * ((1 - p) ^ n * n)) = (\<lambda>n. (1 - p) ^ n * p * real n)"
	+ by auto
	+ ultimately have : "(\<lambda>n. (1 - p) ^ n p * real n) sums ((1 - p) / p)"
	+ using assms sums_subst by (auto simp add: power2_eq_square)
	+ have "measure_pmf.expectation (geometric_pmf p) real =
	+ (\<integral>n. pmf (geometric_pmf p) n * real n \<partial>count_space UNIV)"
	+ unfolding measure_pmf_eq_density by (subst integral_density) auto
	+ also have "integrable (count_space UNIV) (\<lambda>n. pmf (geometric_pmf p) n * real n)"
	+ using * assms unfolding integrable_count_space_nat_iff by (simp add: sums_iff)
	+ hence "(\<integral>n. pmf (geometric_pmf p) n * real n \<partial>count_space UNIV) = (1 - p) / p"
	+ using * assms by (subst integral_count_space_nat) (simp_all add: sums_iff)
	+ finally show ?thesis by auto
	+qed
	+
	+lemma nn_integral_geometric_pmf:
	+ assumes "p \<in> {0<..1}"
	+ shows "nn_integral (geometric_pmf p) real = (1 - p) / p"
	+ using assms expectation_geometric_pmf integrable_real_geometric_pmf
	+ by (subst nn_integral_eq_integral) auto
	+
	+lemma geometric_bind_pmf_unfold:
	+ assumes "p \<in> {0<..1}"
	+ shows "geometric_pmf p =
	+ do {b \<leftarrow> bernoulli_pmf p;
	+ if b then return_pmf 0 else map_pmf Suc (geometric_pmf p)}"
	+proof -
	+ have *: "(Suc -` {i}) = (if i = 0 then {} else {i - 1})" for i
	+ by force
	+ have "pmf (geometric_pmf p) i =
	+ pmf (bernoulli_pmf p \<bind>
	+ (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf p)))
	+ i" for i
	+ proof -
	+ have "pmf (geometric_pmf p) i =
	+ (if i = 0 then p else (1 - p) * pmf (geometric_pmf p) (i - 1))"
	+ using assms by (simp add: power_eq_if)
	+ also have "\<dots> = (if i = 0 then p else (1 - p) * pmf (map_pmf Suc (geometric_pmf p)) i)"
	+ by (simp add: pmf_map indicator_def measure_pmf_single *)
	+ also have "\<dots> = measure_pmf.expectation (bernoulli_pmf p)
	+ (\<lambda>x. pmf (if x then return_pmf 0 else map_pmf Suc (geometric_pmf p)) i)"
	+ using assms by (auto simp add: pmf_map *)
	+ also have "\<dots> = pmf (bernoulli_pmf p \<bind>
	+ (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf p)))
	+ i"
	+ by (auto simp add: pmf_bind)
	+ finally show ?thesis .
	+ qed
	+ then show ?thesis
	+ using pmf_eqI by blast
	+qed
	+
	+lemma "p \<in> {0<..<1} \<Longrightarrow> set_pmf (geometric_pmf p) = UNIV"
	+ by (auto simp add: measure_pmf_single set_pmf_def)
	+
	+lemma "set_pmf (geometric_pmf 1) = 0"
	+ by (auto simp add: measure_pmf_single set_pmf_def)
	+
	+lemma geometric_pmf_prob_atMost:
	+ assumes "p \<in> {0<..1}"
	+ shows "measure_pmf.prob (geometric_pmf p) {..n} = (1 - (1 - p)^(n + 1))"
	+proof -
	+ have "(\<Sum>x\<le>n. (1 - p) ^ x * p) = 1 - (1 - p) * (1 - p) ^ n"
	+ by (induction n) (auto simp add: algebra_simps)
	+ then show ?thesis
	+ using assms by (auto simp add: measure_pmf_conv_infsetsum)
	+qed
	+
	+lemma geometric_pmf_prob_lessThan:
	+ assumes "p \<in> {0<..1}"
	+ shows "measure_pmf.prob (geometric_pmf p) {..<n} = 1 - (1 - p) ^ n"
	+proof -
	+ have "(\<Sum>x<n. (1 - p) ^ x * p) = 1 - (1 - p) ^ n"
	+ by (induction n) (auto simp add: algebra_simps)
	+ then show ?thesis
	+ using assms by (auto simp add: measure_pmf_conv_infsetsum)
	+qed
	+
	+lemma geometric_pmf_prob_greaterThan:
	+ assumes "p \<in> {0<..1}"
	+ shows "measure_pmf.prob (geometric_pmf p) {n<..} = (1 - p)^(n + 1)"
	+proof -
	+ have "(UNIV - {..n}) = {n<..}"
	+ by auto
	+ moreover have "measure_pmf.prob (geometric_pmf p) (UNIV - {..n}) = (1 - p) ^ (n + 1)"
	+ using assms by (subst measure_pmf.finite_measure_Diff)
	+ (auto simp add: geometric_pmf_prob_atMost)
	+ ultimately show ?thesis
	+ by auto
	+qed
	+
	+lemma geometric_pmf_prob_atLeast:
	+ assumes "p \<in> {0<..1}"
	+ shows "measure_pmf.prob (geometric_pmf p) {n..} = (1 - p)^n"
	+proof -
	+ have "(UNIV - {..<n}) = {n..}"
	+ by auto
	+ moreover have "measure_pmf.prob (geometric_pmf p) (UNIV - {..<n}) = (1 - p) ^ n"
	+ using assms by (subst measure_pmf.finite_measure_Diff)
	+ (auto simp add: geometric_pmf_prob_lessThan)
	+ ultimately show ?thesis
	+ by auto
	+qed
	+
	+lemma bernoulli_pmf_of_set':
	+ assumes "finite A"
	+ shows "map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A P (\<lambda>_. bernoulli_pmf (1/2))) = pmf_of_set (Pow A)"
	+proof -
	+ have *: "Pi_pmf A P (\<lambda>_. pmf_of_set (UNIV :: bool set)) = pmf_of_set (PiE_dflt A P (\<lambda>_. UNIV :: bool set))"
	+ using assms by (intro Pi_pmf_of_set) auto
	+ have "map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A P (\<lambda>_. bernoulli_pmf (1 / 2))) =
	+ map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A P (\<lambda>_. pmf_of_set UNIV))"
	+ using bernoulli_pmf_half_conv_pmf_of_set by auto
	+ also have "\<dots> = map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (pmf_of_set (PiE_dflt A P (\<lambda>_. UNIV)))"
	+ using assms by (subst Pi_pmf_of_set) (auto)
	+ also have "\<dots> = pmf_of_set (Pow A)"
	+ proof -
	+ have "bij_betw (\<lambda>b. {x \<in> A. \<not> b x}) (PiE_dflt A P (\<lambda>_. UNIV)) (Pow A)"
	+ by (rule bij_betwI[of _ _ _ "\<lambda>B b. if b \<in> A then \<not> (b \<in> B) else P"]) (auto simp add: PiE_dflt_def)
	+ then show ?thesis
	+ using assms by (intro map_pmf_of_set_bij_betw) auto
	+ qed
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma Pi_pmf_pmf_of_set_Suc:
	+ assumes "finite A"
	+ shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
	+ do {
	+ B \<leftarrow> pmf_of_set (Pow A);
	+ Pi_pmf B 0 (\<lambda>_. map_pmf Suc (geometric_pmf (1/2))) }"
	+proof -
	+ have "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
	+ Pi_pmf A 0 (\<lambda>_. bernoulli_pmf (1/2) \<bind>
	+ (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
	+ using assms by (subst geometric_bind_pmf_unfold) auto
	+ also have "\<dots> =
	+ Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)) \<bind>
	+ (\<lambda>b. Pi_pmf A 0 (\<lambda>x. if b x then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
	+ using assms by (subst Pi_pmf_bind[of _ _ _ _ False]) auto
	+ also have "\<dots> =
	+ do {b \<leftarrow> Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2));
	+ Pi_pmf {x \<in> A. ~b x} 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
	+ using assms by (subst Pi_pmf_if_set') auto
	+ also have "\<dots> =
	+ do {B \<leftarrow> map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)));
	+ Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
	+ unfolding map_pmf_def apply(subst bind_assoc_pmf) apply(subst bind_return_pmf) by auto
	+ also have "\<dots> = pmf_of_set (Pow A) \<bind> (\<lambda>B. Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1 / 2))))"
	+ unfolding assms using assms by (subst bernoulli_pmf_of_set') auto
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma Pi_pmf_pmf_of_set_Suc':
	+ assumes "finite A"
	+ shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
	+ do {
	+ B \<leftarrow> pmf_of_set (Pow A);
	+ Pi_pmf B 0 (\<lambda>_. map_pmf Suc (geometric_pmf (1/2))) }"
	+proof -
	+ have "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
	+ Pi_pmf A 0 (\<lambda>_. bernoulli_pmf (1/2) \<bind>
	+ (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
	+ using assms by (subst geometric_bind_pmf_unfold) auto
	+ also have "\<dots> =
	+ Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)) \<bind>
	+ (\<lambda>b. Pi_pmf A 0 (\<lambda>x. if b x then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
	+ using assms by (subst Pi_pmf_bind[of _ _ _ _ False]) auto
	+ also have "\<dots> =
	+ do {b \<leftarrow> Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2));
	+ Pi_pmf {x \<in> A. ~b x} 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
	+ using assms by (subst Pi_pmf_if_set') auto
	+ also have "\<dots> =
	+ do {B \<leftarrow> map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)));
	+ Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
	+ unfolding map_pmf_def by (auto simp add: bind_assoc_pmf bind_return_pmf)
	+ also have "\<dots> = pmf_of_set (Pow A) \<bind> (\<lambda>B. Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1 / 2))))"
	+ unfolding assms using assms by (subst bernoulli_pmf_of_set') auto
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma binomial_pmf_altdef':
	+ fixes A :: "'a set"
	+ assumes "finite A" and "card A = n" and p: "p \<in> {0..1}"
	+ shows "binomial_pmf n p =
	+ map_pmf (\<lambda>f. card {x\<in>A. f x}) (Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p))" (is "?lhs = ?rhs")
	+proof -
	+ from assms have "?lhs = binomial_pmf (card A) p"
	+ by simp
	+ also have "\<dots> = ?rhs"
	+ using assms(1)
	+ proof (induction rule: finite_induct)
	+ case empty
	+ with p show ?case by (simp add: binomial_pmf_0)
	+ next
	+ case (insert x A)
	+ from insert.hyps have "card (insert x A) = Suc (card A)"
	+ by simp
	+ also have "binomial_pmf \<dots> p = do {
	+ b \<leftarrow> bernoulli_pmf p;
	+ f \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
	+ return_pmf ((if b then 1 else 0) + card {y \<in> A. f y})
	+ }"
	+ using p by (simp add: binomial_pmf_Suc insert.IH bind_map_pmf)
	+ also have "\<dots> = do {
	+ b \<leftarrow> bernoulli_pmf p;
	+ f \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
	+ return_pmf (card {y \<in> insert x A. (f(x := b)) y})
	+ }"
	+ proof (intro bind_pmf_cong refl, goal_cases)
	+ case (1 b f)
	+ have "(if b then 1 else 0) + card {y\<in>A. f y} = card ((if b then {x} else {}) \<union> {y\<in>A. f y})"
	+ using insert.hyps by auto
	+ also have "(if b then {x} else {}) \<union> {y\<in>A. f y} = {y\<in>insert x A. (f(x := b)) y}"
	+ using insert.hyps by auto
	+ finally show ?case by simp
	+ qed
	+ also have "\<dots> = map_pmf (\<lambda>f. card {y\<in>insert x A. f y})
	+ (Pi_pmf (insert x A) dflt (\<lambda>_. bernoulli_pmf p))"
	+ using insert.hyps by (subst Pi_pmf_insert) (simp_all add: pair_pmf_def map_bind_pmf)
	+ finally show ?case .
	+ qed
	+ finally show ?thesis .
	+qed
	+
	+lemma bernoulli_pmf_Not:
	+ assumes "p \<in> {0..1}"
	+ shows "bernoulli_pmf p = map_pmf Not (bernoulli_pmf (1 - p))"
	+proof -
	+ have *: "(Not -` {True}) = {False}" "(Not -` {False}) = {True}"
	+ by blast+
	+ have "pmf (bernoulli_pmf p) b = pmf (map_pmf Not (bernoulli_pmf (1 - p))) b" for b
	+ using assms by (cases b) (auto simp add: pmf_map * measure_pmf_single)
	+ then show ?thesis
	+ by (rule pmf_eqI)
	+qed
	+
	+lemma binomial_pmf_altdef'':
	+ assumes p: "p \<in> {0..1}"
	+ shows "binomial_pmf n p =
	+ map_pmf (\<lambda>f. card {x. x < n \<and> f x}) (Pi_pmf {..<n} dflt (\<lambda>_. bernoulli_pmf p))"
	+ using assms by (subst binomial_pmf_altdef'[of "{..<n}"]) (auto)
	+
	+context includes monad_normalisation
	+begin
	+
	+lemma Pi_pmf_geometric_filter:
	+ assumes "finite A" "p \<in> {0<..1}"
	+ shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf p) =
	+ do {
	+ fb \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
	+ Pi_pmf {x \<in> A. \<not> fb x} 0 (\<lambda>_. map_pmf Suc (geometric_pmf p)) }"
	+proof -
	+ have "Pi_pmf A 0 (\<lambda>_. geometric_pmf p) =
	+ Pi_pmf A 0 (\<lambda>_. bernoulli_pmf p \<bind>
	+ (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf p)))"
	+ using assms by (subst geometric_bind_pmf_unfold) auto
	+ also have "\<dots> =
	+ Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p) \<bind>
	+ (\<lambda>b. Pi_pmf A 0 (\<lambda>x. if b x then return_pmf 0 else map_pmf Suc (geometric_pmf p)))"
	+ using assms by (subst Pi_pmf_bind[of _ _ _ _ dflt]) auto
	+ also have "\<dots> =
	+ do {b \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
	+ Pi_pmf {x \<in> A. \<not> b x} 0 (\<lambda>x. map_pmf Suc (geometric_pmf p))}"
	+ using assms by (subst Pi_pmf_if_set') (auto)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma Pi_pmf_geometric_filter':
	+ assumes "finite A" "p \<in> {0<..1}"
	+ shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf p) =
	+ do {
	+ fb \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf (1 - p));
	+ Pi_pmf {x \<in> A. fb x} 0 (\<lambda>_. map_pmf Suc (geometric_pmf p)) }"
	+ using assms by (auto simp add: Pi_pmf_geometric_filter[of _ _ "\<not> dflt"] bernoulli_pmf_Not[of p]
	+ Pi_pmf_map[of _ _ dflt] map_pmf_def[of "((\<circ>) Not)"])
	+
	+end
	+
	+end
	diff --git a/thys/Skip_Lists/Misc.thy b/thys/Skip_Lists/Misc.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Skip_Lists/Misc.thy
	@@ -0,0 +1,192 @@
	+(*
	+ File: Misc.thy
	+ Authors: Max W. Haslbeck, Manuel Eberl
	+*)
	+section \<open>Auxiliary material\<close>
	+theory Misc
	+ imports "HOL-Analysis.Analysis"
	+begin
	+
	+text \<open>Based on @{term sorted_list_of_set} and @{term the_inv_into} we construct a bijection between
	+ a finite set A of type 'a::linorder and a set of natural numbers @{term "{..< card A}"}\<close>
	+
	+lemma bij_betw_mono_on_the_inv_into:
	+ fixes A::"'a::linorder set" and B::"'b::linorder set"
	+ assumes b: "bij_betw f A B" and m: "mono_on f A"
	+ shows "mono_on (the_inv_into A f) B"
	+proof (rule ccontr)
	+ assume "\<not> mono_on (the_inv_into A f) B"
	+ then have "\<exists>r s. r \<in> B \<and> s \<in> B \<and> r \<le> s \<and> \<not> the_inv_into A f s \<ge> the_inv_into A f r"
	+ unfolding mono_on_def by blast
	+ then obtain r s where rs: "r \<in> B" "s \<in> B" "r \<le> s" "the_inv_into A f s < the_inv_into A f r"
	+ by fastforce
	+ have f: "f (the_inv_into A f b) = b" if "b \<in> B" for b
	+ using that assms f_the_inv_into_f_bij_betw by metis
	+ have "the_inv_into A f s \<in> A" "the_inv_into A f r \<in> A"
	+ using rs assms by (auto simp add: bij_betw_def the_inv_into_into)
	+ then have "f (the_inv_into A f s) \<le> f (the_inv_into A f r)"
	+ using rs by (intro mono_onD[OF m]) (auto)
	+ then have "r = s"
	+ using rs f by simp
	+ then show False
	+ using rs by auto
	+qed
	+
	+lemma rev_removeAll_removeAll_rev: "rev (removeAll x xs) = removeAll x (rev xs)"
	+ by (simp add: removeAll_filter_not_eq rev_filter)
	+
	+lemma sorted_list_of_set_Min_Cons:
	+ assumes "finite A" "A \<noteq> {}"
	+ shows "sorted_list_of_set A = Min A # sorted_list_of_set (A - {Min A})"
	+proof -
	+ have *: "A = insert (Min A) A"
	+ using assms Min_in by (auto)
	+ then have "sorted_list_of_set A = insort (Min A) (sorted_list_of_set (A - {Min A}))"
	+ using assms by (subst *, intro sorted_list_of_set_insert) auto
	+ also have "\<dots> = Min A # sorted_list_of_set (A - {Min A})"
	+ using assms by (intro insort_is_Cons) (auto)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma sorted_list_of_set_filter:
	+ assumes "finite A"
	+ shows "sorted_list_of_set ({x\<in>A. P x}) = filter P (sorted_list_of_set A)"
	+ using assms proof (induction "sorted_list_of_set A" arbitrary: A)
	+ case (Cons x xs)
	+ have x: "x \<in> A"
	+ using Cons sorted_list_of_set list.set_intros(1) by metis
	+ have "sorted_list_of_set A = Min A # sorted_list_of_set (A - {Min A})"
	+ using Cons by (intro sorted_list_of_set_Min_Cons) auto
	+ then have 1: "x = Min A" "xs = sorted_list_of_set (A - {x})"
	+ using Cons by auto
	+ { assume Px: "P x"
	+ have 2: "sorted_list_of_set {x \<in> A. P x} = Min {x \<in> A. P x} # sorted_list_of_set ({x \<in> A. P x} - {Min {x \<in> A. P x}})"
	+ using Px Cons 1 sorted_list_of_set_eq_Nil_iff
	+ by (intro sorted_list_of_set_Min_Cons) fastforce+
	+ also have 3: "Min {x \<in> A. P x} = x"
	+ using Cons 1 Px x by (auto intro!: Min_eqI)
	+ also have 4: "{x \<in> A. P x} - {x} = {y \<in> A - {x}. P y}"
	+ by blast
	+ also have 5: "sorted_list_of_set {y \<in> A - {x}. P y} = filter P (sorted_list_of_set (A - {x}))"
	+ using 1 Cons by (intro Cons) (auto)
	+ also have "\<dots> = filter P xs"
	+ using 1 by simp
	+ also have "filter P (sorted_list_of_set A) = x # filter P xs"
	+ using Px by (simp flip: \<open>x # xs = sorted_list_of_set A\<close>)
	+ finally have ?case
	+ by auto }
	+ moreover
	+ { assume Px: "\<not> P x"
	+ then have "{x \<in> A. P x} = {y \<in> A - {x}. P y}"
	+ by blast
	+ also have "sorted_list_of_set \<dots> = filter P (sorted_list_of_set (A - {x}))"
	+ using 1 Cons by (intro Cons) auto
	+ also have "filter P (sorted_list_of_set (A - {x})) = filter P (sorted_list_of_set A)"
	+ using 1 Px by (simp flip: \<open>x # xs = sorted_list_of_set A\<close>)
	+ finally have ?case
	+ by simp }
	+ ultimately show ?case
	+ by blast
	+qed (use sorted_list_of_set_eq_Nil_iff in fastforce)
	+
	+lemma sorted_list_of_set_Max_snoc:
	+ assumes "finite A" "A \<noteq> {}"
	+ shows "sorted_list_of_set A = sorted_list_of_set (A - {Max A}) @ [Max A]"
	+proof -
	+ have *: "A = insert (Max A) A"
	+ using assms Max_in by (auto)
	+ then have "sorted_list_of_set A = insort (Max A) (sorted_list_of_set (A - {Max A}))"
	+ using assms by (subst *, intro sorted_list_of_set_insert) auto
	+ also have "\<dots> = sorted_list_of_set (A - {Max A}) @ [Max A]"
	+ using assms by (intro sorted_insort_is_snoc) (auto)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma sorted_list_of_set_image:
	+ assumes "mono_on g A" "inj_on g A"
	+ shows "(sorted_list_of_set (g ` A)) = map g (sorted_list_of_set A)"
	+proof (cases "finite A")
	+ case True
	+ then show ?thesis
	+ using assms proof (induction "sorted_list_of_set A" arbitrary: A)
	+ case Nil
	+ then show ?case
	+ using sorted_list_of_set_eq_Nil_iff by fastforce
	+ next
	+ case (Cons x xs A)
	+ have not_empty_A: "A \<noteq> {}"
	+ using Cons sorted_list_of_set_eq_Nil_iff by auto
	+ have *: "Min (g ` A) = g (Min A)"
	+ proof -
	+ have "g (Min A) \<le> g a" if "a \<in> A" for a
	+ using that Cons Min_in Min_le not_empty_A by (auto intro!: mono_onD[of g])
	+ then show ?thesis
	+ using Cons not_empty_A by (intro Min_eqI) auto
	+ qed
	+ have "g ` A \<noteq> {}" "finite (g ` A)"
	+ using Cons by auto
	+ then have "(sorted_list_of_set (g ` A)) =
	+ Min (g ` A) # sorted_list_of_set ((g ` A) - {Min (g ` A)})"
	+ by (auto simp add: sorted_list_of_set_Min_Cons)
	+ also have "(g ` A) - {Min (g ` A)} = g ` (A - {Min A})"
	+ using Cons Min_in not_empty_A * by (subst inj_on_image_set_diff[of _ A]) auto
	+ also have "sorted_list_of_set (g ` (A - {Min A})) = map g (sorted_list_of_set (A - {Min A}))"
	+ using not_empty_A Cons mono_on_subset[of _ A "A - {Min A}"] inj_on_subset[of _ A "A - {Min A}"]
	+ by (intro Cons) (auto simp add: sorted_list_of_set_Min_Cons)
	+ finally show ?case
	+ using Cons not_empty_A * by (auto simp add: sorted_list_of_set_Min_Cons)
	+ qed
	+next
	+ case False
	+ then show ?thesis
	+ using assms by (simp add: finite_image_iff)
	+qed
	+
	+lemma sorted_list_of_set_length: "length (sorted_list_of_set A) = card A"
	+ using distinct_card sorted_list_of_set[of A] by (cases "finite A") fastforce+
	+
	+lemma sorted_list_of_set_bij_betw:
	+ assumes "finite A"
	+ shows "bij_betw (\<lambda>n. sorted_list_of_set A ! n) {..<card A} A"
	+ by (rule bij_betw_nth) (fastforce simp add: assms sorted_list_of_set_length)+
	+
	+lemma nth_mono_on:
	+ assumes "sorted xs" "distinct xs" "set xs = A"
	+ shows "mono_on (\<lambda>n. xs ! n) {..<card A}"
	+ using assms by (intro mono_onI sorted_nth_mono) (auto simp add: distinct_card)
	+
	+lemma sorted_list_of_set_mono_on:
	+ "finite A \<Longrightarrow> mono_on (\<lambda>n. sorted_list_of_set A ! n) {..<card A}"
	+ by (rule nth_mono_on) (auto)
	+
	+definition bij_mono_map_set_to_nat :: "'a::linorder set \<Rightarrow> 'a \<Rightarrow> nat" where
	+ "bij_mono_map_set_to_nat A =
	+ (\<lambda>x. if x \<in> A then the_inv_into {..<card A} ((!) (sorted_list_of_set A)) x
	+ else card A)"
	+
	+lemma bij_mono_map_set_to_nat:
	+ assumes "finite A"
	+ shows "bij_betw (bij_mono_map_set_to_nat A) A {..<card A}"
	+ "mono_on (bij_mono_map_set_to_nat A) A"
	+ "(bij_mono_map_set_to_nat A) ` A = {..<card A}"
	+proof -
	+ let ?f = "bij_mono_map_set_to_nat A"
	+ have "bij_betw (the_inv_into {..<card A} ((!) (sorted_list_of_set A))) A {..<card A}"
	+ using assms sorted_list_of_set_bij_betw bij_betw_the_inv_into by blast
	+ moreover have "bij_betw (the_inv_into {..<card A} ((!) (sorted_list_of_set A))) A {..<card A}
	+ = bij_betw ?f A {..<card A}"
	+ unfolding bij_mono_map_set_to_nat_def by (rule bij_betw_cong) simp
	+ ultimately show *: "bij_betw (bij_mono_map_set_to_nat A) A {..<card A}"
	+ by blast
	+ have "mono_on (the_inv_into {..<card A} ((!) (sorted_list_of_set A))) A"
	+ using assms sorted_list_of_set_bij_betw
	+ sorted_list_of_set_mono_on by (intro bij_betw_mono_on_the_inv_into) auto
	+ then show "mono_on (bij_mono_map_set_to_nat A) A"
	+ unfolding bij_mono_map_set_to_nat_def using mono_onD by (intro mono_onI) (auto)
	+ show "?f ` A = {..<card A}"
	+ using assms bij_betw_imp_surj_on * by blast
	+qed
	+
	+end
	diff --git a/thys/Skip_Lists/Pi_pmf.thy b/thys/Skip_Lists/Pi_pmf.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Skip_Lists/Pi_pmf.thy
	@@ -0,0 +1,755 @@
	+(*
	+ File: Pi_pmf.thy
	+ Authors: Manuel Eberl, Max W. Haslbeck
	+*)
	+section \<open>Indexed products of PMFs\<close>
	+theory Pi_pmf
	+ imports "HOL-Probability.Probability"
	+begin
	+
	+subsection \<open>Preliminaries\<close>
	+
	+lemma pmf_expectation_eq_infsetsum: "measure_pmf.expectation p f = infsetsum (\<lambda>x. pmf p x * f x) UNIV"
	+ unfolding infsetsum_def measure_pmf_eq_density by (subst integral_density) simp_all
	+
	+lemma measure_pmf_prob_product:
	+ assumes "countable A" "countable B"
	+ shows "measure_pmf.prob (pair_pmf M N) (A \<times> B) = measure_pmf.prob M A * measure_pmf.prob N B"
	+proof -
	+ have "measure_pmf.prob (pair_pmf M N) (A \<times> B) = (\<Sum>\<^sub>a(a, b)\<in>A \<times> B. pmf M a * pmf N b)"
	+ by (auto intro!: infsetsum_cong simp add: measure_pmf_conv_infsetsum pmf_pair)
	+ also have "\<dots> = measure_pmf.prob M A * measure_pmf.prob N B"
	+ using assms by (subst infsetsum_product) (auto simp add: measure_pmf_conv_infsetsum)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+
	+subsection \<open>Definition\<close>
	+
	+text \<open>
	+ In analogy to @{const PiM}, we define an indexed product of PMFs. In the literature, this
	+ is typically called taking a vector of independent random variables. Note that the components
	+ do not have to be identically distributed.
	+
	+ The operation takes an explicit index set \<^term>\<open>A :: 'a set\<close> and a function \<^term>\<open>f :: 'a \<Rightarrow> 'b pmf\<close>
	+ that maps each element from \<^term>\<open>A\<close> to a PMF and defines the product measure
	+ $\bigotimes_{i\in A} f(i)$ , which is represented as a \<^typ>\<open>('a \<Rightarrow> 'b) pmf\<close>.
	+
	+ Note that unlike @{const PiM}, this only works for \<^emph>\<open>finite\<close> index sets. It could
	+ be extended to countable sets and beyond, but the construction becomes somewhat more involved.
	+\<close>
	+definition Pi_pmf :: "'a set \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b pmf) \<Rightarrow> ('a \<Rightarrow> 'b) pmf" where
	+ "Pi_pmf A dflt p =
	+ embed_pmf (\<lambda>f. if (\<forall>x. x \<notin> A \<longrightarrow> f x = dflt) then \<Prod>x\<in>A. pmf (p x) (f x) else 0)"
	+
	+text \<open>
	+ A technical subtlety that needs to be addressed is this: Intuitively, the functions in the
	+ support of a product distribution have domain \<open>A\<close>. However, since HOL is a total logic, these
	+ functions must still return \<^emph>\<open>some\<close> value for inputs outside \<open>A\<close>. The product measure
	+ @{const PiM} simply lets these functions return @{const undefined} in these cases. We chose a
	+ different solution here, which is to supply a default value \<^term>\<open>dflt :: 'b\<close> that is returned
	+ in these cases.
	+
	+ As one possible application, one could model the result of \<open>n\<close> different independent coin
	+ tosses as @{term "Pi_pmf {0..<n} False (\<lambda>_. bernoulli_pmf (1 / 2))"}. This returns a function
	+ of type \<^typ>\<open>nat \<Rightarrow> bool\<close> that maps every natural number below \<open>n\<close> to the result of the
	+ corresponding coin toss, and every other natural number to \<^term>\<open>False\<close>.
	+\<close>
	+
	+lemma pmf_Pi:
	+ assumes A: "finite A"
	+ shows "pmf (Pi_pmf A dflt p) f =
	+ (if (\<forall>x. x \<notin> A \<longrightarrow> f x = dflt) then \<Prod>x\<in>A. pmf (p x) (f x) else 0)"
	+ unfolding Pi_pmf_def
	+proof (rule pmf_embed_pmf, goal_cases)
	+ case 2
	+ define S where "S = {f. \<forall>x. x \<notin> A \<longrightarrow> f x = dflt}"
	+ define B where "B = (\<lambda>x. set_pmf (p x))"
	+
	+ have neutral_left: "(\<Prod>xa\<in>A. pmf (p xa) (f xa)) = 0"
	+ if "f \<in> PiE A B - (\<lambda>f. restrict f A) ` S" for f
	+ proof -
	+ have "restrict (\<lambda>x. if x \<in> A then f x else dflt) A \<in> (\<lambda>f. restrict f A) ` S"
	+ by (intro imageI) (auto simp: S_def)
	+ also have "restrict (\<lambda>x. if x \<in> A then f x else dflt) A = f"
	+ using that by (auto simp: PiE_def Pi_def extensional_def fun_eq_iff)
	+ finally show ?thesis using that by blast
	+ qed
	+ have neutral_right: "(\<Prod>xa\<in>A. pmf (p xa) (f xa)) = 0"
	+ if "f \<in> (\<lambda>f. restrict f A) ` S - PiE A B" for f
	+ proof -
	+ from that obtain f' where f': "f = restrict f' A" "f' \<in> S" by auto
	+ moreover from this and that have "restrict f' A \<notin> PiE A B" by simp
	+ then obtain x where "x \<in> A" "pmf (p x) (f' x) = 0" by (auto simp: B_def set_pmf_eq)
	+ with f' and A show ?thesis by auto
	+ qed
	+
	+ have "(\<lambda>f. \<Prod>x\<in>A. pmf (p x) (f x)) abs_summable_on PiE A B"
	+ by (intro abs_summable_on_prod_PiE A) (auto simp: B_def)
	+ also have "?this \<longleftrightarrow> (\<lambda>f. \<Prod>x\<in>A. pmf (p x) (f x)) abs_summable_on (\<lambda>f. restrict f A) ` S"
	+ by (intro abs_summable_on_cong_neutral neutral_left neutral_right) auto
	+ also have "\<dots> \<longleftrightarrow> (\<lambda>f. \<Prod>x\<in>A. pmf (p x) (restrict f A x)) abs_summable_on S"
	+ by (rule abs_summable_on_reindex_iff [symmetric]) (force simp: inj_on_def fun_eq_iff S_def)
	+ also have "\<dots> \<longleftrightarrow> (\<lambda>f. if \<forall>x. x \<notin> A \<longrightarrow> f x = dflt then \<Prod>x\<in>A. pmf (p x) (f x) else 0)
	+ abs_summable_on UNIV"
	+ by (intro abs_summable_on_cong_neutral) (auto simp: S_def)
	+ finally have summable: \<dots> .
	+
	+ have "1 = (\<Prod>x\<in>A. 1::real)" by simp
	+ also have "(\<Prod>x\<in>A. 1) = (\<Prod>x\<in>A. \<Sum>\<^sub>ay\<in>B x. pmf (p x) y)"
	+ unfolding B_def by (subst infsetsum_pmf_eq_1) auto
	+ also have "(\<Prod>x\<in>A. \<Sum>\<^sub>ay\<in>B x. pmf (p x) y) = (\<Sum>\<^sub>af\<in>Pi\<^sub>E A B. \<Prod>x\<in>A. pmf (p x) (f x))"
	+ by (intro infsetsum_prod_PiE [symmetric] A) (auto simp: B_def)
	+ also have "\<dots> = (\<Sum>\<^sub>af\<in>(\<lambda>f. restrict f A) ` S. \<Prod>x\<in>A. pmf (p x) (f x))" using A
	+ by (intro infsetsum_cong_neutral neutral_left neutral_right refl)
	+ also have "\<dots> = (\<Sum>\<^sub>af\<in>S. \<Prod>x\<in>A. pmf (p x) (restrict f A x))"
	+ by (rule infsetsum_reindex) (force simp: inj_on_def fun_eq_iff S_def)
	+ also have "\<dots> = (\<Sum>\<^sub>af\<in>S. \<Prod>x\<in>A. pmf (p x) (f x))"
	+ by (intro infsetsum_cong) (auto simp: S_def)
	+ also have "\<dots> = (\<Sum>\<^sub>af. if \<forall>x. x \<notin> A \<longrightarrow> f x = dflt then \<Prod>x\<in>A. pmf (p x) (f x) else 0)"
	+ by (intro infsetsum_cong_neutral) (auto simp: S_def)
	+ also have "ennreal \<dots> = (\<integral>\<^sup>+f. ennreal (if \<forall>x. x \<notin> A \<longrightarrow> f x = dflt
	+ then \<Prod>x\<in>A. pmf (p x) (f x) else 0) \<partial>count_space UNIV)"
	+ by (intro nn_integral_conv_infsetsum [symmetric] summable) (auto simp: prod_nonneg)
	+ finally show ?case by simp
	+qed (auto simp: prod_nonneg)
	+
	+lemma pmf_Pi':
	+ assumes "finite A" "\<And>x. x \<notin> A \<Longrightarrow> f x = dflt"
	+ shows "pmf (Pi_pmf A dflt p) f = (\<Prod>x\<in>A. pmf (p x) (f x))"
	+ using assms by (subst pmf_Pi) auto
	+
	+lemma pmf_Pi_outside:
	+ assumes "finite A" "\<exists>x. x \<notin> A \<and> f x \<noteq> dflt"
	+ shows "pmf (Pi_pmf A dflt p) f = 0"
	+ using assms by (subst pmf_Pi) auto
	+
	+lemma pmf_Pi_empty [simp]: "Pi_pmf {} dflt p = return_pmf (\<lambda>_. dflt)"
	+ by (intro pmf_eqI, subst pmf_Pi) (auto simp: indicator_def)
	+
	+lemma set_Pi_pmf_subset: "finite A \<Longrightarrow> set_pmf (Pi_pmf A dflt p) \<subseteq> {f. \<forall>x. x \<notin> A \<longrightarrow> f x = dflt}"
	+ by (auto simp: set_pmf_eq pmf_Pi)
	+
	+lemma Pi_pmf_cong [cong]:
	+ assumes "A = A'" "dflt = dflt'" "\<And>x. x \<in> A \<Longrightarrow> f x = f' x"
	+ shows "Pi_pmf A dflt f = Pi_pmf A' dflt' f'"
	+proof -
	+ have "(\<lambda>g. \<Prod>x\<in>A. pmf (f x) (g x)) = (\<lambda>g. \<Prod>x\<in>A. pmf (f' x) (g x))"
	+ by (intro ext prod.cong) (auto simp: assms)
	+ with assms show ?thesis by (simp add: Pi_pmf_def cong: if_cong)
	+qed
	+
	+
	+subsection \<open>Dependent product sets with a default\<close>
	+
	+text \<open>
	+ The following describes a dependent product of sets where the functions are required to return
	+ the default value \<^term>\<open>dflt\<close> outside their domain, in analogy to @{const PiE}, which uses
	+ @{const undefined}.
	+\<close>
	+definition PiE_dflt
	+ where "PiE_dflt A dflt B = {f. \<forall>x. (x \<in> A \<longrightarrow> f x \<in> B x) \<and> (x \<notin> A \<longrightarrow> f x = dflt)}"
	+
	+lemma restrict_PiE_dflt: "(\<lambda>h. restrict h A) ` PiE_dflt A dflt B = PiE A B"
	+proof (intro equalityI subsetI)
	+ fix h assume "h \<in> (\<lambda>h. restrict h A) ` PiE_dflt A dflt B"
	+ thus "h \<in> PiE A B"
	+ by (auto simp: PiE_dflt_def)
	+next
	+ fix h assume h: "h \<in> PiE A B"
	+ hence "restrict (\<lambda>x. if x \<in> A then h x else dflt) A \<in> (\<lambda>h. restrict h A) ` PiE_dflt A dflt B"
	+ by (intro imageI) (auto simp: PiE_def extensional_def PiE_dflt_def)
	+ also have "restrict (\<lambda>x. if x \<in> A then h x else dflt) A = h"
	+ using h by (auto simp: fun_eq_iff)
	+ finally show "h \<in> (\<lambda>h. restrict h A) ` PiE_dflt A dflt B" .
	+qed
	+
	+lemma dflt_image_PiE: "(\<lambda>h x. if x \<in> A then h x else dflt) ` PiE A B = PiE_dflt A dflt B"
	+ (is "?f ` ?X = ?Y")
	+proof (intro equalityI subsetI)
	+ fix h assume "h \<in> ?f ` ?X"
	+ thus "h \<in> ?Y"
	+ by (auto simp: PiE_dflt_def PiE_def)
	+next
	+ fix h assume h: "h \<in> ?Y"
	+ hence "?f (restrict h A) \<in> ?f ` ?X"
	+ by (intro imageI) (auto simp: PiE_def extensional_def PiE_dflt_def)
	+ also have "?f (restrict h A) = h"
	+ using h by (auto simp: fun_eq_iff PiE_dflt_def)
	+ finally show "h \<in> ?f ` ?X" .
	+qed
	+
	+lemma finite_PiE_dflt [intro]:
	+ assumes "finite A" "\<And>x. x \<in> A \<Longrightarrow> finite (B x)"
	+ shows "finite (PiE_dflt A d B)"
	+proof -
	+ have "PiE_dflt A d B = (\<lambda>f x. if x \<in> A then f x else d) ` PiE A B"
	+ by (rule dflt_image_PiE [symmetric])
	+ also have "finite \<dots>"
	+ by (intro finite_imageI finite_PiE assms)
	+ finally show ?thesis .
	+qed
	+
	+lemma card_PiE_dflt:
	+ assumes "finite A" "\<And>x. x \<in> A \<Longrightarrow> finite (B x)"
	+ shows "card (PiE_dflt A d B) = (\<Prod>x\<in>A. card (B x))"
	+proof -
	+ from assms have "(\<Prod>x\<in>A. card (B x)) = card (PiE A B)"
	+ by (intro card_PiE [symmetric]) auto
	+ also have "PiE A B = (\<lambda>f. restrict f A) ` PiE_dflt A d B"
	+ by (rule restrict_PiE_dflt [symmetric])
	+ also have "card \<dots> = card (PiE_dflt A d B)"
	+ by (intro card_image) (force simp: inj_on_def restrict_def fun_eq_iff PiE_dflt_def)
	+ finally show ?thesis ..
	+qed
	+
	+lemma PiE_dflt_empty_iff [simp]: "PiE_dflt A dflt B = {} \<longleftrightarrow> (\<exists>x\<in>A. B x = {})"
	+ by (simp add: dflt_image_PiE [symmetric] PiE_eq_empty_iff)
	+
	+text \<open>
	+ The probability of an independent combination of events is precisely the product
	+ of the probabilities of each individual event.
	+\<close>
	+lemma measure_Pi_pmf_PiE_dflt:
	+ assumes [simp]: "finite A"
	+ shows "measure_pmf.prob (Pi_pmf A dflt p) (PiE_dflt A dflt B) =
	+ (\<Prod>x\<in>A. measure_pmf.prob (p x) (B x))"
	+proof -
	+ define B' where "B' = (\<lambda>x. B x \<inter> set_pmf (p x))"
	+ have "measure_pmf.prob (Pi_pmf A dflt p) (PiE_dflt A dflt B) =
	+ (\<Sum>\<^sub>ah\<in>PiE_dflt A dflt B. pmf (Pi_pmf A dflt p) h)"
	+ by (rule measure_pmf_conv_infsetsum)
	+ also have "\<dots> = (\<Sum>\<^sub>ah\<in>PiE_dflt A dflt B. \<Prod>x\<in>A. pmf (p x) (h x))"
	+ by (intro infsetsum_cong, subst pmf_Pi') (auto simp: PiE_dflt_def)
	+ also have "\<dots> = (\<Sum>\<^sub>ah\<in>(\<lambda>h. restrict h A) ` PiE_dflt A dflt B. \<Prod>x\<in>A. pmf (p x) (h x))"
	+ by (subst infsetsum_reindex) (force simp: inj_on_def PiE_dflt_def fun_eq_iff)+
	+ also have "(\<lambda>h. restrict h A) ` PiE_dflt A dflt B = PiE A B"
	+ by (rule restrict_PiE_dflt)
	+ also have "(\<Sum>\<^sub>ah\<in>PiE A B. \<Prod>x\<in>A. pmf (p x) (h x)) = (\<Sum>\<^sub>ah\<in>PiE A B'. \<Prod>x\<in>A. pmf (p x) (h x))"
	+ by (intro infsetsum_cong_neutral) (auto simp: B'_def set_pmf_eq)
	+ also have "(\<Sum>\<^sub>ah\<in>PiE A B'. \<Prod>x\<in>A. pmf (p x) (h x)) = (\<Prod>x\<in>A. infsetsum (pmf (p x)) (B' x))"
	+ by (intro infsetsum_prod_PiE) (auto simp: B'_def)
	+ also have "\<dots> = (\<Prod>x\<in>A. infsetsum (pmf (p x)) (B x))"
	+ by (intro prod.cong infsetsum_cong_neutral) (auto simp: B'_def set_pmf_eq)
	+ also have "\<dots> = (\<Prod>x\<in>A. measure_pmf.prob (p x) (B x))"
	+ by (subst measure_pmf_conv_infsetsum) (rule refl)
	+ finally show ?thesis .
	+qed
	+
	+lemma set_Pi_pmf_subset':
	+ assumes "finite A"
	+ shows "set_pmf (Pi_pmf A dflt p) \<subseteq> PiE_dflt A dflt (set_pmf \<circ> p)"
	+ using assms by (auto simp: set_pmf_eq pmf_Pi PiE_dflt_def)
	+
	+lemma Pi_pmf_return_pmf [simp]:
	+ assumes "finite A"
	+ shows "Pi_pmf A dflt (\<lambda>x. return_pmf (f x)) = return_pmf (\<lambda>x. if x \<in> A then f x else dflt)"
	+proof -
	+ have "set_pmf (Pi_pmf A dflt (\<lambda>x. return_pmf (f x))) \<subseteq>
	+ PiE_dflt A dflt (set_pmf \<circ> (\<lambda>x. return_pmf (f x)))"
	+ by (intro set_Pi_pmf_subset' assms)
	+ also have "\<dots> \<subseteq> {\<lambda>x. if x \<in> A then f x else dflt}"
	+ by (auto simp: PiE_dflt_def)
	+ finally show ?thesis
	+ by (simp add: set_pmf_subset_singleton)
	+qed
	+
	+lemma Pi_pmf_return_pmf' [simp]:
	+ assumes "finite A"
	+ shows "Pi_pmf A dflt (\<lambda>_. return_pmf dflt) = return_pmf (\<lambda>_. dflt)"
	+ using assms by simp
	+
	+lemma measure_Pi_pmf_Pi:
	+ fixes t::nat
	+ assumes [simp]: "finite A"
	+ shows "measure_pmf.prob (Pi_pmf A dflt p) (Pi A B) =
	+ (\<Prod>x\<in>A. measure_pmf.prob (p x) (B x))" (is "?lhs = ?rhs")
	+proof -
	+ have "?lhs = measure_pmf.prob (Pi_pmf A dflt p) (PiE_dflt A dflt B)"
	+ by (intro measure_prob_cong_0)
	+ (auto simp: PiE_dflt_def PiE_def intro!: pmf_Pi_outside)+
	+ also have "\<dots> = ?rhs"
	+ using assms by (simp add: measure_Pi_pmf_PiE_dflt)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+
	+subsection \<open>Common PMF operations on products\<close>
	+
	+text \<open>
	+ @{const Pi_pmf} distributes over the `bind' operation in the Giry monad:
	+\<close>
	+lemma Pi_pmf_bind:
	+ assumes "finite A"
	+ shows "Pi_pmf A d (\<lambda>x. bind_pmf (p x) (q x)) =
	+ do {f \<leftarrow> Pi_pmf A d' p; Pi_pmf A d (\<lambda>x. q x (f x))}" (is "?lhs = ?rhs")
	+proof (rule pmf_eqI, goal_cases)
	+ case (1 f)
	+ show ?case
	+ proof (cases "\<exists>x\<in>-A. f x \<noteq> d")
	+ case False
	+ define B where "B = (\<lambda>x. set_pmf (p x))"
	+ have [simp]: "countable (B x)" for x by (auto simp: B_def)
	+
	+ {
	+ fix x :: 'a
	+ have "(\<lambda>a. pmf (p x) a * 1) abs_summable_on B x"
	+ by (simp add: pmf_abs_summable)
	+ moreover have "norm (pmf (p x) a * 1) \<ge> norm (pmf (p x) a * pmf (q x a) (f x))" for a
	+ unfolding norm_mult by (intro mult_left_mono) (auto simp: pmf_le_1)
	+ ultimately have "(\<lambda>a. pmf (p x) a * pmf (q x a) (f x)) abs_summable_on B x"
	+ by (rule abs_summable_on_comparison_test)
	+ } note summable = this
	+
	+ have "pmf ?rhs f = (\<Sum>\<^sub>ag. pmf (Pi_pmf A d' p) g * (\<Prod>x\<in>A. pmf (q x (g x)) (f x)))"
	+ by (subst pmf_bind, subst pmf_Pi')
	+ (insert assms False, simp_all add: pmf_expectation_eq_infsetsum)
	+ also have "\<dots> = (\<Sum>\<^sub>ag\<in>PiE_dflt A d' B.
	+ pmf (Pi_pmf A d' p) g * (\<Prod>x\<in>A. pmf (q x (g x)) (f x)))" unfolding B_def
	+ using assms by (intro infsetsum_cong_neutral) (auto simp: pmf_Pi PiE_dflt_def set_pmf_eq)
	+ also have "\<dots> = (\<Sum>\<^sub>ag\<in>PiE_dflt A d' B.
	+ (\<Prod>x\<in>A. pmf (p x) (g x) * pmf (q x (g x)) (f x)))"
	+ using assms by (intro infsetsum_cong) (auto simp: pmf_Pi PiE_dflt_def prod.distrib)
	+ also have "\<dots> = (\<Sum>\<^sub>ag\<in>(\<lambda>g. restrict g A) ` PiE_dflt A d' B.
	+ (\<Prod>x\<in>A. pmf (p x) (g x) * pmf (q x (g x)) (f x)))"
	+ by (subst infsetsum_reindex) (force simp: PiE_dflt_def inj_on_def fun_eq_iff)+
	+ also have "(\<lambda>g. restrict g A) ` PiE_dflt A d' B = PiE A B"
	+ by (rule restrict_PiE_dflt)
	+ also have "(\<Sum>\<^sub>ag\<in>\<dots>. (\<Prod>x\<in>A. pmf (p x) (g x) * pmf (q x (g x)) (f x))) =
	+ (\<Prod>x\<in>A. \<Sum>\<^sub>aa\<in>B x. pmf (p x) a * pmf (q x a) (f x))"
	+ using assms summable by (subst infsetsum_prod_PiE) simp_all
	+ also have "\<dots> = (\<Prod>x\<in>A. \<Sum>\<^sub>aa. pmf (p x) a * pmf (q x a) (f x))"
	+ by (intro prod.cong infsetsum_cong_neutral) (auto simp: B_def set_pmf_eq)
	+ also have "\<dots> = pmf ?lhs f"
	+ using False assms by (subst pmf_Pi') (simp_all add: pmf_bind pmf_expectation_eq_infsetsum)
	+ finally show ?thesis ..
	+ next
	+ case True
	+ have "pmf ?rhs f =
	+ measure_pmf.expectation (Pi_pmf A d' p) (\<lambda>x. pmf (Pi_pmf A d (\<lambda>xa. q xa (x xa))) f)"
	+ using assms by (simp add: pmf_bind)
	+ also have "\<dots> = measure_pmf.expectation (Pi_pmf A d' p) (\<lambda>x. 0)"
	+ using assms True by (intro Bochner_Integration.integral_cong pmf_Pi_outside) auto
	+ also have "\<dots> = pmf ?lhs f"
	+ using assms True by (subst pmf_Pi_outside) auto
	+ finally show ?thesis ..
	+ qed
	+qed
	+
	+text \<open>
	+ Analogously any componentwise mapping can be pulled outside the product:
	+\<close>
	+lemma Pi_pmf_map:
	+ assumes [simp]: "finite A" and "f dflt = dflt'"
	+ shows "Pi_pmf A dflt' (\<lambda>x. map_pmf f (g x)) = map_pmf (\<lambda>h. f \<circ> h) (Pi_pmf A dflt g)"
	+proof -
	+ have "Pi_pmf A dflt' (\<lambda>x. map_pmf f (g x)) =
	+ Pi_pmf A dflt' (\<lambda>x. g x \<bind> (\<lambda>x. return_pmf (f x)))"
	+ using assms by (simp add: map_pmf_def Pi_pmf_bind)
	+ also have "\<dots> = Pi_pmf A dflt g \<bind> (\<lambda>h. return_pmf (\<lambda>x. if x \<in> A then f (h x) else dflt'))"
	+ by (subst Pi_pmf_bind[where d' = dflt]) auto
	+ also have "\<dots> = map_pmf (\<lambda>h. f \<circ> h) (Pi_pmf A dflt g)"
	+ unfolding map_pmf_def using set_Pi_pmf_subset'[of A dflt g]
	+ by (intro bind_pmf_cong refl arg_cong[of _ _ return_pmf])
	+ (auto dest: simp: fun_eq_iff PiE_dflt_def assms(2))
	+ finally show ?thesis .
	+qed
	+
	+text \<open>
	+ We can exchange the default value in a product of PMFs like this:
	+\<close>
	+lemma Pi_pmf_default_swap:
	+ assumes "finite A"
	+ shows "map_pmf (\<lambda>f x. if x \<in> A then f x else dflt') (Pi_pmf A dflt p) =
	+ Pi_pmf A dflt' p" (is "?lhs = ?rhs")
	+proof (rule pmf_eqI, goal_cases)
	+ case (1 f)
	+ let ?B = "(\<lambda>f x. if x \<in> A then f x else dflt') -` {f} \<inter> PiE_dflt A dflt (\<lambda>_. UNIV)"
	+ show ?case
	+ proof (cases "\<exists>x\<in>-A. f x \<noteq> dflt'")
	+ case False
	+ let ?f' = "\<lambda>x. if x \<in> A then f x else dflt"
	+ from False have "pmf ?lhs f = measure_pmf.prob (Pi_pmf A dflt p) ?B"
	+ using assms unfolding pmf_map
	+ by (intro measure_prob_cong_0) (auto simp: PiE_dflt_def pmf_Pi_outside)
	+ also from False have "?B = {?f'}"
	+ by (auto simp: fun_eq_iff PiE_dflt_def)
	+ also have "measure_pmf.prob (Pi_pmf A dflt p) {?f'} = pmf (Pi_pmf A dflt p) ?f'"
	+ by (simp add: measure_pmf_single)
	+ also have "\<dots> = pmf ?rhs f"
	+ using False assms by (subst (1 2) pmf_Pi) auto
	+ finally show ?thesis .
	+ next
	+ case True
	+ have "pmf ?lhs f = measure_pmf.prob (Pi_pmf A dflt p) ?B"
	+ using assms unfolding pmf_map
	+ by (intro measure_prob_cong_0) (auto simp: PiE_dflt_def pmf_Pi_outside)
	+ also from True have "?B = {}" by auto
	+ also have "measure_pmf.prob (Pi_pmf A dflt p) \<dots> = 0"
	+ by simp
	+ also have "0 = pmf ?rhs f"
	+ using True assms by (intro pmf_Pi_outside [symmetric]) auto
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+text \<open>
	+ The following rule allows reindexing the product:
	+\<close>
	+lemma Pi_pmf_bij_betw:
	+ assumes "finite A" "bij_betw h A B" "\<And>x. x \<notin> A \<Longrightarrow> h x \<notin> B"
	+ shows "Pi_pmf A dflt (\<lambda>_. f) = map_pmf (\<lambda>g. g \<circ> h) (Pi_pmf B dflt (\<lambda>_. f))"
	+ (is "?lhs = ?rhs")
	+proof -
	+ have B: "finite B"
	+ using assms bij_betw_finite by auto
	+ have "pmf ?lhs g = pmf ?rhs g" for g
	+ proof (cases "\<forall>a. a \<notin> A \<longrightarrow> g a = dflt")
	+ case True
	+ define h' where "h' = the_inv_into A h"
	+ have h': "h' (h x) = x" if "x \<in> A" for x
	+ unfolding h'_def using that assms by (auto simp add: bij_betw_def the_inv_into_f_f)
	+ have h: "h (h' x) = x" if "x \<in> B" for x
	+ unfolding h'_def using that assms f_the_inv_into_f_bij_betw by fastforce
	+ have "pmf ?rhs g = measure_pmf.prob (Pi_pmf B dflt (\<lambda>_. f)) ((\<lambda>g. g \<circ> h) -` {g})"
	+ unfolding pmf_map by simp
	+ also have "\<dots> = measure_pmf.prob (Pi_pmf B dflt (\<lambda>_. f))
	+ (((\<lambda>g. g \<circ> h) -` {g}) \<inter> PiE_dflt B dflt (\<lambda>_. UNIV))"
	+ using B by (intro measure_prob_cong_0) (auto simp: PiE_dflt_def pmf_Pi_outside)
	+ also have "\<dots> = pmf (Pi_pmf B dflt (\<lambda>_. f)) (\<lambda>x. if x \<in> B then g (h' x) else dflt)"
	+ proof -
	+ have "(if h x \<in> B then g (h' (h x)) else dflt) = g x" for x
	+ using h' assms True by (cases "x \<in> A") (auto simp add: bij_betwE)
	+ then have "(\<lambda>g. g \<circ> h) -` {g} \<inter> PiE_dflt B dflt (\<lambda>_. UNIV) =
	+ {(\<lambda>x. if x \<in> B then g (h' x) else dflt)}"
	+ using assms h' h True unfolding PiE_dflt_def by auto
	+ then show ?thesis
	+ by (simp add: measure_pmf_single)
	+ qed
	+ also have "\<dots> = pmf (Pi_pmf A dflt (\<lambda>_. f)) g"
	+ using B assms True h'_def
	+ by (auto simp add: pmf_Pi intro!: prod.reindex_bij_betw bij_betw_the_inv_into)
	+ finally show ?thesis
	+ by simp
	+ next
	+ case False
	+ have "pmf ?rhs g = infsetsum (pmf (Pi_pmf B dflt (\<lambda>_. f))) ((\<lambda>g. g \<circ> h) -` {g})"
	+ using assms by (auto simp add: measure_pmf_conv_infsetsum pmf_map)
	+ also have "\<dots> = infsetsum (\<lambda>_. 0) ((\<lambda>g x. g (h x)) -` {g})"
	+ using B False assms by (intro infsetsum_cong pmf_Pi_outside) fastforce+
	+ also have "\<dots> = 0"
	+ by simp
	+ finally show ?thesis
	+ using assms False by (auto simp add: pmf_Pi pmf_map)
	+ qed
	+ then show ?thesis
	+ by (rule pmf_eqI)
	+qed
	+
	+text \<open>
	+ A product of uniform random choices is again a uniform distribution.
	+\<close>
	+lemma Pi_pmf_of_set:
	+ assumes "finite A" "\<And>x. x \<in> A \<Longrightarrow> finite (B x)" "\<And>x. x \<in> A \<Longrightarrow> B x \<noteq> {}"
	+ shows "Pi_pmf A d (\<lambda>x. pmf_of_set (B x)) = pmf_of_set (PiE_dflt A d B)" (is "?lhs = ?rhs")
	+proof (rule pmf_eqI, goal_cases)
	+ case (1 f)
	+ show ?case
	+ proof (cases "\<exists>x. x \<notin> A \<and> f x \<noteq> d")
	+ case True
	+ hence "pmf ?lhs f = 0"
	+ using assms by (intro pmf_Pi_outside) (auto simp: PiE_dflt_def)
	+ also from True have "f \<notin> PiE_dflt A d B"
	+ by (auto simp: PiE_dflt_def)
	+ hence "0 = pmf ?rhs f"
	+ using assms by (subst pmf_of_set) auto
	+ finally show ?thesis .
	+ next
	+ case False
	+ hence "pmf ?lhs f = (\<Prod>x\<in>A. pmf (pmf_of_set (B x)) (f x))"
	+ using assms by (subst pmf_Pi') auto
	+ also have "\<dots> = (\<Prod>x\<in>A. indicator (B x) (f x) / real (card (B x)))"
	+ by (intro prod.cong refl, subst pmf_of_set) (use assms False in auto)
	+ also have "\<dots> = (\<Prod>x\<in>A. indicator (B x) (f x)) / real (\<Prod>x\<in>A. card (B x))"
	+ by (subst prod_dividef) simp_all
	+ also have "(\<Prod>x\<in>A. indicator (B x) (f x) :: real) = indicator (PiE_dflt A d B) f"
	+ using assms False by (auto simp: indicator_def PiE_dflt_def)
	+ also have "(\<Prod>x\<in>A. card (B x)) = card (PiE_dflt A d B)"
	+ using assms by (intro card_PiE_dflt [symmetric]) auto
	+ also have "indicator (PiE_dflt A d B) f / \<dots> = pmf ?rhs f"
	+ using assms by (intro pmf_of_set [symmetric]) auto
	+ finally show ?thesis .
	+ qed
	+qed
	+
	+
	+subsection \<open>Merging and splitting PMF products\<close>
	+
	+text \<open>
	+ The following lemma shows that we can add a single PMF to a product:
	+\<close>
	+lemma Pi_pmf_insert:
	+ assumes "finite A" "x \<notin> A"
	+ shows "Pi_pmf (insert x A) dflt p = map_pmf (\<lambda>(y,f). f(x:=y)) (pair_pmf (p x) (Pi_pmf A dflt p))"
	+proof (intro pmf_eqI)
	+ fix f
	+ let ?M = "pair_pmf (p x) (Pi_pmf A dflt p)"
	+ have "pmf (map_pmf (\<lambda>(y, f). f(x := y)) ?M) f =
	+ measure_pmf.prob ?M ((\<lambda>(y, f). f(x := y)) -` {f})"
	+ by (subst pmf_map) auto
	+ also have "((\<lambda>(y, f). f(x := y)) -` {f}) = (\<Union>y'. {(f x, f(x := y'))})"
	+ by (auto simp: fun_upd_def fun_eq_iff)
	+ also have "measure_pmf.prob ?M \<dots> = measure_pmf.prob ?M {(f x, f(x := dflt))}"
	+ using assms by (intro measure_prob_cong_0) (auto simp: pmf_pair pmf_Pi split: if_splits)
	+ also have "\<dots> = pmf (p x) (f x) * pmf (Pi_pmf A dflt p) (f(x := dflt))"
	+ by (simp add: measure_pmf_single pmf_pair pmf_Pi)
	+ also have "\<dots> = pmf (Pi_pmf (insert x A) dflt p) f"
	+ proof (cases "\<forall>y. y \<notin> insert x A \<longrightarrow> f y = dflt")
	+ case True
	+ with assms have "pmf (p x) (f x) * pmf (Pi_pmf A dflt p) (f(x := dflt)) =
	+ pmf (p x) (f x) * (\<Prod>xa\<in>A. pmf (p xa) ((f(x := dflt)) xa))"
	+ by (subst pmf_Pi') auto
	+ also have "(\<Prod>xa\<in>A. pmf (p xa) ((f(x := dflt)) xa)) = (\<Prod>xa\<in>A. pmf (p xa) (f xa))"
	+ using assms by (intro prod.cong) auto
	+ also have "pmf (p x) (f x) * \<dots> = pmf (Pi_pmf (insert x A) dflt p) f"
	+ using assms True by (subst pmf_Pi') auto
	+ finally show ?thesis .
	+ qed (insert assms, auto simp: pmf_Pi)
	+ finally show "\<dots> = pmf (map_pmf (\<lambda>(y, f). f(x := y)) ?M) f" ..
	+qed
	+
	+lemma Pi_pmf_insert':
	+ assumes "finite A" "x \<notin> A"
	+ shows "Pi_pmf (insert x A) dflt p =
	+ do {y \<leftarrow> p x; f \<leftarrow> Pi_pmf A dflt p; return_pmf (f(x := y))}"
	+ using assms
	+ by (subst Pi_pmf_insert)
	+ (auto simp add: map_pmf_def pair_pmf_def case_prod_beta' bind_return_pmf bind_assoc_pmf)
	+
	+lemma Pi_pmf_singleton:
	+ "Pi_pmf {x} dflt p = map_pmf (\<lambda>a b. if b = x then a else dflt) (p x)"
	+proof -
	+ have "Pi_pmf {x} dflt p = map_pmf (fun_upd (\<lambda>_. dflt) x) (p x)"
	+ by (subst Pi_pmf_insert) (simp_all add: pair_return_pmf2 pmf.map_comp o_def)
	+ also have "fun_upd (\<lambda>_. dflt) x = (\<lambda>z y. if y = x then z else dflt)"
	+ by (simp add: fun_upd_def fun_eq_iff)
	+ finally show ?thesis .
	+qed
	+
	+text \<open>
	+ Projecting a product of PMFs onto a component yields the expected result:
	+\<close>
	+lemma Pi_pmf_component:
	+ assumes "finite A"
	+ shows "map_pmf (\<lambda>f. f x) (Pi_pmf A dflt p) = (if x \<in> A then p x else return_pmf dflt)"
	+proof (cases "x \<in> A")
	+ case True
	+ define A' where "A' = A - {x}"
	+ from assms and True have A': "A = insert x A'"
	+ by (auto simp: A'_def)
	+ from assms have "map_pmf (\<lambda>f. f x) (Pi_pmf A dflt p) = p x" unfolding A'
	+ by (subst Pi_pmf_insert)
	+ (auto simp: A'_def pmf.map_comp o_def case_prod_unfold map_fst_pair_pmf)
	+ with True show ?thesis by simp
	+next
	+ case False
	+ have "map_pmf (\<lambda>f. f x) (Pi_pmf A dflt p) = map_pmf (\<lambda>_. dflt) (Pi_pmf A dflt p)"
	+ using assms False set_Pi_pmf_subset[of A dflt p]
	+ by (intro pmf.map_cong refl) (auto simp: set_pmf_eq pmf_Pi_outside)
	+ with False show ?thesis by simp
	+qed
	+
	+text \<open>
	+ We can take merge two PMF products on disjoint sets like this:
	+\<close>
	+lemma Pi_pmf_union:
	+ assumes "finite A" "finite B" "A \<inter> B = {}"
	+ shows "Pi_pmf (A \<union> B) dflt p =
	+ map_pmf (\<lambda>(f,g) x. if x \<in> A then f x else g x)
	+ (pair_pmf (Pi_pmf A dflt p) (Pi_pmf B dflt p))" (is "_ = map_pmf (?h A) (?q A)")
	+ using assms(1,3)
	+proof (induction rule: finite_induct)
	+ case (insert x A)
	+ have "map_pmf (?h (insert x A)) (?q (insert x A)) =
	+ do {v \<leftarrow> p x; (f, g) \<leftarrow> pair_pmf (Pi_pmf A dflt p) (Pi_pmf B dflt p);
	+ return_pmf (\<lambda>y. if y \<in> insert x A then (f(x := v)) y else g y)}"
	+ by (subst Pi_pmf_insert)
	+ (insert insert.hyps insert.prems,
	+ simp_all add: pair_pmf_def map_bind_pmf bind_map_pmf bind_assoc_pmf bind_return_pmf)
	+ also have "\<dots> = do {v \<leftarrow> p x; (f, g) \<leftarrow> ?q A; return_pmf ((?h A (f,g))(x := v))}"
	+ by (intro bind_pmf_cong refl) (auto simp: fun_eq_iff)
	+ also have "\<dots> = do {v \<leftarrow> p x; f \<leftarrow> map_pmf (?h A) (?q A); return_pmf (f(x := v))}"
	+ by (simp add: bind_map_pmf map_bind_pmf case_prod_unfold cong: if_cong)
	+ also have "\<dots> = do {v \<leftarrow> p x; f \<leftarrow> Pi_pmf (A \<union> B) dflt p; return_pmf (f(x := v))}"
	+ using insert.hyps and insert.prems by (intro bind_pmf_cong insert.IH [symmetric] refl) auto
	+ also have "\<dots> = Pi_pmf (insert x (A \<union> B)) dflt p"
	+ by (subst Pi_pmf_insert)
	+ (insert assms insert.hyps insert.prems, auto simp: pair_pmf_def map_bind_pmf)
	+ also have "insert x (A \<union> B) = insert x A \<union> B"
	+ by simp
	+ finally show ?case ..
	+qed (simp_all add: case_prod_unfold map_snd_pair_pmf)
	+
	+text \<open>
	+ We can also project a product to a subset of the indices by mapping all the other
	+ indices to the default value:
	+\<close>
	+lemma Pi_pmf_subset:
	+ assumes "finite A" "A' \<subseteq> A"
	+ shows "Pi_pmf A' dflt p = map_pmf (\<lambda>f x. if x \<in> A' then f x else dflt) (Pi_pmf A dflt p)"
	+proof -
	+ let ?P = "pair_pmf (Pi_pmf A' dflt p) (Pi_pmf (A - A') dflt p)"
	+ from assms have [simp]: "finite A'"
	+ by (blast dest: finite_subset)
	+ from assms have "A = A' \<union> (A - A')"
	+ by blast
	+ also have "Pi_pmf \<dots> dflt p = map_pmf (\<lambda>(f,g) x. if x \<in> A' then f x else g x) ?P"
	+ using assms by (intro Pi_pmf_union) auto
	+ also have "map_pmf (\<lambda>f x. if x \<in> A' then f x else dflt) \<dots> = map_pmf fst ?P"
	+ unfolding map_pmf_comp o_def case_prod_unfold
	+ using set_Pi_pmf_subset[of A' dflt p] by (intro map_pmf_cong refl) (auto simp: fun_eq_iff)
	+ also have "\<dots> = Pi_pmf A' dflt p"
	+ by (simp add: map_fst_pair_pmf)
	+ finally show ?thesis ..
	+qed
	+
	+lemma Pi_pmf_subset':
	+ fixes f :: "'a \<Rightarrow> 'b pmf"
	+ assumes "finite A" "B \<subseteq> A" "\<And>x. x \<in> A - B \<Longrightarrow> f x = return_pmf dflt"
	+ shows "Pi_pmf A dflt f = Pi_pmf B dflt f"
	+proof -
	+ have "Pi_pmf (B \<union> (A - B)) dflt f =
	+ map_pmf (\<lambda>(f, g) x. if x \<in> B then f x else g x)
	+ (pair_pmf (Pi_pmf B dflt f) (Pi_pmf (A - B) dflt f))"
	+ using assms by (intro Pi_pmf_union) (auto dest: finite_subset)
	+ also have "Pi_pmf (A - B) dflt f = Pi_pmf (A - B) dflt (\<lambda>_. return_pmf dflt)"
	+ using assms by (intro Pi_pmf_cong) auto
	+ also have "\<dots> = return_pmf (\<lambda>_. dflt)"
	+ using assms by simp
	+ also have "map_pmf (\<lambda>(f, g) x. if x \<in> B then f x else g x)
	+ (pair_pmf (Pi_pmf B dflt f) (return_pmf (\<lambda>_. dflt))) =
	+ map_pmf (\<lambda>f x. if x \<in> B then f x else dflt) (Pi_pmf B dflt f)"
	+ by (simp add: map_pmf_def pair_pmf_def bind_assoc_pmf bind_return_pmf bind_return_pmf')
	+ also have "\<dots> = Pi_pmf B dflt f"
	+ using assms by (intro Pi_pmf_default_swap) (auto dest: finite_subset)
	+ also have "B \<union> (A - B) = A"
	+ using assms by auto
	+ finally show ?thesis .
	+qed
	+
	+lemma Pi_pmf_if_set:
	+ assumes "finite A"
	+ shows "Pi_pmf A dflt (\<lambda>x. if b x then f x else return_pmf dflt) =
	+ Pi_pmf {x\<in>A. b x} dflt f"
	+proof -
	+ have "Pi_pmf A dflt (\<lambda>x. if b x then f x else return_pmf dflt) =
	+ Pi_pmf {x\<in>A. b x} dflt (\<lambda>x. if b x then f x else return_pmf dflt)"
	+ using assms by (intro Pi_pmf_subset') auto
	+ also have "\<dots> = Pi_pmf {x\<in>A. b x} dflt f"
	+ by (intro Pi_pmf_cong) auto
	+ finally show ?thesis .
	+qed
	+
	+lemma Pi_pmf_if_set':
	+ assumes "finite A"
	+ shows "Pi_pmf A dflt (\<lambda>x. if b x then return_pmf dflt else f x) =
	+ Pi_pmf {x\<in>A. \<not>b x} dflt f"
	+proof -
	+ have "Pi_pmf A dflt (\<lambda>x. if b x then return_pmf dflt else f x) =
	+ Pi_pmf {x\<in>A. \<not>b x} dflt (\<lambda>x. if b x then return_pmf dflt else f x)"
	+ using assms by (intro Pi_pmf_subset') auto
	+ also have "\<dots> = Pi_pmf {x\<in>A. \<not>b x} dflt f"
	+ by (intro Pi_pmf_cong) auto
	+ finally show ?thesis .
	+qed
	+
	+text \<open>
	+ Lastly, we can delete a single component from a product:
	+\<close>
	+lemma Pi_pmf_remove:
	+ assumes "finite A"
	+ shows "Pi_pmf (A - {x}) dflt p = map_pmf (\<lambda>f. f(x := dflt)) (Pi_pmf A dflt p)"
	+proof -
	+ have "Pi_pmf (A - {x}) dflt p =
	+ map_pmf (\<lambda>f xa. if xa \<in> A - {x} then f xa else dflt) (Pi_pmf A dflt p)"
	+ using assms by (intro Pi_pmf_subset) auto
	+ also have "\<dots> = map_pmf (\<lambda>f. f(x := dflt)) (Pi_pmf A dflt p)"
	+ using set_Pi_pmf_subset[of A dflt p] assms
	+ by (intro map_pmf_cong refl) (auto simp: fun_eq_iff)
	+ finally show ?thesis .
	+qed
	+
	+
	+subsection \<open>Applications\<close>
	+
	+text \<open>
	+ Choosing a subset of a set uniformly at random is equivalent to tossing a fair coin
	+ independently for each element and collecting all the elements that came up heads.
	+\<close>
	+lemma pmf_of_set_Pow_conv_bernoulli:
	+ assumes "finite (A :: 'a set)"
	+ shows "map_pmf (\<lambda>b. {x\<in>A. b x}) (Pi_pmf A P (\<lambda>_. bernoulli_pmf (1/2))) = pmf_of_set (Pow A)"
	+proof -
	+ have "Pi_pmf A P (\<lambda>_. bernoulli_pmf (1/2)) = pmf_of_set (PiE_dflt A P (\<lambda>x. UNIV))"
	+ using assms by (simp add: bernoulli_pmf_half_conv_pmf_of_set Pi_pmf_of_set)
	+ also have "map_pmf (\<lambda>b. {x\<in>A. b x}) \<dots> = pmf_of_set (Pow A)"
	+ proof -
	+ have "bij_betw (\<lambda>b. {x \<in> A. b x}) (PiE_dflt A P (\<lambda>_. UNIV)) (Pow A)"
	+ by (rule bij_betwI[of _ _ _ "\<lambda>B b. if b \<in> A then b \<in> B else P"]) (auto simp add: PiE_dflt_def)
	+ then show ?thesis
	+ using assms by (intro map_pmf_of_set_bij_betw) auto
	+ qed
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+text \<open>
	+ A binomial distribution can be seen as the number of successes in \<open>n\<close> independent coin tosses.
	+\<close>
	+lemma binomial_pmf_altdef':
	+ fixes A :: "'a set"
	+ assumes "finite A" and "card A = n" and p: "p \<in> {0..1}"
	+ shows "binomial_pmf n p =
	+ map_pmf (\<lambda>f. card {x\<in>A. f x}) (Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p))" (is "?lhs = ?rhs")
	+proof -
	+ from assms have "?lhs = binomial_pmf (card A) p"
	+ by simp
	+ also have "\<dots> = ?rhs"
	+ using assms(1)
	+ proof (induction rule: finite_induct)
	+ case empty
	+ with p show ?case by (simp add: binomial_pmf_0)
	+ next
	+ case (insert x A)
	+ from insert.hyps have "card (insert x A) = Suc (card A)"
	+ by simp
	+ also have "binomial_pmf \<dots> p = do {
	+ b \<leftarrow> bernoulli_pmf p;
	+ f \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
	+ return_pmf ((if b then 1 else 0) + card {y \<in> A. f y})
	+ }"
	+ using p by (simp add: binomial_pmf_Suc insert.IH bind_map_pmf)
	+ also have "\<dots> = do {
	+ b \<leftarrow> bernoulli_pmf p;
	+ f \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
	+ return_pmf (card {y \<in> insert x A. (f(x := b)) y})
	+ }"
	+ proof (intro bind_pmf_cong refl, goal_cases)
	+ case (1 b f)
	+ have "(if b then 1 else 0) + card {y\<in>A. f y} = card ((if b then {x} else {}) \<union> {y\<in>A. f y})"
	+ using insert.hyps by auto
	+ also have "(if b then {x} else {}) \<union> {y\<in>A. f y} = {y\<in>insert x A. (f(x := b)) y}"
	+ using insert.hyps by auto
	+ finally show ?case by simp
	+ qed
	+ also have "\<dots> = map_pmf (\<lambda>f. card {y\<in>insert x A. f y})
	+ (Pi_pmf (insert x A) dflt (\<lambda>_. bernoulli_pmf p))"
	+ using insert.hyps by (subst Pi_pmf_insert) (simp_all add: pair_pmf_def map_bind_pmf)
	+ finally show ?case .
	+ qed
	+ finally show ?thesis .
	+qed
	+
	+end
	diff --git a/thys/Skip_Lists/ROOT b/thys/Skip_Lists/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Skip_Lists/ROOT
	@@ -0,0 +1,14 @@
	+chapter AFP
	+
	+session Skip_Lists (AFP) = "HOL-Probability" +
	+ options [timeout = 300]
	+ sessions
	+ Monad_Normalisation
	+ theories
	+ Pi_pmf
	+ Misc
	+ Geometric_PMF
	+ Skip_List
	+ document_files
	+ "root.tex"
	+ "root.bib"
	diff --git a/thys/Skip_Lists/Skip_List.thy b/thys/Skip_Lists/Skip_List.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Skip_Lists/Skip_List.thy
	@@ -0,0 +1,1346 @@
	+(*
	+ File: Skip_List.thy
	+ Authors: Max W. Haslbeck, Manuel Eberl
	+*)
	+
	+section \<open>Randomized Skip Lists\<close>
	+theory Skip_List
	+ imports Geometric_PMF
	+ Pi_pmf
	+ Misc
	+ "Monad_Normalisation.Monad_Normalisation"
	+begin
	+
	+subsection \<open>Preliminaries\<close>
	+
	+lemma bind_pmf_if': "(do {c \<leftarrow> C;
	+ ab \<leftarrow> (if c then A else B);
	+ D ab}::'a pmf) =
	+ do {c \<leftarrow> C;
	+ (if c then (A \<bind> D) else (B \<bind> D))}"
	+ by (metis (mono_tags, lifting))
	+
	+abbreviation (input) Max\<^sub>0 where "Max\<^sub>0 \<equiv> (\<lambda>A. Max (A \<union> {0}))"
	+
	+
	+subsection \<open>Definition of a Randomised Skip List\<close>
	+
	+text \<open>
	+ Given a set A we assign a geometric random variable (counting the number of failed Bernoulli
	+ trials before the first success) to every element in A. That means an arbitrary element of A is
	+ on level n with probability $(1-p)^{n}p$. We define he height of the skip list as the maximum
	+ assigned level. So a skip list with only one level has height 0 but the calculation of the
	+ expected height is cleaner this way.
	+\<close>
	+
	+locale random_skip_list =
	+ fixes p::real
	+begin
	+
	+definition q where "q = 1 - p"
	+
	+definition SL :: "('a::linorder) set \<Rightarrow> ('a \<Rightarrow> nat) pmf" where "SL A = Pi_pmf A 0 (\<lambda>_. geometric_pmf p)"
	+definition SL\<^sub>N :: "nat \<Rightarrow> (nat \<Rightarrow> nat) pmf" where "SL\<^sub>N n = SL {..<n}"
	+
	+subsection \<open>Height of Skip List\<close>
	+
	+definition H where "H A = map_pmf (\<lambda>f. Max\<^sub>0 (f ` A)) (SL A)"
	+definition H\<^sub>N :: "nat \<Rightarrow> nat pmf" where "H\<^sub>N n = H {..<n}"
	+
	+context includes monad_normalisation
	+begin
	+
	+text \<open>
	+ The height of a skip list is independent of the values in a set A. For simplicity we can
	+ therefore work on the skip list over the set @{term "{..< card A}"}
	+\<close>
	+
	+lemma
	+ assumes "finite A"
	+ shows "H A = H\<^sub>N (card A)"
	+proof -
	+ define f' where "f' = (\<lambda>x. if x \<in> A
	+ then the_inv_into {..<card A} ((!) (sorted_list_of_set A)) x
	+ else card A)"
	+ have bij_f': "bij_betw f' A {..<card A}"
	+ proof -
	+ (* I know the proof looks weird, but for some reason all tools have problems with this proof *)
	+ have "bij_betw (the_inv_into {..<card A} ((!) (sorted_list_of_set A))) A {..<card A}"
	+ unfolding f'_def using sorted_list_of_set_bij_betw assms bij_betw_the_inv_into by blast
	+ moreover have "bij_betw (the_inv_into {..<card A} ((!) (sorted_list_of_set A))) A {..<card A}
	+ = bij_betw f' A {..<card A}"
	+ unfolding f'_def by (rule bij_betw_cong) simp
	+ ultimately show ?thesis
	+ by blast
	+ qed
	+ have *: "Max\<^sub>0 ((f \<circ> f') ` A) = Max\<^sub>0 (f ` {..<card A})" for f :: "nat \<Rightarrow> nat"
	+ using bij_betw_imp_surj_on bij_f' image_comp by metis
	+ have "H A = map_pmf (\<lambda>f. Max\<^sub>0 (f ` A)) (map_pmf (\<lambda>g. g \<circ> f') (SL\<^sub>N (card A)))"
	+ using assms bij_f' unfolding H_def SL_def SL\<^sub>N_def
	+ by (subst Pi_pmf_bij_betw[of _ f' "{..<card A}"]) (auto simp add: f'_def)
	+ also have "\<dots> = H\<^sub>N (card A)"
	+ unfolding H\<^sub>N_def H_def SL\<^sub>N_def using * by (auto intro!: bind_pmf_cong simp add: map_pmf_def)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+text \<open>
	+ The cumulative distribution function (CDF) of the height is the CDF of the geometric PMF to the
	+ power of n
	+\<close>
	+
	+lemma prob_Max_IID_geometric_atMost:
	+ assumes "p \<in> {0..1}"
	+ shows "measure_pmf.prob (H\<^sub>N n) {..i}
	+ = (measure_pmf.prob (geometric_pmf p) {..i}) ^ n" (is "?lhs = ?rhs")
	+proof -
	+ note SL_def[simp] SL\<^sub>N_def[simp] H_def[simp] H\<^sub>N_def[simp]
	+ have "{f. Max\<^sub>0 (f ` {..<n}) \<le> i} = {..<n} \<rightarrow> {..i}"
	+ by auto
	+ then have "?lhs = measure_pmf.prob (SL\<^sub>N n) ({..<n} \<rightarrow> {..i})"
	+ by (simp add: vimage_def)
	+ also have "\<dots> = measure_pmf.prob (SL\<^sub>N n) (PiE_dflt {..<n} 0 (\<lambda>_. {..i}))"
	+ by (intro measure_prob_cong_0) (auto simp add: PiE_dflt_def pmf_Pi split: if_splits)
	+ also have "\<dots> = measure_pmf.prob (geometric_pmf p) {..i} ^ n"
	+ using assms by (auto simp add: measure_Pi_pmf_PiE_dflt)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma prob_Max_IID_geometric_greaterThan:
	+ assumes "p \<in> {0<..1}"
	+ shows "measure_pmf.prob (H\<^sub>N n) {i<..} =
	+ 1 - (1 - q ^ (i + 1)) ^ n"
	+proof -
	+ have "UNIV - {..i} = {i<..}"
	+ by auto
	+ then have "measure_pmf.prob (H\<^sub>N n) {i<..} = measure_pmf.prob (H\<^sub>N n) (space (measure_pmf (H\<^sub>N n)) - {..i})"
	+ by (auto)
	+ also have "\<dots> = 1 - (measure_pmf.prob (geometric_pmf p) {..i}) ^ n"
	+ using assms by (subst measure_pmf.prob_compl) (auto simp add: prob_Max_IID_geometric_atMost)
	+ also have "\<dots> = 1 - (1 - q ^ (i + 1)) ^ n"
	+ using assms unfolding q_def by (subst geometric_pmf_prob_atMost) auto
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+end (* context includes monad_normalisation *)
	+end (* locale skip_list *)
	+
	+text \<open>
	+ An alternative definition of the expected value of a non-negative random variable
	+ \footnote{\url{https://en.wikipedia.org/w/index.php?title=Expected\_value&oldid=881384346\#Formula\_for\_non-negative\_random\_variables}}
	+\<close>
	+
	+lemma expectation_prob_atLeast:
	+ assumes "(\<lambda>i. measure_pmf.prob N {i..}) abs_summable_on {1..}"
	+ shows "measure_pmf.expectation N real = infsetsum (\<lambda>i. measure_pmf.prob N {i..}) {1..}"
	+ "integrable N real"
	+proof -
	+ have "(\<lambda>(x, y). pmf N y) abs_summable_on Sigma {Suc 0..} atLeast"
	+ using assms by (auto simp add: measure_pmf_conv_infsetsum abs_summable_on_Sigma_iff)
	+ then have summable: "(\<lambda>(x, y). pmf N x) abs_summable_on Sigma {Suc 0..} (atLeastAtMost (Suc 0))"
	+ by (subst abs_summable_on_reindex_bij_betw[of "\<lambda>(x,y). (y,x)", symmetric])
	+ (auto intro!: bij_betw_imageI simp add: inj_on_def case_prod_beta)
	+ have "measure_pmf.expectation N real = (\<Sum>\<^sub>ax. pmf N x *\<^sub>R real x)"
	+ by (auto simp add: infsetsum_def integral_density measure_pmf_eq_density)
	+ also have "\<dots> = (\<Sum>\<^sub>ax \<in> ({0} \<union> {Suc 0..}). pmf N x *\<^sub>R real x)"
	+ by (auto intro!: infsetsum_cong)
	+ also have "\<dots> = (\<Sum>\<^sub>ax\<in>{Suc 0..}. pmf N x * real x)"
	+ proof -
	+ have "(\<lambda>x. pmf N x *\<^sub>R real x) abs_summable_on {0} \<union> {Suc 0..}"
	+ using summable by (subst (asm) abs_summable_on_Sigma_iff) (auto simp add: mult.commute)
	+ then show ?thesis
	+ by (subst infsetsum_Un_Int) auto
	+ qed
	+ also have "\<dots> = (\<Sum>\<^sub>a(x, y)\<in>Sigma {Suc 0..} (atLeastAtMost (Suc 0)). pmf N x)"
	+ using summable by (subst infsetsum_Sigma) (auto simp add: mult.commute)
	+ also have "\<dots> = (\<Sum>\<^sub>ax\<in>Sigma {Suc 0..} atLeast. pmf N (snd x))"
	+ by (subst infsetsum_reindex_bij_betw[of "\<lambda>(x,y). (y,x)", symmetric])
	+ (auto intro!: bij_betw_imageI simp add: inj_on_def case_prod_beta)
	+ also have "\<dots> = infsetsum (\<lambda>i. measure_pmf.prob N {i..}) {1..}"
	+ using assms
	+ by (subst infsetsum_Sigma)
	+ (auto simp add: measure_pmf_conv_infsetsum abs_summable_on_Sigma_iff infsetsum_Sigma')
	+ finally show "measure_pmf.expectation N real = infsetsum (\<lambda>i. measure_pmf.prob N {i..}) {1..}"
	+ by simp
	+ have "(\<lambda>x. pmf N x *\<^sub>R real x) abs_summable_on {0} \<union> {Suc 0..}"
	+ using summable by (subst (asm) abs_summable_on_Sigma_iff) (auto simp add: mult.commute)
	+ then have "(\<lambda>x. pmf N x *\<^sub>R real x) abs_summable_on UNIV"
	+ by (simp add: atLeast_Suc)
	+ then have "integrable (count_space UNIV) (\<lambda>x. pmf N x *\<^sub>R real x)"
	+ by (subst abs_summable_on_def[symmetric]) blast
	+ then show "integrable N real"
	+ by (subst measure_pmf_eq_density, subst integrable_density) auto
	+qed
	+
	+text \<open>
	+ The expected height of a skip list has no closed-form expression but we can approximate it. We
	+ start by showing how we can calculate an infinite sum over the natural numbers with an integral
	+ over the positive reals and the floor function.
	+\<close>
	+
	+lemma infsetsum_set_nn_integral_reals:
	+ assumes "f abs_summable_on UNIV" "\<And>n. f n \<ge> 0"
	+ shows "infsetsum f UNIV = set_nn_integral lborel {0::real..} (\<lambda>x. f (nat (floor x)))"
	+proof -
	+ have "x < 1 + (floor x)"for x::real
	+ by linarith
	+ then have "\<exists>n. real n \<le> x \<and> x < 1 + real n" if "x \<ge> 0" for x
	+ using that of_nat_floor by (intro exI[of _ "nat (floor x)"]) auto
	+ then have "{0..} = (\<Union>n. {real n..<real (Suc n)})"
	+ by auto
	+ then have "\<integral>\<^sup>+x\<in>{0::real..}. ennreal (f (nat \<lfloor>x\<rfloor>))\<partial>lborel =
	+ (\<Sum>n. \<integral>\<^sup>+x\<in>{real n..<1 + real n}. ennreal (f (nat \<lfloor>x\<rfloor>))\<partial>lborel)"
	+ by (auto simp add: disjoint_family_on_def nn_integral_disjoint_family)
	+ also have "\<dots> = (\<Sum>n. \<integral>\<^sup>+x\<in>{real n..<1 + real n}. ennreal (f n)\<partial>lborel)"
	+ by(subst suminf_cong, rule nn_integral_cong_AE)
	+ (auto intro!: eventuallyI simp add: indicator_def floor_eq4)
	+ also have "\<dots> = (\<Sum>n. ennreal (f n))"
	+ by (auto intro!: suminf_cong simp add: nn_integral_cmult)
	+ also have "\<dots> = infsetsum f {0..}"
	+ using assms suminf_ennreal2 abs_summable_on_nat_iff' summable_norm_cancel
	+ by (auto simp add: infsetsum_nat)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma nn_integral_nats_reals:
	+ shows "(\<integral>\<^sup>+ i. ennreal (f i) \<partial>count_space UNIV) = \<integral>\<^sup>+x\<in>{0::real..}. ennreal (f (nat \<lfloor>x\<rfloor>))\<partial>lborel"
	+proof -
	+ have "x < 1 + (floor x)"for x::real
	+ by linarith
	+ then have "\<exists>n. real n \<le> x \<and> x < 1 + real n" if "x \<ge> 0" for x
	+ using that of_nat_floor by (intro exI[of _ "nat (floor x)"]) auto
	+ then have "{0..} = (\<Union>n. {real n..<real (Suc n)})"
	+ by auto
	+ then have "\<integral>\<^sup>+x\<in>{0::real..}. f (nat \<lfloor>x\<rfloor>)\<partial>lborel =
	+ (\<Sum>n. \<integral>\<^sup>+x\<in>{real n..<1 + real n}. ennreal (f (nat \<lfloor>x\<rfloor>))\<partial>lborel)"
	+ by (auto simp add: disjoint_family_on_def nn_integral_disjoint_family)
	+ also have "\<dots> = (\<Sum>n. \<integral>\<^sup>+x\<in>{real n..<1 + real n}. ennreal (f n)\<partial>lborel)"
	+ by(subst suminf_cong,rule nn_integral_cong_AE)
	+ (auto intro!: eventuallyI simp add: indicator_def floor_eq4)
	+ also have "\<dots> = (\<Sum>n. ennreal (f n))"
	+ by (auto intro!: suminf_cong simp add: nn_integral_cmult)
	+ also have "\<dots> = (\<integral>\<^sup>+ i. ennreal (f i) \<partial>count_space UNIV)"
	+ by (simp add: nn_integral_count_space_nat)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma nn_integral_floor_less_eq:
	+ assumes "\<And>x y. x \<le> y \<Longrightarrow> f y \<le> f x"
	+ shows "\<integral>\<^sup>+x\<in>{0::real..}. ennreal (f x)\<partial>lborel \<le> \<integral>\<^sup>+x\<in>{0::real..}. ennreal (f (nat \<lfloor>x\<rfloor>))\<partial>lborel"
	+ using assms by (auto simp add: indicator_def intro!: nn_integral_mono ennreal_leI)
	+
	+lemma nn_integral_finite_imp_abs_sumable_on:
	+ fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
	+ assumes "nn_integral (count_space A) (\<lambda>x. norm (f x)) < \<infinity>"
	+ shows "f abs_summable_on A"
	+ using assms unfolding abs_summable_on_def integrable_iff_bounded by auto
	+
	+lemma nn_integral_finite_imp_abs_sumable_on':
	+ assumes "nn_integral (count_space A) (\<lambda>x. ennreal (f x)) < \<infinity>" "\<And>x. f x \<ge> 0"
	+ shows "f abs_summable_on A"
	+ using assms unfolding abs_summable_on_def integrable_iff_bounded by auto
	+
	+text \<open>
	+ We now show that $\int_0^\infty 1 - (1 - q^x) ^ n\;dx = \frac{- H_n}{\ln q}$ if $0 < q < 1$.
	+\<close>
	+
	+lemma harm_integral_x_raised_n:
	+ "set_integrable lborel {0::real..1} (\<lambda>x. (\<Sum>i\<in>{..<n}. x ^ i))" (is ?thesis1)
	+ "LBINT x = 0..1. (\<Sum>i\<in>{..<n}. x ^ i) = harm n" (is ?thesis2)
	+proof -
	+ have h: "set_integrable lborel {0::real..1} (\<lambda>x. (\<Sum>i\<in>{..<n}. x ^ i))" for n
	+ by (intro borel_integrable_atLeastAtMost') (auto intro!: continuous_intros)
	+ then show ?thesis1
	+ by (intro borel_integrable_atLeastAtMost') (auto intro!: continuous_intros)
	+ show ?thesis2
	+ proof (induction n)
	+ case (Suc n)
	+ have "(LBINT x=0..1.(\<Sum>i\<in>{..<n}. x ^ i) + x ^ n) =
	+ (LBINT x=0..1. (\<Sum>i\<in>{..<n}. x ^ i)) + (LBINT x=0..1. x ^ n)"
	+ proof -
	+ have "set_integrable lborel (einterval 0 1) (\<lambda>x. (\<Sum>i\<in>{..<n}. x ^ i))"
	+ by (rule set_integrable_subset) (use h in \<open>auto simp add: einterval_def\<close>)
	+ moreover have "set_integrable lborel (einterval 0 1) (\<lambda>x. (x ^ n))"
	+ proof -
	+ have "set_integrable lborel {0::real..1} (\<lambda>x. (x ^ n))"
	+ by (rule borel_integrable_atLeastAtMost')
	+ (auto intro!: borel_integrable_atLeastAtMost' continuous_intros)
	+ then show ?thesis
	+ by (rule set_integrable_subset) (auto simp add: einterval_def)
	+ qed
	+ ultimately show ?thesis
	+ by (auto intro!: borel_integrable_atLeastAtMost' simp add: interval_lebesgue_integrable_def)
	+ qed
	+ also have "(LBINT x=0..1. x ^ n) = 1 / (1 + real n)"
	+ proof -
	+ have "(LBINT x=0..1. x ^ n) = LBINT x. x ^ n * indicator {0..1} x "
	+ proof -
	+ have "AE x in lborel. x ^ n * indicator {0..1} x = indicator (einterval 0 1) x * x ^ n"
	+ by(rule eventually_mono[OF eventually_conj[OF AE_lborel_singleton[of 1]
	+ AE_lborel_singleton[of 0]]])
	+ (auto simp add: indicator_def einterval_def)
	+ then show ?thesis
	+ using integral_cong_AE unfolding interval_lebesgue_integral_def set_lebesgue_integral_def
	+ by (auto intro!: integral_cong_AE)
	+ qed
	+ then show ?thesis
	+ by (auto simp add: integral_power)
	+ qed
	+ finally show ?case
	+ using Suc by (auto simp add: harm_def inverse_eq_divide)
	+ qed (auto simp add: harm_def)
	+qed
	+
	+lemma harm_integral_0_1_fraction:
	+ "set_integrable lborel {0::real..1} (\<lambda>x. (1 - x ^ n) / (1 - x))"
	+ "(LBINT x = 0..1. ((1 - x ^ n) / (1 - x))) = harm n"
	+proof -
	+ show "set_integrable lborel {0::real..1} (\<lambda>x. (1 - x ^ n) / (1 - x))"
	+ proof -
	+ have "AE x\<in>{0::real..1} in lborel. (1 - x ^ n) / (1 - x) = sum ((^) x) {..<n}"
	+ by (auto intro!: eventually_mono[OF AE_lborel_singleton[of 1]] simp add: sum_gp_strict)
	+ with harm_integral_x_raised_n show ?thesis
	+ by (subst set_integrable_cong_AE) auto
	+ qed
	+ moreover have "AE x\<in>{0::real<..<1} in lborel. (1 - x ^ n) / (1 - x) = sum ((^) x) {..<n}"
	+ by (auto simp add: sum_gp_strict)
	+ moreover have "einterval (min 0 1) (max 0 1) = {0::real<..<1}"
	+ by (auto simp add: min_def max_def einterval_iff)
	+ ultimately show "(LBINT x = 0..1. ((1 - x ^ n) / (1 - x))) = harm n"
	+ using harm_integral_x_raised_n by (subst interval_integral_cong_AE) auto
	+qed
	+
	+lemma one_minus_one_minus_q_x_n_integral:
	+ assumes "q \<in> {0<..<1}"
	+ shows "set_integrable lborel (einterval 0 \<infinity>) (\<lambda>x. (1 - (1 - q powr x) ^ n))"
	+ "(LBINT x=0..\<infinity>. 1 - (1 - q powr x) ^ n) = - harm n / ln q"
	+proof -
	+ have [simp]: "q powr (log q (1-x)) = 1 - x" if "x \<in> {0<..<1}" for x
	+ using that assms by (subst powr_log_cancel) auto
	+ have 1: "((ereal \<circ> (\<lambda>x. log q (1 - x)) \<circ> real_of_ereal) \<longlongrightarrow> 0) (at_right 0)"
	+ using assms unfolding zero_ereal_def ereal_tendsto_simps by (auto intro!: tendsto_eq_intros)
	+ have 2: "((ereal \<circ> (\<lambda>x. log q (1-x)) \<circ> real_of_ereal) \<longlongrightarrow> \<infinity>) (at_left 1)"
	+ proof -
	+ have "filterlim ((-) 1) (at_right 0) (at_left (1::real))"
	+ by (intro filterlim_at_withinI eventually_at_leftI[of 0]) (auto intro!: tendsto_eq_intros)
	+ then have "LIM x at_left 1. - inverse (ln q) * - ln (1 - x) :> at_top"
	+ using assms
	+ by (intro filterlim_tendsto_pos_mult_at_top [OF tendsto_const])
	+ (auto simp: filterlim_uminus_at_top intro!: filterlim_compose[OF ln_at_0])
	+ then show ?thesis
	+ unfolding one_ereal_def ereal_tendsto_simps log_def by (simp add: field_simps)
	+ qed
	+ have 3: "set_integrable lborel (einterval 0 1)
	+ (\<lambda>x. (1 - (1 - q powr (log q (1 - x))) ^ n) * (- 1 / (ln q * (1 - x))))"
	+ proof -
	+ have "set_integrable lborel (einterval 0 1) (\<lambda>x. - (1 / ln q) * ((1 - x ^ n) / (1 - x)))"
	+ by(intro set_integrable_mult_right)
	+ (auto intro!: harm_integral_0_1_fraction intro: set_integrable_subset simp add: einterval_def)
	+ then show ?thesis
	+ by(subst set_integrable_cong_AE[where g="\<lambda>x. - (1 / ln q) * ((1 - x ^ n) / (1 - x))"])
	+ (auto intro!: eventuallyI simp add: einterval_def)
	+ qed
	+ have 4: "LBINT x=0..1. - ((1 - (1 - q powr log q (1 - x)) ^ n) / (ln q * (1 - x))) = - (harm n / ln q)"
	+ (is "?lhs = ?rhs")
	+ proof -
	+ have "?lhs = LBINT x=0..1. ((1 - x ^ n) / (1 - x)) * (- 1 / ln q)"
	+ using assms
	+ by (intro interval_integral_cong_AE)
	+ (auto intro!: eventuallyI simp add: max_def einterval_def field_simps)
	+ also have "\<dots> = harm n * (-1 / ln q)"
	+ using harm_integral_0_1_fraction by (subst interval_lebesgue_integral_mult_left) auto
	+ finally show ?thesis
	+ by auto
	+ qed
	+ note sub = interval_integral_substitution_nonneg
	+ [where f = "(\<lambda>x. (1 - (1 - q powr x) ^ n))" and g="(\<lambda>x. log q (1-x))"
	+ and g'="(\<lambda>x. - 1 / (ln q * (1 - x)))" and a = 0 and b = 1]
	+ show "set_integrable lborel (einterval 0 \<infinity>) (\<lambda>x. (1 - (1 - q powr x) ^ n))"
	+ using assms 1 2 3 4
	+ by (intro sub) (auto intro!: derivative_eq_intros mult_nonneg_nonpos2 tendsto_intros power_le_one)
	+ show "(LBINT x=0..\<infinity>. 1 - (1 - q powr x) ^ n) = - harm n / ln q"
	+ using assms 1 2 3 4
	+ by (subst sub) (auto intro!: derivative_eq_intros mult_nonneg_nonpos2 tendsto_intros power_le_one)
	+qed
	+
	+lemma one_minus_one_minus_q_x_n_nn_integral:
	+ fixes q::real
	+ assumes "q \<in> {0<..<1}"
	+ shows "set_nn_integral lborel {0..} (\<lambda>x. (1 - (1 - q powr x) ^ n)) =
	+ LBINT x=0..\<infinity>. 1 - (1 - q powr x) ^ n"
	+proof -
	+ have "set_nn_integral lborel {0..} (\<lambda>x. (1 - (1 - q powr x) ^ n)) =
	+ nn_integral lborel (\<lambda>x. indicator (einterval 0 \<infinity>) x * (1 - (1 - q powr x) ^ n))"
	+ using assms by (intro nn_integral_cong_AE eventually_mono[OF AE_lborel_singleton[of 0]])
	+ (auto simp add: indicator_def einterval_def)
	+ also have "\<dots> = ennreal (LBINT x. indicator (einterval 0 \<infinity>) x * (1 - (1 - q powr x) ^ n))"
	+ using one_minus_one_minus_q_x_n_integral assms
	+ by(intro nn_integral_eq_integral)
	+ (auto simp add: indicator_def einterval_def set_integrable_def
	+ intro!: eventuallyI power_le_one powr_le1)
	+ finally show ?thesis
	+ by (simp add: interval_lebesgue_integral_def set_lebesgue_integral_def)
	+qed
	+
	+text \<open>
	+ We can now derive bounds for the expected height.
	+\<close>
	+
	+context random_skip_list
	+begin
	+
	+definition EH\<^sub>N where "EH\<^sub>N n = measure_pmf.expectation (H\<^sub>N n) real"
	+
	+lemma EH\<^sub>N_bounds':
	+ fixes n::nat
	+ assumes "p \<in> {0<..<1}" "0 < n"
	+ shows "- harm n / ln q - 1 \<le> EH\<^sub>N n"
	+ "EH\<^sub>N n \<le> - harm n / ln q"
	+ "integrable (H\<^sub>N n) real"
	+proof -
	+ define f where "f = (\<lambda>x. 1 - (1 - q ^ x) ^ n)"
	+ define f' where "f' = (\<lambda>x. 1 - (1 - q powr x) ^ n)"
	+ have q: "q \<in> {0<..<1}"
	+ unfolding q_def using assms by auto
	+ have f_descending: "f y \<le> f x" if "x \<le> y" for x y
	+ unfolding f_def using that q
	+ by (auto intro!: power_mono simp add: power_decreasing power_le_one_iff)
	+ have f'_descending: "f' y \<le> f' x" if "x \<le> y" "0 \<le> x" for x y
	+ unfolding f'_def using that q
	+ by (auto intro!: power_mono simp add: ln_powr powr_def mult_nonneg_nonpos)
	+ have [simp]: "harm n / ln q <= 0"
	+ using harm_nonneg ln_ge_zero_imp_ge_one q by (intro divide_nonneg_neg) auto
	+ have f_nn_integral_harm:
	+ "- harm n / ln q \<le> \<integral>\<^sup>+ x. (f x) \<partial>count_space UNIV"
	+ "(\<integral>\<^sup>+ i. f (i + 1) \<partial>count_space UNIV) \<le> - harm n / ln q"
	+ proof -
	+ have "(\<integral>\<^sup>+ i. f (i + 1) \<partial>count_space UNIV) = (\<integral>\<^sup>+x\<in>{0::real..}. (f (nat \<lfloor>x\<rfloor> + 1))\<partial>lborel)"
	+ using nn_integral_nats_reals by auto
	+ also have "\<dots> = \<integral>\<^sup>+x\<in>{0::real..}. ennreal (f' (nat \<lfloor>x\<rfloor> + 1))\<partial>lborel"
	+ proof -
	+ have "0 \<le> x \<Longrightarrow> (1 - q * q ^ nat \<lfloor>x\<rfloor>) ^ n = (1 - q powr (1 + real_of_int \<lfloor>x\<rfloor>)) ^ n" for x::real
	+ using q by (metis greaterThanLessThan_iff powr_int powr_mult_base zero_le_floor)
	+ then show ?thesis
	+ unfolding f_def f'_def using q
	+ by (auto intro!: nn_integral_cong ennreal_cong simp add: powr_real_of_int indicator_def)
	+ qed
	+ also have "\<dots> \<le> set_nn_integral lborel {0..} f'"
	+ proof -
	+ have "x \<le> 1 + real_of_int \<lfloor>x\<rfloor>" for x
	+ by linarith
	+ then show ?thesis
	+ by (auto simp add: indicator_def intro!: f'_descending nn_integral_mono ennreal_leI)
	+ qed
	+ also have harm_integral_f': "\<dots> = - harm n / ln q"
	+ unfolding f'_def using q
	+ by (auto intro!: ennreal_cong
	+ simp add: one_minus_one_minus_q_x_n_nn_integral one_minus_one_minus_q_x_n_integral)
	+ finally show "(\<integral>\<^sup>+ i. f (i + 1) \<partial>count_space UNIV) \<le> - harm n / ln q"
	+ by simp
	+ note harm_integral_f'[symmetric]
	+ also have "set_nn_integral lborel {0..} f' \<le> \<integral>\<^sup>+x\<in>{0::real..}. f' (nat \<lfloor>x\<rfloor>)\<partial>lborel"
	+ using assms f'_descending
	+ by (auto simp add: indicator_def intro!: nn_integral_mono ennreal_leI)
	+ also have "\<dots> = \<integral>\<^sup>+x\<in>{0::real..}. f (nat \<lfloor>x\<rfloor>)\<partial>lborel"
	+ unfolding f_def f'_def
	+ using q by (auto intro!: nn_integral_cong ennreal_cong simp add: powr_real_of_int indicator_def)
	+ also have "\<dots> = (\<integral>\<^sup>+ x. f x \<partial>count_space UNIV)"
	+ using nn_integral_nats_reals by auto
	+ finally show "- harm n / ln q \<le> \<integral>\<^sup>+ x. f x \<partial>count_space UNIV"
	+ by simp
	+ qed
	+ then have f1_abs_summable_on: "(\<lambda>i. f (i + 1)) abs_summable_on UNIV"
	+ unfolding f_def using q
	+ by (intro nn_integral_finite_imp_abs_sumable_on')
	+ (auto simp add: f_def le_less_trans intro!: power_le_one mult_le_one)
	+ then have f_abs_summable_on: "f abs_summable_on {1..}"
	+ using Suc_le_lessD greaterThan_0
	+ by (subst abs_summable_on_reindex_bij_betw[symmetric, where g="\<lambda>x. x + 1" and A="UNIV"]) auto
	+ also have "(f abs_summable_on {1..}) = ((\<lambda>x. measure_pmf.prob (H\<^sub>N n) {x..}) abs_summable_on {1..})"
	+ proof -
	+ have "((\<lambda>x. measure_pmf.prob (H\<^sub>N n) {x..}) abs_summable_on {1..}) =
	+ ((\<lambda>x. measure_pmf.prob (H\<^sub>N n) {x - 1<..}) abs_summable_on {1..})"
	+ by (auto intro!: measure_prob_cong_0 abs_summable_on_cong)
	+ also have "\<dots> = (f abs_summable_on {1..})"
	+ using assms
	+ by (intro abs_summable_on_cong) (auto simp add: f_def prob_Max_IID_geometric_greaterThan)
	+ finally show ?thesis
	+ by simp
	+ qed
	+ finally have EH\<^sub>N_sum:
	+ "EH\<^sub>N n = (\<Sum>\<^sub>ai\<in>{1..}. measure_pmf.prob (H\<^sub>N n) {i..})"
	+ "integrable (measure_pmf (H\<^sub>N n)) real"
	+ unfolding EH\<^sub>N_def using expectation_prob_atLeast by auto
	+ then show "integrable (measure_pmf (H\<^sub>N n)) real"
	+ by simp
	+ have EH\<^sub>N_sum': "EH\<^sub>N n = infsetsum f {1..}"
	+ proof -
	+ have "EH\<^sub>N n = (\<Sum>\<^sub>ak\<in>{1..}. measure_pmf.prob (H\<^sub>N n) {k - 1<..})"
	+ unfolding EH\<^sub>N_sum by (auto intro!: measure_prob_cong_0 infsetsum_cong)
	+ also have "\<dots> = infsetsum f {1..}"
	+ using assms
	+ by (intro infsetsum_cong) (auto simp add: f_def prob_Max_IID_geometric_greaterThan)
	+ finally show ?thesis
	+ by simp
	+ qed
	+ also have "\<dots> = (\<Sum>\<^sub>ak. f (k + 1))"
	+ using Suc_le_lessD greaterThan_0
	+ by (subst infsetsum_reindex_bij_betw[symmetric, where g="\<lambda>x. x + 1" and A="UNIV"]) auto
	+ also have "ennreal \<dots> = (\<integral>\<^sup>+x\<in>{0::real..}. f (nat \<lfloor>x\<rfloor> + 1)\<partial>lborel)"
	+ using f1_abs_summable_on q
	+ by (intro infsetsum_set_nn_integral_reals) (auto simp add: f_def mult_le_one power_le_one)
	+ also have "\<dots> = (\<integral>\<^sup>+ i. f (i + 1) \<partial>count_space UNIV)"
	+ using nn_integral_nats_reals by auto
	+ also have "\<dots> \<le> - harm n / ln q"
	+ using f_nn_integral_harm by auto
	+ finally show "EH\<^sub>N n \<le> - harm n / ln q"
	+ by (subst (asm) ennreal_le_iff) (auto)
	+ have "EH\<^sub>N n + 1 = (\<Sum>\<^sub>ax\<in>{Suc 0..}. f x) + (\<Sum>\<^sub>ax\<in>{0}. f x)"
	+ using assms by (subst EH\<^sub>N_sum') (auto simp add: f_def)
	+ also have "\<dots> = infsetsum f UNIV"
	+ using f_abs_summable_on by (subst infsetsum_Un_disjoint[symmetric]) (auto intro!: infsetsum_cong)
	+ also have "\<dots> = (\<integral>\<^sup>+x\<in>{0::real..}. f (nat \<lfloor>x\<rfloor>)\<partial>lborel)"
	+ proof -
	+ have "f abs_summable_on ({0} \<union> {1..})"
	+ using f_abs_summable_on by (intro abs_summable_on_union) (auto)
	+ also have "{0::nat} \<union> {1..} = UNIV"
	+ by auto
	+ finally show ?thesis
	+ using q
	+ by (intro infsetsum_set_nn_integral_reals) (auto simp add: f_def mult_le_one power_le_one)
	+ qed
	+ also have "\<dots> = (\<integral>\<^sup>+ x. f x \<partial>count_space UNIV)"
	+ using nn_integral_nats_reals by auto
	+ also have "... \<ge> - harm n / ln q"
	+ using f_nn_integral_harm by auto
	+ finally have "- harm n / ln q \<le> EH\<^sub>N n + 1"
	+ by (subst (asm) ennreal_le_iff) (auto simp add: EH\<^sub>N_def)
	+ then show "- harm n / ln q - 1 \<le> EH\<^sub>N n"
	+ by simp
	+qed
	+
	+theorem EH\<^sub>N_bounds:
	+ fixes n::nat
	+ assumes "p \<in> {0<..<1}"
	+ shows
	+ "- harm n / ln q - 1 \<le> EH\<^sub>N n"
	+ "EH\<^sub>N n \<le> - harm n / ln q"
	+ "integrable (H\<^sub>N n) real"
	+proof -
	+ show "- harm n / ln q - 1 \<le> EH\<^sub>N n"
	+ using assms EH\<^sub>N_bounds'
	+ by (cases "n = 0") (auto simp add: EH\<^sub>N_def H\<^sub>N_def H_def SL_def harm_expand)
	+ show "EH\<^sub>N n \<le> - harm n / ln q"
	+ using assms EH\<^sub>N_bounds'
	+ by (cases "n = 0") (auto simp add: EH\<^sub>N_def H\<^sub>N_def H_def SL_def harm_expand)
	+ show "integrable (H\<^sub>N n) real"
	+ using assms EH\<^sub>N_bounds'
	+ by (cases "n = 0") (auto simp add: H\<^sub>N_def H_def SL_def intro!: integrable_measure_pmf_finite)
	+qed
	+
	+end (* context random_skip_list *)
	+
	+subsection \<open>Expected Length of Search Path\<close>
	+
	+text \<open>
	+ Let @{term "A::'a::linorder set"} and @{term "f::'a \<Rightarrow> nat"} where f is an abstract description
	+ of a skip list (assign each value its maximum level). steps A f s u l starts on the rightmost element
	+ on level s in the skip lists. If possible it moves up, if not it moves to the left. For every step
	+ up it adds cost u and for every step to the left it adds cost l. steps A f 0 1 1 therefore walks
	+ from the bottom right corner of a skip list to the top left corner of a skip list and counts
	+ all steps.
	+\<close>
	+
	+\<comment> \<open>NOTE: You could also define steps with lsteps and then prove that the following recursive
	+ definition holds\<close>
	+
	+function steps :: "'a :: linorder set \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
	+ "steps A f l up left = (if A = {} \<or> infinite A
	+ then 0
	+ else (let m = Max A in (if f m < l then steps (A - {m}) f l up left
	+ else (if f m > l then up + steps A f (l + 1) up left
	+ else left + steps (A - {m}) f l up left))))"
	+ by pat_completeness auto
	+termination
	+proof (relation "(\<lambda>(A,f,l,a,b). card A) <mlex> (\<lambda>(A,f,l,a,b). Max (f ` A) - l) <mlex> {}", goal_cases)
	+ case 1
	+ then show ?case
	+ by(intro wf_mlex wf_empty)
	+next
	+ case 2
	+ then show ?case
	+ by (intro mlex_less) (auto simp: card_gt_0_iff)
	+next
	+ case (3 A f l a b x)
	+ then have "Max (f ` A) - Suc l < Max (f ` A) - l"
	+ by (meson Max_gr_iff Max_in diff_less_mono2 finite_imageI imageI image_is_empty lessI)
	+ with 3 have "((A, f, l + 1, a, b), A, f, l, a, b) \<in> (\<lambda>(A, f, l, a, b). Max (f ` A) - l) <mlex> {}"
	+ by (intro mlex_less) (auto)
	+ with 3 show ?case apply - apply(rule mlex_leq) by auto
	+next
	+ case 4
	+ then show ?case by (intro mlex_less) (auto simp: card_gt_0_iff)
	+qed
	+
	+declare steps.simps[simp del]
	+
	+text \<open>
	+ lsteps is similar to steps but is using lists instead of sets. This makes the proofs where we use
	+ induction easier.
	+\<close>
	+
	+function lsteps :: "'a list \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
	+ "lsteps [] f l up left = 0" \|
	+ "lsteps (x#xs) f l up left = (if f x < l then lsteps xs f l up left
	+ else (if f x > l then up + lsteps (x#xs) f (l + 1) up left
	+ else left + lsteps xs f l up left))"
	+ by pat_completeness auto
	+termination
	+proof (relation "(\<lambda>(xs,f,l,a,b). length xs) <mlex> (\<lambda>(xs,f,l,a,b).
	+ Max (f ` set xs) - l) <mlex> {}",
	+ goal_cases)
	+ case 1
	+ then show ?case
	+ by(intro wf_mlex wf_empty)
	+next
	+ case 2
	+ then show ?case
	+ by (auto intro: mlex_less simp: card_gt_0_iff)
	+next
	+ case (3 n f l a b)
	+ show ?case
	+ by (rule mlex_leq) (use 3 in \<open>auto intro: mlex_less mlex_leq intro!: diff_less_mono2 simp add: Max_gr_iff\<close>)
	+next
	+ case 4
	+ then show ?case by (intro mlex_less) (auto simp: card_gt_0_iff)
	+qed
	+
	+declare lsteps.simps(2)[simp del]
	+
	+lemma steps_empty [simp]: "steps {} f l up left = 0"
	+ by (simp add: steps.simps)
	+
	+lemma steps_lsteps: "steps A f l u v = lsteps (rev (sorted_list_of_set A)) f l u v"
	+proof (cases "finite A \<and> A \<noteq> {}")
	+ case True
	+ then show ?thesis
	+ proof(induction "(rev (sorted_list_of_set A))" f l u v arbitrary: A rule: lsteps.induct)
	+ case (2 y ys f l u v A)
	+ then have y_ys: "y = Max A" "ys = rev (sorted_list_of_set (A - {y}))"
	+ by (auto simp add: sorted_list_of_set_Max_snoc)
	+ consider (a) "l < f y" \| (b) "f y < l" \| (c) "f y = l"
	+ by fastforce
	+ then have "steps A f l u v = lsteps (y#ys) f l u v"
	+ proof cases
	+ case a
	+ then show ?thesis
	+ by (subst steps.simps, subst lsteps.simps) (use y_ys 2 in auto)
	+ next
	+ case b
	+ then show ?thesis
	+ using y_ys 2(1) by (cases "ys = []") (auto simp add: steps.simps lsteps.simps)
	+ next
	+ case c
	+ then have "steps (A - {Max A}) f l u v =
	+ lsteps (rev (sorted_list_of_set (A - {Max A}))) f l u v"
	+ by (cases "A = {Max A}") (use y_ys 2 in \<open>auto intro!: 2(3) simp add: steps.simps\<close>)
	+ then show ?thesis
	+ by (subst steps.simps, subst lsteps.simps) (use y_ys 2 in auto)
	+ qed
	+ then show ?case
	+ using 2 by simp
	+ qed (auto simp add: steps.simps)
	+qed (auto simp add: steps.simps)
	+
	+lemma lsteps_comp_map: "lsteps zs (f \<circ> g) l u v = lsteps (map g zs) f l u v"
	+ by (induction zs "f \<circ> g" l u v rule: lsteps.induct) (auto simp add: lsteps.simps)
	+
	+lemma steps_image:
	+ assumes "finite A" "mono_on g A" "inj_on g A"
	+ shows "steps A (f \<circ> g) l u v = steps (g ` A) f l u v"
	+proof -
	+ have "(sorted_list_of_set (g ` A)) = map g (sorted_list_of_set A)"
	+ using sorted_list_of_set_image assms by auto
	+ also have "rev \<dots> = map g (rev (sorted_list_of_set A))"
	+ using rev_map by auto
	+ finally show ?thesis
	+ by (simp add: steps_lsteps lsteps_comp_map)
	+qed
	+
	+lemma lsteps_cong:
	+ assumes "ys = xs" "\<And>x. x \<in> set xs \<Longrightarrow> f x = g x" "l = l'"
	+ shows "lsteps xs f l u v = lsteps ys g l' u v"
	+ using assms proof (induction xs f l u v arbitrary: ys l' rule: lsteps.induct)
	+ case (2 x xs f l up left)
	+ then show ?case
	+ by (subst \<open>ys = x # xs\<close>, subst lsteps.simps, subst (2) lsteps.simps) auto
	+qed (auto)
	+
	+lemma steps_cong:
	+ assumes "A = B" "\<And>x. x \<in> A \<Longrightarrow> f x = g x" "l = l'"
	+ shows "steps A f l u v = steps B g l' u v"
	+ using assms
	+ by (cases "A = {} \<or> infinite A") (auto simp add: steps_lsteps steps.simps intro!: lsteps_cong)
	+
	+lemma lsteps_f_add':
	+ shows "lsteps xs f l u v = lsteps xs (\<lambda>x. f x + m) (l + m) u v"
	+ by (induction xs f l u v rule: lsteps.induct) (auto simp add: lsteps.simps)
	+
	+lemma steps_f_add':
	+ shows "steps A f l u v = steps A (\<lambda>x. f x + m) (l + m) u v"
	+ by (cases "A = {} \<or> infinite A") (auto simp add: steps_lsteps steps.simps intro!: lsteps_f_add')
	+
	+lemma lsteps_smaller_set:
	+ assumes "m \<le> l"
	+ shows "lsteps xs f l u v = lsteps [x \<leftarrow> xs. m \<le> f x] f l u v"
	+ using assms by (induction xs f l u v rule: lsteps.induct) (auto simp add: lsteps.simps)
	+
	+lemma steps_smaller_set:
	+ assumes "finite A" "m \<le> l"
	+ shows "steps A f l u v = steps {x\<in>A. f x \<ge> m} f l u v"
	+ using assms
	+ by(cases "A = {} \<or> infinite A")
	+ (auto simp add: steps_lsteps steps.simps rev_filter sorted_list_of_set_filter
	+ intro!: lsteps_smaller_set)
	+
	+lemma lsteps_level_greater_fun_image:
	+ assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x < l"
	+ shows "lsteps xs f l u v = 0"
	+ using assms by (induction xs f l u v rule: lsteps.induct) (auto simp add: lsteps.simps)
	+
	+lemma lsteps_smaller_card_Max_fun':
	+ assumes "\<exists>x \<in> set xs. l \<le> f x"
	+ shows "lsteps xs f l u v + l * u \<le> v * length xs + u * Max ((f ` (set xs)) \<union> {0})"
	+ using assms proof (induction xs f l u v rule: lsteps.induct)
	+ case (1 f l up left)
	+ then show ?case by (simp)
	+next
	+ case (2 x xs f l up left)
	+ consider "l = f x" "\<exists>y\<in>set xs. l \<le> f y" \| "f x = l" "\<not> (\<exists>y\<in>set xs. l \<le> f y)" \|
	+ "f x < l" \| "l < f x"
	+ by fastforce
	+ then show ?case
	+ proof cases
	+ assume a: "l = f x" "\<exists>y\<in>set xs. l \<le> f y"
	+ have "lsteps (x # xs) f l up left + l * up = lsteps xs f l up left + f x * up + left"
	+ using a by (auto simp add: lsteps.simps)
	+ also have "lsteps xs f l up left + f x * up \<le> left * length xs + up * Max (f ` set xs \<union> {0})"
	+ using a 2 by blast
	+ also have "up * Max (f ` set xs \<union> {0}) \<le> up * Max (insert (f x) (f ` set xs))"
	+ by simp
	+ finally show ?case
	+ by auto
	+ next
	+ assume a: "f x = l" "\<not> (\<exists>y\<in>set xs. l \<le> f y)"
	+ have "lsteps (x # xs) f l up left + l * up = lsteps xs f l up left + f x * up + left"
	+ using a by (auto simp add: lsteps.simps)
	+ also have "lsteps xs f l up left = 0"
	+ using a by (subst lsteps_level_greater_fun_image) auto
	+ also have "f x * up \<le> up * Max (insert (f x) (f ` set xs))"
	+ by simp
	+ finally show ?case
	+ by simp
	+ next
	+ assume a: "f x < l"
	+ then have "lsteps (x # xs) f l up left = lsteps xs f l up left"
	+ by (auto simp add: lsteps.simps)
	+ also have "\<dots> + l * up \<le> left * length (x # xs) + up * Max (insert 0 (f ` set xs))"
	+ using a 2 by auto
	+ also have "Max (insert 0 (f ` set xs)) \<le> Max (f ` set (x # xs) \<union> {0})"
	+ by simp
	+ finally show ?case
	+ by simp
	+ next
	+ assume "f x > l"
	+ then show ?case
	+ using 2 by (subst lsteps.simps) auto
	+ qed
	+qed
	+
	+lemma steps_smaller_card_Max_fun':
	+ assumes "finite A" "\<exists>x\<in>A. l \<le> f x"
	+ shows "steps A f l up left + l * up \<le> left * card A + up * Max\<^sub>0 (f ` A)"
	+proof -
	+ let ?xs = "rev (sorted_list_of_set A)"
	+ have "steps A f l up left = lsteps (rev (sorted_list_of_set A)) f l up left"
	+ using steps_lsteps by blast
	+ also have "\<dots> + l * up \<le> left * length ?xs + up * Max (f ` set ?xs \<union> {0})"
	+ using assms by (intro lsteps_smaller_card_Max_fun') auto
	+ also have "left * length ?xs = left * card A"
	+ using assms sorted_list_of_set_length by (auto)
	+ also have "set ?xs = A"
	+ using assms by (auto)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma lsteps_height:
	+ assumes "\<exists>x \<in> set xs. l \<le> f x"
	+ shows "lsteps xs f l up 0 + up * l = up * Max\<^sub>0 (f ` (set xs))"
	+ using assms proof (induction xs f l up "0::nat" rule: lsteps.induct)
	+ case (2 x xs f l up)
	+ consider "l = f x" "\<exists>y\<in>set xs. l \<le> f y" \| "f x = l" "\<not> (\<exists>y\<in>set xs. l \<le> f y)" \|
	+ "f x < l" \| "l < f x"
	+ by fastforce
	+ then show ?case
	+ proof cases
	+ assume 0: "l = f x" "\<exists>y\<in>set xs. l \<le> f y"
	+ then have 1: "set xs \<noteq> {}"
	+ using 2 by auto
	+ then have "\<exists>xa\<in>set xs. f x \<le> f xa"
	+ using 0 2 by force
	+ then have "f x \<le> Max (f ` set xs)"
	+ using 0 2 by (subst Max_ge_iff) auto
	+ then have "max (f x) (Max (f ` set xs)) = (Max (f ` set xs))"
	+ using 0 2 by (auto intro!: simp add: max_def)
	+ then show ?case
	+ using 0 1 2 by (subst lsteps.simps) (auto)
	+ next
	+ assume 0: "f x = l" "\<not> (\<exists>y\<in>set xs. l \<le> f y)"
	+ then have "Max (insert l (f ` set xs)) = l"
	+ by (intro Max_eqI) (auto)
	+ moreover have "lsteps xs f l up 0 = 0"
	+ using 0 by (subst lsteps_level_greater_fun_image) auto
	+ ultimately show ?case
	+ using 0 by (subst lsteps.simps) auto
	+ next
	+ assume 0: "f x < l"
	+ then have 1: "set xs \<noteq> {}"
	+ using 2 by auto
	+ then have "\<exists>xa\<in>set xs. f x \<le> f xa"
	+ using 0 2 by force
	+ then have " f x \<le> Max (f ` set xs)"
	+ using 0 2 by (subst Max_ge_iff) auto
	+ then have "max (f x) (Max (f ` set xs)) = Max (f ` set xs)"
	+ using 0 2 by (auto intro!: simp add: max_def)
	+ then show ?case
	+ using 0 1 2 by (subst lsteps.simps) (auto)
	+ next
	+ assume "f x > l"
	+ then show ?case
	+ using 2 by (subst lsteps.simps) auto
	+ qed
	+qed (simp)
	+
	+lemma steps_height:
	+ assumes "finite A"
	+ shows "steps A f 0 up 0 = up * Max\<^sub>0 (f ` A)"
	+proof -
	+ have "steps A f 0 up 0 = lsteps (rev (sorted_list_of_set A)) f 0 up 0 + up * 0"
	+ by (subst steps_lsteps) simp
	+ also have "\<dots> = up * Max (f ` A \<union> {0})" if "A \<noteq> {}"
	+ using assms that by (subst lsteps_height) auto
	+ finally show ?thesis
	+ using assms by (cases "A = {}") (auto)
	+qed
	+
	+context random_skip_list
	+begin
	+
	+text \<open>
	+ We can now define the pmf describing the length of the search path in a skip list.
	+ Like the height it only depends on the number of elements in the skip list's underlying set.
	+\<close>
	+
	+definition R where "R A u l = map_pmf (\<lambda>f. steps A f 0 u l) (SL A)"
	+definition R\<^sub>N :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat pmf" where "R\<^sub>N n u l = R {..<n} u l"
	+
	+
	+lemma R\<^sub>N_alt_def: "R\<^sub>N n u l = map_pmf (\<lambda>f. steps {..<n} f 0 u l) (SL\<^sub>N n)"
	+ unfolding SL\<^sub>N_def R\<^sub>N_def R_def by simp
	+
	+context includes monad_normalisation
	+begin
	+
	+lemma R_R\<^sub>N:
	+ assumes "finite A" "p \<in> {0..1}"
	+ shows "R A u l = R\<^sub>N (card A) u l"
	+proof -
	+ let ?steps = "\<lambda>A f. steps A f 0 u l"
	+ let ?f' = "bij_mono_map_set_to_nat A"
	+ have "R A u l = SL A \<bind> (\<lambda>f. return_pmf (?steps A f))"
	+ unfolding R_def map_pmf_def by simp
	+ also have "\<dots> = SL\<^sub>N (card A) \<bind> (\<lambda>f. return_pmf (?steps A (f \<circ> ?f')))"
	+ proof -
	+ have "?f' x \<notin> {..<card A}" if "x \<notin> A" for x
	+ using that unfolding bij_mono_map_set_to_nat_def by (auto)
	+ then show ?thesis
	+ using assms bij_mono_map_set_to_nat unfolding SL_def SL\<^sub>N_def
	+ by (subst Pi_pmf_bij_betw[of _ ?f' "{..<card A}"])
	+ (auto simp add: map_pmf_def)
	+ qed
	+ also have "\<dots> = SL\<^sub>N (card A) \<bind> (\<lambda>f. return_pmf (?steps {..<card A} f))"
	+ using assms bij_mono_map_set_to_nat bij_betw_def by (subst steps_image) (fastforce)+
	+ finally show ?thesis
	+ unfolding R\<^sub>N_def R_def SL\<^sub>N_def SL_def by (simp add: map_pmf_def)
	+qed
	+
	+text \<open>
	+ @{const R\<^sub>N} fulfills a recurrence relation. If we move up or to the left the ``remaining'' length of the
	+ search path is again a slightly different probability distribution over the length.
	+\<close>
	+
	+lemma R\<^sub>N_recurrence:
	+ assumes "0 < n" "p \<in> {0<..1}"
	+ shows "R\<^sub>N n u l =
	+ do {
	+ b \<leftarrow> bernoulli_pmf p;
	+ if b then \<comment> \<open>leftwards\<close>
	+ map_pmf (\<lambda>n. n + l) (R\<^sub>N (n - 1) u l)
	+ else do { \<comment> \<open>upwards\<close>
	+ m \<leftarrow> binomial_pmf (n - 1) (1 - p);
	+ map_pmf (\<lambda>n. n + u) (R\<^sub>N (m + 1) u l)
	+ }
	+ }"
	+proof -
	+ define B where "B = (\<lambda>b. insert (n-1) {x \<in> {..<n - 1}. \<not> b x})"
	+ have "R\<^sub>N n u l = map_pmf (\<lambda>f. steps {..<n} f 0 u l) (SL\<^sub>N n)"
	+ by (auto simp add: R\<^sub>N_def R_def SL\<^sub>N_def)
	+ also have "\<dots> = map_pmf (\<lambda>f. steps {..<n} f 0 u l)
	+ (map_pmf (\<lambda>(y, f). f(n-1 := y)) (pair_pmf (geometric_pmf p) (SL\<^sub>N (n - 1))))"
	+ proof -
	+ have "{..<n} = insert (n - Suc 0) {..<n - 1}"
	+ using assms by force
	+ then have "(Pi_pmf {..<n} 0 (\<lambda>_. geometric_pmf p)) =
	+ map_pmf (\<lambda>(y, f). f(n - 1 := y)) (pair_pmf (geometric_pmf p)
	+ (Pi_pmf {..<n-1} 0 (\<lambda>_. geometric_pmf p)))"
	+ using assms
	+ by (subst Pi_pmf_insert[of "{..<n-1}" "n-1" 0 "\<lambda>_. geometric_pmf p", symmetric]) (auto)
	+ then show ?thesis
	+ by (simp add: SL\<^sub>N_def SL_def)
	+ qed
	+ also have "\<dots> =
	+ do { g \<leftarrow> geometric_pmf p;
	+ f \<leftarrow> SL\<^sub>N (n - 1);
	+ return_pmf (steps {..<n} (f(n - 1 := g)) 0 u l)}"
	+ by (simp add: case_prod_beta map_pmf_def pair_pmf_def)
	+ also have "\<dots> =
	+ do { b \<leftarrow> bernoulli_pmf p;
	+ g \<leftarrow> if b then return_pmf 0 else map_pmf Suc (geometric_pmf p);
	+ f \<leftarrow> SL\<^sub>N (n - 1);
	+ return_pmf (steps {..<n} (f(n - 1 := g)) 0 u l)}"
	+ using assms by (subst geometric_bind_pmf_unfold) (auto)
	+ also have "\<dots> =
	+ do { b \<leftarrow> bernoulli_pmf p;
	+ if b
	+ then do { g \<leftarrow> return_pmf 0;
	+ f \<leftarrow> SL\<^sub>N (n - 1);
	+ return_pmf (steps {..<n} (f(n - 1 := g)) 0 u l) }
	+ else do { g \<leftarrow> map_pmf Suc (geometric_pmf p);
	+ f \<leftarrow> SL\<^sub>N (n - 1);
	+ return_pmf (steps {..<n} (f(n - 1 := g)) 0 u l) }}"
	+ by (subst bind_pmf_if') (auto)
	+ also have "do { g \<leftarrow> return_pmf 0;
	+ f \<leftarrow> SL\<^sub>N (n - 1);
	+ return_pmf (steps {..<n} (f(n - 1 := g)) 0 u l) } =
	+ do { f \<leftarrow> SL\<^sub>N (n - 1);
	+ return_pmf (steps {..<n} (f(n - 1 := 0)) 0 u l) }"
	+ by (subst bind_return_pmf) auto
	+ also have "\<dots> = map_pmf (\<lambda>n. n + l) (map_pmf (\<lambda>f. steps {..<n - 1} f 0 u l) (SL\<^sub>N (n - 1)))"
	+ proof -
	+ have I: "{..<n} - {n - Suc 0} = {..<n - Suc 0}"
	+ by fastforce
	+ have "Max {..<n} = n - Suc 0"
	+ using assms by (intro Max_eqI) (auto)
	+ then have "steps {..<n} (f(n - 1 := 0)) 0 u l = l + steps {..<n - 1} f 0 u l" for f
	+ using assms by (subst steps.simps) (auto intro!: steps_cong simp add: I simp add: Let_def)
	+ then show ?thesis
	+ by (auto simp add: add_ac map_pmf_def)
	+ qed
	+ also have "\<dots> = map_pmf (\<lambda>n. n + l) (R\<^sub>N (n - 1) u l)"
	+ unfolding R\<^sub>N_def R_def SL\<^sub>N_def by simp
	+ also have "map_pmf Suc (geometric_pmf p) \<bind>
	+ (\<lambda>g. SL\<^sub>N (n - 1) \<bind>
	+ (\<lambda>f. return_pmf (steps {..<n} (f(n - 1 := g)) 0 u l)))
	+ =
	+ Pi_pmf {..<n - 1} True (\<lambda>_. bernoulli_pmf p) \<bind>
	+ (\<lambda>b. map_pmf Suc (geometric_pmf p) \<bind>
	+ (\<lambda>g. Pi_pmf {x \<in> {..<n - 1}. \<not> b x} 0 (\<lambda>_. map_pmf Suc (geometric_pmf p)) \<bind>
	+ (\<lambda>f. return_pmf (steps {..<n} (f(n - 1 := g)) 0 u l))))"
	+ using assms unfolding SL\<^sub>N_def SL_def by (subst Pi_pmf_geometric_filter) (auto)
	+ also have "\<dots> =
	+ do {
	+ b \<leftarrow> Pi_pmf {..<n - 1} True (\<lambda>_. bernoulli_pmf p);
	+ f \<leftarrow> Pi_pmf (insert (n-1) {x \<in> {..<n - 1}. \<not> b x}) 0 (\<lambda>_. map_pmf Suc (geometric_pmf p));
	+ return_pmf (steps {..<n} f 0 u l)}" (is "_ = ?rhs")
	+ using assms by (subst Pi_pmf_insert') (auto)
	+ also have "\<dots> =
	+ do {
	+ b \<leftarrow> Pi_pmf {..<n - 1} True (\<lambda>_. bernoulli_pmf p);
	+ f \<leftarrow> Pi_pmf (B b) 1 (\<lambda>_. map_pmf Suc (geometric_pmf p));
	+ return_pmf (steps {..<n} (\<lambda>x. if x \<in> (B b) then f x else 0) 0 u l)}"
	+ by (subst Pi_pmf_default_swap[symmetric, of _ _ _ 1]) (auto simp add: map_pmf_def B_def)
	+ also have "\<dots> =
	+ do {
	+ b \<leftarrow> Pi_pmf {..<n - 1} True (\<lambda>_. bernoulli_pmf p);
	+ f \<leftarrow> SL (B b);
	+ return_pmf (steps {..<n} (\<lambda>x. if x \<in> (B b) then Suc (f x) else 0) 0 u l)}"
	+ proof -
	+ have *: "(Suc \<circ> f) x = Suc (f x)" for x and f::"nat \<Rightarrow> nat"
	+ by simp
	+ have "(\<lambda>f. return_pmf (steps {..<n} (\<lambda>x. if x \<in> B b then (Suc \<circ> f) x else 0) 0 u l)) =
	+ (\<lambda>f. return_pmf (steps {..<n} (\<lambda>x. if x \<in> B b then Suc (f x) else 0) 0 u l))" for b
	+ by (subst *) (simp)
	+ then show ?thesis
	+ by (subst Pi_pmf_map[of _ _ 0]) (auto simp add: map_pmf_def B_def SL_def)
	+ qed
	+ also have "\<dots> =
	+ do {
	+ b \<leftarrow> Pi_pmf {..<n - 1} True (\<lambda>_. bernoulli_pmf p);
	+ r \<leftarrow> R (B b) u l;
	+ return_pmf (u + r)}"
	+ proof -
	+ have "steps {..<n} (\<lambda>x. if x \<in> B b then Suc (f x) else 0) 0 u l = u + steps (B b) f 0 u l"
	+ for f b
	+ proof -
	+ have "Max {..<n} = n - 1"
	+ using assms by (intro Max_eqI) auto
	+ then have "steps {..<n} (\<lambda>x. if x \<in> B b then Suc (f x) else 0) 0 u l =
	+ u + (steps {..<n} (\<lambda>x. if x \<in> (B b) then Suc (f x) else 0) 1 u l)"
	+ unfolding B_def using assms by (subst steps.simps) (auto simp add: Let_def)
	+ also have "steps {..<n} (\<lambda>x. if x \<in> (B b) then Suc (f x) else 0) 1 u l =
	+ steps (B b) (\<lambda>x. if x \<in> (B b) then Suc (f x) else 0) 1 u l"
	+ proof -
	+ have "{x \<in> {..<n}. 1 \<le> (if x \<in> B b then Suc (f x) else 0)} = B b"
	+ using assms unfolding B_def by force
	+ then show ?thesis
	+ by (subst steps_smaller_set[of _ 1]) auto
	+ qed
	+ also have "\<dots> = steps (B b) (\<lambda>x. f x + 1) 1 u l"
	+ by (rule steps_cong) (auto)
	+ also have "\<dots> = steps (B b) f 0 u l"
	+ by (subst (2) steps_f_add'[of _ _ _ _ _ 1]) simp
	+ finally show ?thesis
	+ by auto
	+ qed
	+ then show ?thesis
	+ by (simp add: R_def map_pmf_def)
	+ qed
	+ also have "\<dots> = do {
	+ b \<leftarrow> Pi_pmf {..<n - 1} False (\<lambda>_. bernoulli_pmf (1 - p));
	+ let m = 1 + card {x. x < n - 1 \<and> b x};
	+ r \<leftarrow> R {..<m} u l;
	+ return_pmf (u + r)}"
	+ proof -
	+ have *: "card (insert (n - Suc 0) {x. x < n - 1 \<and> b x}) =
	+ (Suc (card {x. x < n - 1 \<and> b x}))" for b
	+ using assms by (auto simp add: card_insert_if)
	+ have "Pi_pmf {..<n - 1} True (\<lambda>_. bernoulli_pmf p) =
	+ Pi_pmf {..<n - 1} True (\<lambda>_. map_pmf Not (bernoulli_pmf (1 - p)))"
	+ using assms by (subst bernoulli_pmf_Not) auto
	+ also have "\<dots> = map_pmf ((\<circ>) Not) (Pi_pmf {..<n - 1} False (\<lambda>_. bernoulli_pmf (1 - p)))"
	+ using assms by (subst Pi_pmf_map[of _ _ False]) auto
	+ finally show ?thesis
	+ unfolding B_def using assms *
	+ by (subst R_R\<^sub>N) (auto simp add: R_R\<^sub>N map_pmf_def)
	+ qed
	+ also have "\<dots> = binomial_pmf (n - 1) (1 - p) \<bind> (\<lambda>m. map_pmf (\<lambda>n. n + u) (R\<^sub>N (m + 1) u l))"
	+ using assms
	+ by (subst binomial_pmf_altdef'[where A = "{..<n - 1}" and dflt = "False"])
	+ (auto simp add: R\<^sub>N_def R_def SL_def map_pmf_def ac_simps)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+end (* context includes monad_normalisation *)
	+
	+text \<open>
	+ The expected height and length of search path defined as non-negative integral. It's easier
	+ to prove the recurrence relation of the expected length of the search path using non-negative
	+ integrals.
	+\<close>
	+
	+definition NH\<^sub>N where "NH\<^sub>N n = nn_integral (H\<^sub>N n) real"
	+definition NR\<^sub>N where "NR\<^sub>N n u l = nn_integral (R\<^sub>N n u l) real"
	+
	+lemma NH\<^sub>N_EH\<^sub>N:
	+ assumes "p \<in> {0<..<1}"
	+ shows "NH\<^sub>N n = EH\<^sub>N n"
	+ using assms EH\<^sub>N_bounds unfolding EH\<^sub>N_def NH\<^sub>N_def by (subst nn_integral_eq_integral) (auto)
	+
	+lemma R\<^sub>N_0 [simp]: "R\<^sub>N 0 u l = return_pmf 0"
	+ unfolding R\<^sub>N_def R_def SL_def by (auto simp add: steps.simps)
	+
	+lemma NR\<^sub>N_bounds:
	+ fixes u l::nat
	+ shows "NR\<^sub>N n u l \<le> l * n + u * NH\<^sub>N n"
	+proof -
	+ have "NR\<^sub>N n u l = \<integral>\<^sup>+ x. x \<partial>measure_pmf (R\<^sub>N n u l)"
	+ unfolding NR\<^sub>N_def R\<^sub>N_alt_def
	+ by (simp add: ennreal_of_nat_eq_real_of_nat)
	+ also have "\<dots> \<le> \<integral>\<^sup>+ x. x \<partial>(measure_pmf (map_pmf (\<lambda>f. l * n + u * Max\<^sub>0 (f ` {..<n})) (SL\<^sub>N n)))"
	+ using of_nat_mono[OF steps_smaller_card_Max_fun'[of "{..<n}" 0 _ u l]] unfolding R\<^sub>N_alt_def
	+ by (cases "n = 0") (auto intro!: nn_integral_mono)
	+ also have "\<dots> = l * n + u * NH\<^sub>N n"
	+ unfolding NH\<^sub>N_def H\<^sub>N_def H_def SL\<^sub>N_def
	+ by (auto simp add: nn_integral_add nn_integral_cmult ennreal_of_nat_eq_real_of_nat ennreal_mult)
	+ finally show "NR\<^sub>N n u l \<le> l * n + u * NH\<^sub>N n"
	+ by simp
	+qed
	+
	+lemma NR\<^sub>N_recurrence:
	+ assumes "0 < n" "p \<in> {0<..<1}"
	+ shows "NR\<^sub>N n u l = (p * (l + NR\<^sub>N (n - 1) u l) +
	+ q * (u + (\<Sum>k<n - 1. NR\<^sub>N (k + 1) u l * (pmf (binomial_pmf (n - 1) q) k))))
	+ / (1 - (q ^ n))"
	+proof -
	+ define B where "B = (\<lambda>n k. pmf (binomial_pmf n q) k)"
	+ have q: "q \<in> {0<..<1}"
	+ using assms unfolding q_def by auto
	+ then have "q ^ n < 1"
	+ using assms power_Suc_less_one by (induction n) (auto)
	+ then have qn: "q ^ n \<in> {0<..<1}"
	+ using assms q by (auto)
	+ have "NR\<^sub>N n u l = p * (l + NR\<^sub>N (n - 1) u l) +
	+ q * (u + \<integral>\<^sup>+ k. NR\<^sub>N (k + 1) u l \<partial>measure_pmf (binomial_pmf (n - 1) q))"
	+ using assms unfolding NR\<^sub>N_def
	+ by(subst R\<^sub>N_recurrence)
	+ (auto simp add: field_simps nn_integral_add q_def ennreal_of_nat_eq_real_of_nat)
	+ also have "(\<integral>\<^sup>+ m. NR\<^sub>N (m + 1) u l \<partial>measure_pmf (binomial_pmf (n - 1) q)) =
	+ (\<Sum>k\<le>n - 1. NR\<^sub>N (k + 1) u l * B (n - 1) k)"
	+ using assms unfolding B_def q_def
	+ by (auto simp add: nn_integral_measure_pmf_finite)
	+ also have "\<dots> = (\<Sum>k\<in>{..<n - 1} \<union> {n - 1}. NR\<^sub>N (k + 1) u l * B (n - 1) k)"
	+ by (rule sum.cong) (auto)
	+ also have "\<dots> = (\<Sum>k<n - 1. NR\<^sub>N (k + 1) u l * B (n - 1) k) + NR\<^sub>N n u l * q ^ (n - 1)"
	+ unfolding B_def q_def using assms by (subst sum.union_disjoint) (auto)
	+ finally have "NR\<^sub>N n u l = p * (l + NR\<^sub>N (n - 1) u l) +
	+ q * ((\<Sum>k<n - 1. NR\<^sub>N (k + 1) u l * B (n - 1) k) + u) +
	+ NR\<^sub>N n u l * (q ^ (n - 1)) * q"
	+ using assms by (auto simp add: field_simps numerals)
	+ also have "NR\<^sub>N n u l * (q ^ (n - 1)) * q = (q ^ n) * NR\<^sub>N n u l"
	+ using q power_minus_mult[of _ q] assms
	+ by (subst mult_ac, subst ennreal_mult[symmetric], auto simp add: mult_ac)
	+ finally have 1: "NR\<^sub>N n u l = p * (l + NR\<^sub>N (n - 1) u l) +
	+ q * (u + (\<Sum>k<n - 1. NR\<^sub>N (k + 1) u l * (B (n - 1) k))) +
	+ (q ^ n) * NR\<^sub>N n u l "
	+ by (simp add: add_ac)
	+ have "x - z = y" if "x = y + z" "z \<noteq> \<top>" for x y z::ennreal
	+ using that by (subst that) (auto)
	+ have "NR\<^sub>N n u l \<le> l * n + u * NH\<^sub>N n"
	+ using NR\<^sub>N_bounds by (auto simp add: ennreal_of_nat_eq_real_of_nat)
	+ also have "NH\<^sub>N n = EH\<^sub>N n"
	+ using assms NH\<^sub>N_EH\<^sub>N by auto
	+ also have "(l * n) + u * ennreal (EH\<^sub>N n) < \<top>"
	+ by (simp add: ennreal_mult_less_top of_nat_less_top)
	+ finally have 3: "NR\<^sub>N n u l \<noteq> \<top>"
	+ by simp
	+ have 2: "x = y / (1 - a)" if "x = y + a * x" and t: "x \<noteq> \<top>" "a \<in> {0<..<1}" for x y::ennreal
	+ and a::real
	+ proof -
	+ have "y = x - a * x"
	+ using t by (subst that) (auto simp add: ennreal_mult_eq_top_iff)
	+ also have "\<dots> = x * (ennreal 1 - ennreal a)"
	+ using that by (auto simp add: mult_ac ennreal_right_diff_distrib)
	+ also have "ennreal 1 - ennreal a = ennreal (1 - a)"
	+ using that by (subst ennreal_minus) (auto)
	+ also have "x * (1 - a) / (1 - a) = x"
	+ using that ennreal_minus_eq_0 not_less by (subst mult_divide_eq_ennreal) auto
	+ finally show ?thesis
	+ by simp
	+ qed
	+ have "NR\<^sub>N n u l = (p * (l + NR\<^sub>N (n - 1) u l) +
	+ q * (u + (\<Sum>k<n - 1. NR\<^sub>N (k + 1) u l * (B (n - 1) k))))
	+ / (1 - (q ^ n))"
	+ using 1 3 assms qn by (intro 2) auto
	+ then show ?thesis
	+ unfolding B_def by simp
	+qed
	+
	+lemma NR\<^sub>n_NH\<^sub>N: "NR\<^sub>N n u 0 = u * NH\<^sub>N n"
	+proof -
	+ have "NR\<^sub>N n u 0 = \<integral>\<^sup>+ f. steps {..<n} f 0 u 0 \<partial>measure_pmf (SL\<^sub>N n)"
	+ unfolding NR\<^sub>N_def R\<^sub>N_alt_def by (auto simp add: ennreal_of_nat_eq_real_of_nat)
	+ also have "\<dots> = \<integral>\<^sup>+ f. of_nat u * of_nat (Max\<^sub>0 (f ` {..<n})) \<partial>measure_pmf (SL\<^sub>N n)"
	+ by (intro nn_integral_cong) (auto simp add: steps_height)
	+ also have "\<dots> = u * NH\<^sub>N n"
	+ by (auto simp add: NH\<^sub>N_def H\<^sub>N_def H_def SL\<^sub>N_def ennreal_of_nat_eq_real_of_nat nn_integral_cmult)
	+ finally show ?thesis
	+ by simp
	+qed
	+
	+lemma NR\<^sub>N_recurrence':
	+ assumes "0 < n" "p \<in> {0<..<1}"
	+ shows "NR\<^sub>N n u l = (p * l + p * NR\<^sub>N (n - 1) u l +
	+ q * u + q * (\<Sum>k<n - 1. NR\<^sub>N (k + 1) u l * (pmf (binomial_pmf (n - 1) q) k)))
	+ / (1 - (q ^ n))"
	+ unfolding NR\<^sub>N_recurrence[OF assms]
	+ by (auto simp add: field_simps ennreal_of_nat_eq_real_of_nat ennreal_mult' ennreal_mult'')
	+
	+
	+lemma NR\<^sub>N_l_0:
	+ assumes "0 < n" "p \<in> {0<..<1}"
	+ shows "NR\<^sub>N n u 0 = (p * NR\<^sub>N (n - 1) u 0 +
	+ q * (u + (\<Sum>k<n - 1. NR\<^sub>N (k + 1) u 0 * (pmf (binomial_pmf (n - 1) q) k))))
	+ / (1 - (q ^ n))"
	+ unfolding NR\<^sub>N_recurrence[OF assms] by (simp)
	+
	+lemma NR\<^sub>N_u_0:
	+ assumes "0 < n" "p \<in> {0<..<1}"
	+ shows "NR\<^sub>N n 0 l = (p * (l + NR\<^sub>N (n - 1) 0 l) +
	+ q * (\<Sum>k<n - 1. NR\<^sub>N (k + 1) 0 l * (pmf (binomial_pmf (n - 1) q) k)))
	+ / (1 - (q ^ n))"
	+ unfolding NR\<^sub>N_recurrence[OF assms] by (simp)
	+
	+lemma NR\<^sub>N_0[simp]: "NR\<^sub>N 0 u l = 0"
	+ unfolding NR\<^sub>N_def R\<^sub>N_def R_def by (auto)
	+
	+lemma NR\<^sub>N_1:
	+ assumes "p \<in> {0<..<1}"
	+ shows "NR\<^sub>N 1 u l = (u * q + l * p) / p"
	+proof -
	+ have "NR\<^sub>N 1 u l = (ennreal p * of_nat l + ennreal q * of_nat u) / ennreal (1 - q)"
	+ using assms by (subst NR\<^sub>N_recurrence) auto
	+ also have "(ennreal p * of_nat l + ennreal q * of_nat u) = (u * q + l * p)"
	+ using assms q_def by (subst ennreal_plus)
	+ (auto simp add: field_simps ennreal_mult' ennreal_of_nat_eq_real_of_nat)
	+ also have "\<dots> / ennreal (1 - q) = ennreal ((u * q + l * p) / (1 - q))"
	+ using q_def assms by (intro divide_ennreal) auto
	+ finally show ?thesis
	+ unfolding q_def by simp
	+qed
	+
	+lemma NR\<^sub>N_NR\<^sub>N_l_0:
	+ assumes n: "0 < n" and p: "p \<in> {0<..<1}" and "u \<ge> 1"
	+ shows "NR\<^sub>N n u 0 = (u * q / (u * q + l * p)) * NR\<^sub>N n u l"
	+ using n proof (induction n rule: less_induct)
	+ case (less i)
	+ have 1: "0 < u * q"
	+ unfolding q_def using assms by simp
	+ moreover have "0 \<le> l * p"
	+ using assms by auto
	+ ultimately have 2: "0 < u * q + l * p"
	+ by arith
	+ define c where "c = ennreal (u * q / (u * q + l * p))"
	+ have [simp]: "c / c = 1"
	+ proof -
	+ have "u * q / (u * q + l * p) \<noteq> 0"
	+ using assms q_def 2 by auto
	+ then show ?thesis
	+ unfolding c_def using p q_def by (auto intro!: ennreal_divide_self)
	+ qed
	+ show ?case
	+ proof (cases "i = 1")
	+ case True
	+ have "c * NR\<^sub>N i u l = c * ((u * q + l * p) / p)"
	+ unfolding c_def True by (subst NR\<^sub>N_1[OF p]) auto
	+ also have "\<dots> = ennreal ((u * q / (u * q + l * p)) * ((u * q + l * p) / p))"
	+ unfolding c_def using assms q_def by (subst ennreal_mult'') auto
	+ also have "(u * q / (u * q + l * p)) * ((u * q + l * p) / p) = u * q / p"
	+ proof -
	+ have I: "(a / b) * (b / c) = a / c" if "0 < b" for a b c::"real"
	+ using that by (auto)
	+ show ?thesis
	+ using 2 q_def by (intro I) auto
	+ qed
	+ also have "\<dots> = NR\<^sub>N i u 0"
	+ unfolding True c_def by (subst NR\<^sub>N_1[OF p]) (auto)
	+ finally show ?thesis
	+ unfolding c_def using True by simp
	+ next
	+ case False
	+ then have i: "i > 1"
	+ using less by auto
	+ define c where "c = ennreal (u * q / (u * q + l * p))"
	+ define B where "B = (\<Sum>k<i - 1. NR\<^sub>N (k + 1) u l * ennreal (pmf (binomial_pmf (i - 1) q) k))"
	+ have "NR\<^sub>N i u 0 = (p * NR\<^sub>N (i - 1) u 0 +
	+ q * (u + (\<Sum>k<i - 1. NR\<^sub>N (k + 1) u 0 * (pmf (binomial_pmf (i - 1) q) k))))
	+ / (1 - (q ^ i))"
	+ using less assms by (subst NR\<^sub>N_l_0) auto
	+ also have "q * (u + (\<Sum>k<i - 1. NR\<^sub>N (k + 1) u 0 * (pmf (binomial_pmf (i - 1) q) k))) =
	+ q * u + q * (\<Sum>k<i - 1. NR\<^sub>N (k + 1) u 0 * (pmf (binomial_pmf (i - 1) q) k))"
	+ using assms q_def
	+ by (auto simp add: field_simps ennreal_of_nat_eq_real_of_nat ennreal_mult)
	+ also have "NR\<^sub>N (i - 1) u 0 = c * NR\<^sub>N (i - 1) u l"
	+ unfolding c_def using less i by (intro less) (auto)
	+ also have "(\<Sum>k<i - 1. NR\<^sub>N (k + 1) u 0 * ennreal (pmf (binomial_pmf (i - 1) q) k)) =
	+ (\<Sum>k<i - 1. c * NR\<^sub>N (k + 1) u l * ennreal (pmf (binomial_pmf (i - 1) q) k))"
	+ by (auto intro!: sum.cong simp add: less c_def)
	+ also have "\<dots> = c * B"
	+ unfolding B_def by (subst sum_distrib_left) (auto intro!: sum.cong mult_ac)
	+ also have "q * (c * B) = c * (q * B)"
	+ by (simp add: mult_ac)
	+ also have "ennreal (q * real u) = q * u * ((u * q + l * p) / (u * q + l * p))"
	+ using assms 2 by (auto simp add: field_simps q_def)
	+ also have "\<dots> = c * (real u * q + real l * p)"
	+ unfolding c_def using 2 by (subst ennreal_mult''[symmetric]) (auto simp add: mult_ac)
	+ also have "c * ennreal (real u * q + real l * p) + c * (ennreal q * B) =
	+ c * (ennreal (real u * q + real l * p) + (ennreal q * B))"
	+ by (auto simp add: field_simps)
	+ also have "ennreal p * (c * NR\<^sub>N (i - 1) u l) = c * (ennreal p * NR\<^sub>N (i - 1) u l)"
	+ by (simp add: mult_ac)
	+ also have "(c * (ennreal p * NR\<^sub>N (i - 1) u l) + c * (ennreal (u * q + l * p) + ennreal q * B))
	+ = c * ((ennreal p * NR\<^sub>N (i - 1) u l) + (ennreal (u * q + l * p) + ennreal q * B))"
	+ by (auto simp add: field_simps)
	+ also have " c * (ennreal p * NR\<^sub>N (i - 1) u l + (ennreal (u * q + l * p) + ennreal q * B)) / ennreal (1 - q ^ i)
	+ = c * ((ennreal p * NR\<^sub>N (i - 1) u l + (ennreal (u * q + l * p) + ennreal q * B)) / ennreal (1 - q ^ i))"
	+ by (auto simp add: ennreal_times_divide)
	+ also have "(ennreal p * NR\<^sub>N (i - 1) u l + (ennreal (real u * q + real l * p) + ennreal q * B)) / ennreal (1 - q ^ i)
	+ = NR\<^sub>N i u l"
	+ apply(subst (2) NR\<^sub>N_recurrence')
	+ using i assms q_def by
	+ (auto simp add: field_simps B_def ennreal_of_nat_eq_real_of_nat ennreal_mult' ennreal_mult'')
	+ finally show ?thesis
	+ unfolding c_def by simp
	+ qed
	+qed
	+
	+text \<open>
	+ Assigning 1 as the cost for going up and/or left, we can now show the relation between the
	+ expected length of the reverse search path and the expected height.
	+\<close>
	+
	+definition EL\<^sub>N where "EL\<^sub>N n = measure_pmf.expectation (R\<^sub>N n 1 1) real"
	+
	+
	+theorem EH\<^sub>N_EL\<^sub>s\<^sub>p:
	+ assumes "p \<in> {0<..<1}"
	+ shows "1 / q * EH\<^sub>N n = EL\<^sub>N n"
	+proof -
	+ have 1: "ennreal (1 / y * x) = r" if "ennreal x = y * r" "x \<ge> 0" "y > 0"
	+ for x y::real and r::ennreal
	+ proof -
	+ have "ennreal ((1 / y) * x) = ennreal (1 / y) * ennreal x"
	+ using that apply(subst ennreal_mult'') by auto
	+ also note that(1)
	+ also have "ennreal (1 / y) * (ennreal y * r) = ennreal ((1 / y) * y) * r"
	+ using that by (subst ennreal_mult'') (auto simp add: mult_ac)
	+ also have "(1 / y) * y = 1"
	+ using that by (auto)
	+ finally show ?thesis
	+ by auto
	+ qed
	+ have "EH\<^sub>N n = NH\<^sub>N n"
	+ using NH\<^sub>N_EH\<^sub>N assms by auto
	+ also have "NH\<^sub>N n = NR\<^sub>N n 1 0"
	+ using NR\<^sub>n_NH\<^sub>N by auto
	+ also have "NR\<^sub>N n 1 0 = q * NR\<^sub>N n 1 1" if "n > 0"
	+ using NR\<^sub>N_NR\<^sub>N_l_0[of _ 1 1] that assms q_def by force
	+ finally have "ennreal (EH\<^sub>N n) = q * NR\<^sub>N n 1 1" if "n > 0"
	+ using that by blast
	+ then have "1 / q * EH\<^sub>N n = NR\<^sub>N n 1 1" if "n > 0"
	+ using that assms q_def by (intro 1) (auto simp add: EH\<^sub>N_def H\<^sub>N_def H_def)
	+ moreover have "1 / q * EH\<^sub>N n = NR\<^sub>N n 1 1" if "n = 0"
	+ unfolding that by (auto simp add: EH\<^sub>N_def H\<^sub>N_def H_def)
	+ ultimately have 2: "ennreal (1 / q * EH\<^sub>N n) = NR\<^sub>N n 1 1"
	+ by blast
	+ also have "NR\<^sub>N n 1 1 = EL\<^sub>N n"
	+ using 2 assms EH\<^sub>N_bounds unfolding EL\<^sub>N_def NR\<^sub>N_def
	+ by(subst nn_integral_eq_integral)
	+ (auto intro!: integrableI_nn_integral_finite[where x="EH\<^sub>N n / q"])
	+ finally show ?thesis
	+ using assms q_def ennreal_inj unfolding EL\<^sub>N_def EH\<^sub>N_def H\<^sub>N_def H_def SL_def
	+ by (auto)
	+qed
	+
	+end (* context random_skip_list *)
	+
	+thm random_skip_list.EH\<^sub>N_EL\<^sub>s\<^sub>p[unfolded random_skip_list.q_def]
	+ random_skip_list.EH\<^sub>N_bounds'[unfolded random_skip_list.q_def]
	+
	+
	+end
	diff --git a/thys/Skip_Lists/document/root.bib b/thys/Skip_Lists/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Skip_Lists/document/root.bib
	@@ -0,0 +1,15 @@
	+@inproceedings{pugh1989skip,
	+author = {Pugh, William},
	+booktitle = {Workshop on Algorithms and Data Structures},
	+organization = {Springer},
	+pages = {437--449},
	+title = {{Skip lists: A probabilistic alternative to balanced trees}},
	+year = {1989}
	+}
	+@book{motwani1995,
	+ title={Randomized algorithms},
	+ author={Motwani, Rajeev and Raghavan, Prabhakar},
	+ year={1995},
	+ publisher={Cambridge university press}
	+}
	+
	diff --git a/thys/Skip_Lists/document/root.tex b/thys/Skip_Lists/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Skip_Lists/document/root.tex
	@@ -0,0 +1,42 @@
	+\documentclass[11pt,a4paper]{article}
	+\usepackage{isabelle,isabellesym}
	+\usepackage{amsfonts, 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{Randomised Skip Lists}
	+\author{Max W. Haslbeck, Manuel Eberl}
	+\maketitle
	+
	+\begin{abstract}
	+Skip lists are sorted linked lists enhanced with shortcuts and are an alternative to binary search trees \cite{pugh1989skip}.
	+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 \emph{skipped} in such a way that a lookup in a skip lists takes $\mathcal{O}(\log{n})$ time.
	+In a randomised skip list the skipped elements are choosen randomly.
	+
	+This entry contains formalized proofs of the textbook results about the expected height and the expected length of a search path in a randomised skip list \cite{motwani1995}.
	+\end{abstract}
	+
	+\tableofcontents
	+\newpage
	+\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/Subset_Boolean_Algebras/ROOT b/thys/Subset_Boolean_Algebras/ROOT
	new file mode 100644
	--- /dev/null
	+++ b/thys/Subset_Boolean_Algebras/ROOT
	@@ -0,0 +1,13 @@
	+chapter AFP
	+
	+session Subset_Boolean_Algebras (AFP) = Stone_Algebras +
	+
	+ options [timeout = 600]
	+
	+ theories
	+ Subset_Boolean_Algebras
	+
	+ document_files
	+ "root.tex"
	+ "root.bib"
	+
	diff --git a/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy b/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy
	new file mode 100644
	--- /dev/null
	+++ b/thys/Subset_Boolean_Algebras/Subset_Boolean_Algebras.thy
	@@ -0,0 +1,3608 @@
	+(* Title: Subset Boolean Algebras
	+ Authors: Walter Guttmann, Bernhard Möller
	+ Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
	+*)
	+
	+theory Subset_Boolean_Algebras
	+
	+imports Stone_Algebras.P_Algebras
	+
	+begin
	+
	+section \<open>Boolean Algebras\<close>
	+
	+text \<open>
	+We show that Isabelle/HOL's \<open>boolean_algebra\<close> class is equivalent to Huntington's axioms \cite{Huntington1933}.
	+See \cite{WamplerDoty2016} for related results.
	+\<close>
	+
	+subsection \<open>Huntington's Axioms\<close>
	+
	+text \<open>Definition 1\<close>
	+
	+class huntington = sup + uminus +
	+ assumes associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ assumes commutative: "x \<squnion> y = y \<squnion> x"
	+ assumes huntington: "x = -(-x \<squnion> y) \<squnion> -(-x \<squnion> -y)"
	+begin
	+
	+lemma top_unique:
	+ "x \<squnion> -x = y \<squnion> -y"
	+proof -
	+ have "x \<squnion> -x = y \<squnion> -(--y \<squnion> -x) \<squnion> -(--y \<squnion> --x)"
	+ by (smt associative commutative huntington)
	+ thus ?thesis
	+ by (metis associative huntington)
	+qed
	+
	+end
	+
	+subsection \<open>Equivalence to \<open>boolean_algebra\<close> Class\<close>
	+
	+text \<open>Definition 2\<close>
	+
	+class extended = sup + inf + minus + uminus + bot + top + ord +
	+ assumes top_def: "top = (THE x . \<forall>y . x = y \<squnion> -y)" (* define without imposing uniqueness *)
	+ assumes bot_def: "bot = -(THE x . \<forall>y . x = y \<squnion> -y)"
	+ assumes inf_def: "x \<sqinter> y = -(-x \<squnion> -y)"
	+ assumes minus_def: "x - y = -(-x \<squnion> y)"
	+ assumes less_eq_def: "x \<le> y \<longleftrightarrow> x \<squnion> y = y"
	+ assumes less_def: "x < y \<longleftrightarrow> x \<squnion> y = y \<and> \<not> (y \<squnion> x = x)"
	+
	+class huntington_extended = huntington + extended
	+begin
	+
	+lemma top_char:
	+ "top = x \<squnion> -x"
	+ using top_def top_unique by auto
	+
	+lemma bot_char:
	+ "bot = -top"
	+ by (simp add: bot_def top_def)
	+
	+subclass boolean_algebra
	+proof
	+ show 1: "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
	+ by (simp add: less_def less_eq_def)
	+ show 2: "\<And>x. x \<le> x"
	+ proof -
	+ fix x
	+ have "x \<squnion> top = top \<squnion> --x"
	+ by (metis (full_types) associative top_char)
	+ thus "x \<le> x"
	+ by (metis (no_types) associative huntington less_eq_def top_char)
	+ qed
	+ show 3: "\<And>x y z. x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
	+ by (metis associative less_eq_def)
	+ show 4: "\<And>x y. x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
	+ by (simp add: commutative less_eq_def)
	+ show 5: "\<And>x y. x \<sqinter> y \<le> x"
	+ using 2 by (metis associative huntington inf_def less_eq_def)
	+ show 6: "\<And>x y. x \<sqinter> y \<le> y"
	+ using 5 commutative inf_def by fastforce
	+ show 8: "\<And>x y. x \<le> x \<squnion> y"
	+ using 2 associative less_eq_def by auto
	+ show 9: "\<And>y x. y \<le> x \<squnion> y"
	+ using 8 commutative by fastforce
	+ show 10: "\<And>y x z. y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
	+ by (metis associative less_eq_def)
	+ show 11: "\<And>x. bot \<le> x"
	+ using 8 by (metis bot_char huntington top_char)
	+ show 12: "\<And>x. x \<le> top"
	+ using 6 11 by (metis huntington bot_def inf_def less_eq_def top_def)
	+ show 13: "\<And>x y z. x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
	+ proof -
	+ have 2: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ by (simp add: associative)
	+ have 3: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
	+ using 2 by metis
	+ have 4: "\<And>x y . x \<squnion> y = y \<squnion> x"
	+ by (simp add: commutative)
	+ have 5: "\<And>x y . x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
	+ by (simp add: huntington)
	+ have 6: "\<And>x y . - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y) = x"
	+ using 5 by metis
	+ have 7: "\<And>x y . x \<sqinter> y = - (- x \<squnion> - y)"
	+ by (simp add: inf_def)
	+ have 10: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
	+ using 3 4 by metis
	+ have 11: "\<And>x y z . - (- x \<squnion> y) \<squnion> (- (- x \<squnion> - y) \<squnion> z) = x \<squnion> z"
	+ using 3 6 by metis
	+ have 12: "\<And>x y . - (x \<squnion> - y) \<squnion> - (- y \<squnion> - x) = y"
	+ using 4 6 by metis
	+ have 13: "\<And>x y . - (- x \<squnion> y) \<squnion> - (- y \<squnion> - x) = x"
	+ using 4 6 by metis
	+ have 14: "\<And>x y . - x \<squnion> - (- (- x \<squnion> y) \<squnion> - - (- x \<squnion> - y)) = - x \<squnion> y"
	+ using 6 by metis
	+ have 18: "\<And>x y z . - (x \<squnion> - y) \<squnion> (- (- y \<squnion> - x) \<squnion> z) = y \<squnion> z"
	+ using 3 12 by metis
	+ have 20: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> - x) = x"
	+ using 4 12 by metis
	+ have 21: "\<And>x y . - (x \<squnion> - y) \<squnion> - (- x \<squnion> - y) = y"
	+ using 4 12 by metis
	+ have 22: "\<And>x y . - x \<squnion> - (- (y \<squnion> - x) \<squnion> - - (- x \<squnion> - y)) = y \<squnion> - x"
	+ using 6 12 by metis
	+ have 23: "\<And>x y . - x \<squnion> - (- x \<squnion> (- y \<squnion> - (y \<squnion> - x))) = y \<squnion> - x"
	+ using 3 4 6 12 by metis
	+ have 24: "\<And>x y . - x \<squnion> - (- (- x \<squnion> - y) \<squnion> - - (- x \<squnion> y)) = - x \<squnion> - y"
	+ using 6 12 by metis
	+ have 28: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (- y \<squnion> x) = y"
	+ using 4 13 by metis
	+ have 30: "\<And>x y . - x \<squnion> - (- y \<squnion> (- x \<squnion> - (- x \<squnion> y))) = - x \<squnion> y"
	+ using 3 4 6 13 by metis
	+ have 32: "\<And>x y z . - (- x \<squnion> y) \<squnion> (z \<squnion> - (- y \<squnion> - x)) = z \<squnion> x"
	+ using 10 13 by metis
	+ have 37: "\<And>x y z . - (- x \<squnion> - y) \<squnion> (- (y \<squnion> - x) \<squnion> z) = x \<squnion> z"
	+ using 3 20 by metis
	+ have 39: "\<And>x y z . - (- x \<squnion> - y) \<squnion> (z \<squnion> - (y \<squnion> - x)) = z \<squnion> x"
	+ using 10 20 by metis
	+ have 40: "\<And>x y z . - (x \<squnion> - y) \<squnion> (- (- x \<squnion> - y) \<squnion> z) = y \<squnion> z"
	+ using 3 21 by metis
	+ have 43: "\<And>x y . - x \<squnion> - (- y \<squnion> (- x \<squnion> - (y \<squnion> - x))) = y \<squnion> - x"
	+ using 3 4 6 21 by metis
	+ have 47: "\<And>x y z . - (x \<squnion> y) \<squnion> - (- (- x \<squnion> z) \<squnion> - (- (- x \<squnion> - z) \<squnion> y)) = - x \<squnion> z"
	+ using 6 11 by metis
	+ have 55: "\<And>x y . x \<squnion> - (- y \<squnion> - - x) = y \<squnion> - (- x \<squnion> y)"
	+ using 4 11 12 by metis
	+ have 58: "\<And>x y . x \<squnion> - (- - y \<squnion> - x) = x \<squnion> - (- x \<squnion> y)"
	+ using 4 11 13 by metis
	+ have 63: "\<And>x y . x \<squnion> - (- - x \<squnion> - y) = y \<squnion> - (- x \<squnion> y)"
	+ using 4 11 21 by metis
	+ have 71: "\<And>x y . x \<squnion> - (- y \<squnion> x) = y \<squnion> - (- x \<squnion> y)"
	+ using 4 11 28 by metis
	+ have 75: "\<And>x y . x \<squnion> - (- y \<squnion> x) = y \<squnion> - (y \<squnion> - x)"
	+ using 4 71 by metis
	+ have 78: "\<And>x y . - x \<squnion> (y \<squnion> - (- x \<squnion> (y \<squnion> - - (- x \<squnion> - y)))) = - x \<squnion> - (- x \<squnion> - y)"
	+ using 3 4 6 71 by metis
	+ have 86: "\<And>x y . - (- x \<squnion> - (- y \<squnion> x)) \<squnion> - (y \<squnion> - (- x \<squnion> y)) = - y \<squnion> x"
	+ using 4 20 71 by metis
	+ have 172: "\<And>x y . - x \<squnion> - (- x \<squnion> - y) = y \<squnion> - (- - x \<squnion> y)"
	+ using 14 75 by metis
	+ have 201: "\<And>x y . x \<squnion> - (- y \<squnion> - - x) = y \<squnion> - (y \<squnion> - x)"
	+ using 4 55 by metis
	+ have 236: "\<And>x y . x \<squnion> - (- - y \<squnion> - x) = x \<squnion> - (y \<squnion> - x)"
	+ using 4 58 by metis
	+ have 266: "\<And>x y . - x \<squnion> - (- (- x \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> - - (- - x \<squnion> y))) = - x \<squnion> - (- - x \<squnion> y)"
	+ using 14 58 236 by metis
	+ have 678: "\<And>x y z . - (- x \<squnion> - (- y \<squnion> x)) \<squnion> (- (y \<squnion> - (- x \<squnion> y)) \<squnion> z) = - y \<squnion> (x \<squnion> z)"
	+ using 3 4 37 71 by smt
	+ have 745: "\<And>x y z . - (- x \<squnion> - (- y \<squnion> x)) \<squnion> (z \<squnion> - (y \<squnion> - (- x \<squnion> y))) = z \<squnion> (- y \<squnion> x)"
	+ using 4 39 71 by metis
	+ have 800: "\<And>x y . - - x \<squnion> (- y \<squnion> (- (y \<squnion> - - x) \<squnion> - (- x \<squnion> (- - x \<squnion> (- y \<squnion> - (y \<squnion> - - x)))))) = x \<squnion> - (y \<squnion> - - x)"
	+ using 3 23 63 by metis
	+ have 944: "\<And>x y . x \<squnion> - (x \<squnion> - - (- (- x \<squnion> - y) \<squnion> - - (- x \<squnion> y))) = - (- x \<squnion> - y) \<squnion> - (- (- x \<squnion> - y) \<squnion> - - (- x \<squnion> y))"
	+ using 4 24 71 by metis
	+ have 948: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> (- y \<squnion> - x))) = - x \<squnion> - (- y \<squnion> - x)"
	+ using 24 75 by metis
	+ have 950: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (- - x \<squnion> y)) \<squnion> - - (- x \<squnion> (- x \<squnion> - y))) = - x \<squnion> - (- x \<squnion> - y)"
	+ using 24 75 by metis
	+ have 961: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (- - x \<squnion> y)) \<squnion> - - (- x \<squnion> (- - - x \<squnion> - y))) = y \<squnion> - (- - x \<squnion> y)"
	+ using 24 63 by metis
	+ have 966: "\<And>x y . - x \<squnion> - (- (y \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> (- y \<squnion> - - - x))) = y \<squnion> - (y \<squnion> - - x)"
	+ using 24 201 by metis
	+ have 969: "\<And>x y . - x \<squnion> - (- (- x \<squnion> - (y \<squnion> - - x)) \<squnion> - - (- x \<squnion> (- - y \<squnion> - - x))) = - x \<squnion> - (y \<squnion> - - x)"
	+ using 24 236 by metis
	+ have 1096: "\<And>x y z . - x \<squnion> (- (- x \<squnion> - y) \<squnion> z) = y \<squnion> (- (- - x \<squnion> y) \<squnion> z)"
	+ using 3 172 by metis
	+ have 1098: "\<And>x y z . - x \<squnion> (y \<squnion> - (- x \<squnion> - z)) = y \<squnion> (z \<squnion> - (- - x \<squnion> z))"
	+ using 10 172 by metis
	+ have 1105: "\<And>x y . x \<squnion> - x = y \<squnion> - y"
	+ using 4 10 12 32 172 by metis
	+ have 1109: "\<And>x y z . x \<squnion> (- x \<squnion> y) = z \<squnion> (- z \<squnion> y)"
	+ using 3 1105 by metis
	+ have 1110: "\<And>x y z . x \<squnion> - x = y \<squnion> (z \<squnion> - (y \<squnion> z))"
	+ using 3 1105 by metis
	+ have 1114: "\<And>x y . - (- x \<squnion> - - x) = - (y \<squnion> - y)"
	+ using 7 1105 by metis
	+ have 1115: "\<And>x y z . x \<squnion> (y \<squnion> - y) = z \<squnion> (x \<squnion> - z)"
	+ using 10 1105 by metis
	+ have 1117: "\<And>x y . - (x \<squnion> - - x) \<squnion> - (y \<squnion> - y) = - x"
	+ using 4 13 1105 by metis
	+ have 1121: "\<And>x y . - (x \<squnion> - x) \<squnion> - (y \<squnion> - - y) = - y"
	+ using 4 28 1105 by metis
	+ have 1122: "\<And>x . - - x = x"
	+ using 4 28 1105 1117 by metis
	+ have 1134: "\<And>x y z . - (x \<squnion> - y) \<squnion> (z \<squnion> - z) = y \<squnion> (- y \<squnion> - x)"
	+ using 18 1105 1122 by metis
	+ have 1140: "\<And>x . - x \<squnion> - (x \<squnion> (x \<squnion> - x)) = - x \<squnion> - x"
	+ using 4 22 1105 1122 1134 by metis
	+ have 1143: "\<And>x y . x \<squnion> (- x \<squnion> y) = y \<squnion> (x \<squnion> - y)"
	+ using 37 1105 1122 1134 by metis
	+ have 1155: "\<And>x y . - (x \<squnion> - x) \<squnion> - (y \<squnion> y) = - y"
	+ using 1121 1122 by metis
	+ have 1156: "\<And>x y . - (x \<squnion> x) \<squnion> - (y \<squnion> - y) = - x"
	+ using 1117 1122 by metis
	+ have 1157: "\<And>x y . - (x \<squnion> - x) = - (y \<squnion> - y)"
	+ using 4 1114 1122 by metis
	+ have 1167: "\<And>x y z . - x \<squnion> (y \<squnion> - (- x \<squnion> - z)) = y \<squnion> (z \<squnion> - (x \<squnion> z))"
	+ using 1098 1122 by metis
	+ have 1169: "\<And>x y z . - x \<squnion> (- (- x \<squnion> - y) \<squnion> z) = y \<squnion> (- (x \<squnion> y) \<squnion> z)"
	+ using 1096 1122 by metis
	+ have 1227: "\<And>x y . - x \<squnion> - (- x \<squnion> (y \<squnion> (x \<squnion> - (- x \<squnion> - (y \<squnion> x))))) = - x \<squnion> - (y \<squnion> x)"
	+ using 3 4 969 1122 by smt
	+ have 1230: "\<And>x y . - x \<squnion> - (- x \<squnion> (- y \<squnion> (- x \<squnion> - (y \<squnion> - (y \<squnion> x))))) = y \<squnion> - (y \<squnion> x)"
	+ using 3 4 966 1122 by smt
	+ have 1234: "\<And>x y . - x \<squnion> - (- x \<squnion> (- x \<squnion> (- y \<squnion> - (y \<squnion> - (x \<squnion> y))))) = y \<squnion> - (x \<squnion> y)"
	+ using 3 4 961 1122 by metis
	+ have 1239: "\<And>x y . - x \<squnion> - (- x \<squnion> - y) = y \<squnion> - (x \<squnion> y)"
	+ using 3 4 950 1122 1234 by metis
	+ have 1240: "\<And>x y . - x \<squnion> - (- y \<squnion> - x) = y \<squnion> - (y \<squnion> x)"
	+ using 3 4 948 1122 1230 by metis
	+ have 1244: "\<And>x y . x \<squnion> - (x \<squnion> (y \<squnion> (y \<squnion> - (x \<squnion> y)))) = - (- x \<squnion> - y) \<squnion> - (y \<squnion> (y \<squnion> - (x \<squnion> y)))"
	+ using 3 4 944 1122 1167 by metis
	+ have 1275: "\<And>x y . x \<squnion> (- y \<squnion> (- (y \<squnion> x) \<squnion> - (x \<squnion> (- x \<squnion> (- y \<squnion> - (y \<squnion> x)))))) = x \<squnion> - (y \<squnion> x)"
	+ using 10 800 1122 by metis
	+ have 1346: "\<And>x y . - x \<squnion> - (x \<squnion> (y \<squnion> (y \<squnion> (x \<squnion> - (x \<squnion> (y \<squnion> x)))))) = - x \<squnion> - (x \<squnion> y)"
	+ using 3 4 10 266 1122 1167 by smt
	+ have 1377: "\<And>x y . - x \<squnion> (y \<squnion> - (- x \<squnion> (y \<squnion> (- x \<squnion> - y)))) = y \<squnion> - (x \<squnion> y)"
	+ using 78 1122 1239 by metis
	+ have 1394: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> (y \<squnion> (- x \<squnion> - (x \<squnion> y)))) = x"
	+ using 3 4 10 20 30 1122 1239 by smt
	+ have 1427: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> - (x \<squnion> (x \<squnion> - (x \<squnion> y)))) = x \<squnion> (x \<squnion> - (x \<squnion> y))"
	+ using 3 4 30 40 1240 by smt
	+ have 1436: "\<And>x . - x \<squnion> - (x \<squnion> (x \<squnion> (- x \<squnion> - x))) = - x \<squnion> (- x \<squnion> - (x \<squnion> - x))"
	+ using 3 4 30 1140 1239 by smt
	+ have 1437: "\<And>x y . - (x \<squnion> y) \<squnion> - (x \<squnion> - y) = - x"
	+ using 6 1122 by metis
	+ have 1438: "\<And>x y . - (x \<squnion> y) \<squnion> - (y \<squnion> - x) = - y"
	+ using 12 1122 by metis
	+ have 1439: "\<And>x y . - (x \<squnion> y) \<squnion> - (- y \<squnion> x) = - x"
	+ using 13 1122 by metis
	+ have 1440: "\<And>x y . - (x \<squnion> - y) \<squnion> - (y \<squnion> x) = - x"
	+ using 20 1122 by metis
	+ have 1441: "\<And>x y . - (x \<squnion> y) \<squnion> - (- x \<squnion> y) = - y"
	+ using 21 1122 by metis
	+ have 1568: "\<And>x y . x \<squnion> (- y \<squnion> - x) = y \<squnion> (- y \<squnion> x)"
	+ using 10 1122 1143 by metis
	+ have 1598: "\<And>x . - x \<squnion> - (x \<squnion> (x \<squnion> (x \<squnion> - x))) = - x \<squnion> (- x \<squnion> - (x \<squnion> - x))"
	+ using 4 1436 1568 by metis
	+ have 1599: "\<And>x y . - x \<squnion> (y \<squnion> - (x \<squnion> (- x \<squnion> (- x \<squnion> y)))) = y \<squnion> - (x \<squnion> y)"
	+ using 10 1377 1568 by smt
	+ have 1617: "\<And>x . x \<squnion> (- x \<squnion> (- x \<squnion> - (x \<squnion> - x))) = x \<squnion> - x"
	+ using 3 4 10 71 1122 1155 1568 1598 by metis
	+ have 1632: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> (- (z \<squnion> - z) \<squnion> - (y \<squnion> - (x \<squnion> - x)))) = y \<squnion> - (x \<squnion> - x)"
	+ using 43 1157 by metis
	+ have 1633: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> (- (x \<squnion> - x) \<squnion> - (y \<squnion> - (z \<squnion> - z)))) = y \<squnion> - (x \<squnion> - x)"
	+ using 43 1157 by metis
	+ have 1636: "\<And>x y . x \<squnion> - (y \<squnion> (- y \<squnion> - (x \<squnion> x))) = x \<squnion> x"
	+ using 43 1109 1122 by metis
	+ have 1645: "\<And>x y . x \<squnion> - x = y \<squnion> (y \<squnion> - y)"
	+ using 3 1110 1156 by metis
	+ have 1648: "\<And>x y z . - (x \<squnion> (y \<squnion> (- y \<squnion> - x))) \<squnion> - (z \<squnion> - z) = - (y \<squnion> - y)"
	+ using 3 1115 1156 by metis
	+ have 1657: "\<And>x y z . x \<squnion> - x = y \<squnion> (z \<squnion> - z)"
	+ using 1105 1645 by metis
	+ have 1664: "\<And>x y z . x \<squnion> - x = y \<squnion> (z \<squnion> - y)"
	+ using 1115 1645 by metis
	+ have 1672: "\<And>x y z . x \<squnion> - x = y \<squnion> (- y \<squnion> z)"
	+ using 3 4 1657 by metis
	+ have 1697: "\<And>x y z . - x \<squnion> (y \<squnion> x) = z \<squnion> - z"
	+ using 1122 1664 by metis
	+ have 1733: "\<And>x y z . - (x \<squnion> y) \<squnion> - (- (z \<squnion> - z) \<squnion> - (- (- x \<squnion> - x) \<squnion> y)) = x \<squnion> - x"
	+ using 4 47 1105 1122 by metis
	+ have 1791: "\<And>x y z . x \<squnion> - (y \<squnion> (- y \<squnion> z)) = x \<squnion> - (x \<squnion> - x)"
	+ using 4 71 1122 1672 by metis
	+ have 1818: "\<And>x y z . x \<squnion> - (- y \<squnion> (z \<squnion> y)) = x \<squnion> - (x \<squnion> - x)"
	+ using 4 71 1122 1697 by metis
	+ have 1861: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (y \<squnion> - (z \<squnion> - z)) = - y"
	+ using 1437 1657 by metis
	+ have 1867: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> - (z \<squnion> y)) = y"
	+ using 1122 1437 1697 by metis
	+ have 1868: "\<And>x y . x \<squnion> - (y \<squnion> - y) = x"
	+ using 1122 1155 1633 1861 by metis
	+ have 1869: "\<And>x y z . - (x \<squnion> - x) \<squnion> - (- y \<squnion> (- (z \<squnion> - z) \<squnion> - y)) = y"
	+ using 1632 1868 by metis
	+ have 1870: "\<And>x y . - (x \<squnion> - x) \<squnion> - y = - y"
	+ using 1861 1868 by metis
	+ have 1872: "\<And>x y z . x \<squnion> - (- y \<squnion> (z \<squnion> y)) = x"
	+ using 1818 1868 by metis
	+ have 1875: "\<And>x y z . x \<squnion> - (y \<squnion> (- y \<squnion> z)) = x"
	+ using 1791 1868 by metis
	+ have 1883: "\<And>x y . - (x \<squnion> (y \<squnion> (- y \<squnion> - x))) = - (y \<squnion> - y)"
	+ using 1648 1868 by metis
	+ have 1885: "\<And>x . x \<squnion> (x \<squnion> - x) = x \<squnion> - x"
	+ using 4 1568 1617 1868 by metis
	+ have 1886: "\<And>x . - x \<squnion> - x = - x"
	+ using 1598 1868 1885 by metis
	+ have 1890: "\<And>x . - (x \<squnion> x) = - x"
	+ using 1156 1868 by metis
	+ have 1892: "\<And>x y . - (x \<squnion> - x) \<squnion> y = y"
	+ using 1122 1869 1870 1886 by metis
	+ have 1893: "\<And>x y . - (- x \<squnion> - (y \<squnion> x)) = x"
	+ using 1867 1892 by metis
	+ have 1902: "\<And>x y . x \<squnion> (y \<squnion> - (x \<squnion> y)) = x \<squnion> - x"
	+ using 3 4 1122 1733 1886 1892 by metis
	+ have 1908: "\<And>x . x \<squnion> x = x"
	+ using 1636 1875 1890 by metis
	+ have 1910: "\<And>x y . x \<squnion> - (y \<squnion> x) = - y \<squnion> x"
	+ using 1599 1875 by metis
	+ have 1921: "\<And>x y . x \<squnion> (- y \<squnion> - (y \<squnion> x)) = - y \<squnion> x"
	+ using 1275 1875 1910 by metis
	+ have 1951: "\<And>x y . - x \<squnion> - (y \<squnion> x) = - x"
	+ using 1227 1872 1893 1908 by metis
	+ have 1954: "\<And>x y z . x \<squnion> (y \<squnion> - (x \<squnion> z)) = y \<squnion> (- z \<squnion> x)"
	+ using 745 1122 1910 1951 by metis
	+ have 1956: "\<And>x y z . x \<squnion> (- (x \<squnion> y) \<squnion> z) = - y \<squnion> (x \<squnion> z)"
	+ using 678 1122 1910 1951 by metis
	+ have 1959: "\<And>x y . x \<squnion> - (x \<squnion> y) = - y \<squnion> x"
	+ using 86 1122 1910 1951 by metis
	+ have 1972: "\<And>x y . x \<squnion> (- x \<squnion> y) = x \<squnion> - x"
	+ using 1902 1910 by metis
	+ have 2000: "\<And>x y . - (- x \<squnion> - y) \<squnion> - (y \<squnion> (- x \<squnion> y)) = x \<squnion> - (y \<squnion> (- x \<squnion> y))"
	+ using 4 1244 1910 1959 by metis
	+ have 2054: "\<And>x y . x \<squnion> - (y \<squnion> (- x \<squnion> y)) = x"
	+ using 1394 1921 2000 by metis
	+ have 2057: "\<And>x y . - (x \<squnion> (y \<squnion> - y)) = - (y \<squnion> - y)"
	+ using 1883 1972 by metis
	+ have 2061: "\<And>x y . x \<squnion> (- y \<squnion> x) = x \<squnion> - y"
	+ using 4 1122 1427 1910 1959 2054 by metis
	+ have 2090: "\<And>x y z . x \<squnion> (- (y \<squnion> x) \<squnion> z) = x \<squnion> (- y \<squnion> z)"
	+ using 1122 1169 1956 by metis
	+ have 2100: "\<And>x y . - x \<squnion> - (x \<squnion> y) = - x"
	+ using 4 1346 1868 1885 1910 1959 1972 2057 by metis
	+ have 2144: "\<And>x y . x \<squnion> - (y \<squnion> - x) = x"
	+ using 1122 1440 2000 2061 by metis
	+ have 2199: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
	+ using 3 1908 by metis
	+ have 2208: "\<And>x y z . x \<squnion> (- (y \<squnion> - x) \<squnion> z) = x \<squnion> z"
	+ using 3 2144 by metis
	+ have 2349: "\<And>x y z . - (x \<squnion> y) \<squnion> - (x \<squnion> (y \<squnion> z)) = - (x \<squnion> y)"
	+ using 3 2100 by metis
	+ have 2432: "\<And>x y z . - (x \<squnion> (y \<squnion> z)) \<squnion> - (y \<squnion> (z \<squnion> - x)) = - (y \<squnion> z)"
	+ using 3 1438 by metis
	+ have 2530: "\<And>x y z . - (- (x \<squnion> y) \<squnion> z) = - (y \<squnion> (- x \<squnion> z)) \<squnion> - (- y \<squnion> z)"
	+ using 4 1122 1439 2090 2208 by smt
	+ have 3364: "\<And>x y z . - (- x \<squnion> y) \<squnion> (z \<squnion> - (x \<squnion> y)) = z \<squnion> - y"
	+ using 3 4 1122 1441 1910 1954 2199 by metis
	+ have 5763: "\<And>x y z . - (x \<squnion> y) \<squnion> - (- x \<squnion> (y \<squnion> z)) = - (x \<squnion> y) \<squnion> - (y \<squnion> z)"
	+ using 4 2349 3364 by metis
	+ have 6113: "\<And>x y z . - (x \<squnion> (y \<squnion> z)) \<squnion> - (z \<squnion> - x) = - (y \<squnion> z) \<squnion> - (z \<squnion> - x)"
	+ using 4 2432 3364 5763 by metis
	+ show "\<And>x y z. x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
	+ proof -
	+ fix x y z
	+ have "- (y \<sqinter> z \<squnion> x) = - (- (- y \<squnion> z) \<squnion> - (- y \<squnion> - z) \<squnion> x) \<squnion> - (x \<squnion> - - z)"
	+ using 1437 2530 6113 by (smt commutative inf_def)
	+ thus "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
	+ using 12 1122 by (metis commutative inf_def)
	+ qed
	+ qed
	+ show 14: "\<And>x. x \<sqinter> - x = bot"
	+ proof -
	+ fix x
	+ have "(bot \<squnion> x) \<sqinter> (bot \<squnion> -x) = bot"
	+ using huntington bot_def inf_def by auto
	+ thus "x \<sqinter> -x = bot"
	+ using 11 less_eq_def by force
	+ qed
	+ show 15: "\<And>x. x \<squnion> - x = top"
	+ using 5 14 by (metis (no_types, lifting) huntington bot_def less_eq_def top_def)
	+ show 16: "\<And>x y. x - y = x \<sqinter> - y"
	+ using 15 by (metis commutative huntington inf_def minus_def)
	+ show 7: "\<And>x y z. x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
	+ by (simp add: 13 less_eq_def)
	+qed
	+
	+end
	+
	+context boolean_algebra
	+begin
	+
	+sublocale ba_he: huntington_extended
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (simp add: sup_assoc)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (simp add: sup_commute)
	+ show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
	+ by simp
	+ show "top = (THE x. \<forall>y. x = y \<squnion> - y)"
	+ by auto
	+ show "bot = - (THE x. \<forall>y. x = y \<squnion> - y)"
	+ by auto
	+ show "\<And>x y. x \<sqinter> y = - (- x \<squnion> - y)"
	+ by simp
	+ show "\<And>x y. x - y = - (- x \<squnion> y)"
	+ by (simp add: diff_eq)
	+ show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
	+ by (simp add: le_iff_sup)
	+ show "\<And>x y. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
	+ using sup.strict_order_iff sup_commute by auto
	+qed
	+
	+end
	+
	+subsection \<open>Stone Algebras\<close>
	+
	+text \<open>
	+We relate Stone algebras to Boolean algebras.
	+\<close>
	+
	+class stone_algebra_extended = stone_algebra + minus +
	+ assumes stone_minus_def[simp]: "x - y = x \<sqinter> -y"
	+
	+class regular_stone_algebra = stone_algebra_extended +
	+ assumes double_complement[simp]: "--x = x"
	+begin
	+
	+subclass boolean_algebra
	+proof
	+ show "\<And>x. x \<sqinter> - x = bot"
	+ by simp
	+ show "\<And>x. x \<squnion> - x = top"
	+ using regular_dense_top by fastforce
	+ show "\<And>x y. x - y = x \<sqinter> - y"
	+ by simp
	+qed
	+
	+end
	+
	+context boolean_algebra
	+begin
	+
	+sublocale ba_rsa: regular_stone_algebra
	+proof
	+ show "\<And>x y. x - y = x \<sqinter> - y"
	+ by (simp add: diff_eq)
	+ show "\<And>x. - - x = x"
	+ by simp
	+qed
	+
	+end
	+
	+section \<open>Alternative Axiomatisations of Boolean Algebras\<close>
	+
	+text \<open>
	+We consider four axiomatisations of Boolean algebras based only on join and complement.
	+The first three are from the literature and the fourth, a version using equational axioms, is new.
	+The motivation for Byrne's and the new axiomatisation is that the axioms are easier to understand than Huntington's third axiom.
	+We also include Meredith's axiomatisation.
	+\<close>
	+
	+subsection \<open>Lee Byrne's Formulation A\<close>
	+
	+text \<open>
	+The following axiomatisation is from \cite[Formulation A]{Byrne1946}; see also \cite{Frink1941}.
	+\<close>
	+
	+text \<open>Theorem 3\<close>
	+
	+class boolean_algebra_1 = sup + uminus +
	+ assumes ba1_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ assumes ba1_commutative: "x \<squnion> y = y \<squnion> x"
	+ assumes ba1_complement: "x \<squnion> -y = z \<squnion> -z \<longleftrightarrow> x \<squnion> y = x"
	+begin
	+
	+subclass huntington
	+proof
	+ show 1: "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (simp add: ba1_associative)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (simp add: ba1_commutative)
	+ show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
	+ proof -
	+ have 2: "\<forall>x y. y \<squnion> (y \<squnion> x) = y \<squnion> x"
	+ using 1 by (metis ba1_complement)
	+ hence "\<forall>x. --x = x"
	+ by (smt ba1_associative ba1_commutative ba1_complement)
	+ hence "\<forall>x y. y \<squnion> -(y \<squnion> -x) = y \<squnion> x"
	+ by (smt ba1_associative ba1_commutative ba1_complement)
	+ thus "\<And>x y. x = -(-x \<squnion> y) \<squnion> -(-x \<squnion> - y)"
	+ using 2 by (smt ba1_commutative ba1_complement)
	+ qed
	+qed
	+
	+end
	+
	+context huntington
	+begin
	+
	+sublocale h_ba1: boolean_algebra_1
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (simp add: associative)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (simp add: commutative)
	+ show "\<And>x y z. (x \<squnion> - y = z \<squnion> - z) = (x \<squnion> y = x)"
	+ proof
	+ fix x y z
	+ have 1: "\<And>x y z. -(-x \<squnion> y) \<squnion> (-(-x \<squnion> -y) \<squnion> z) = x \<squnion> z"
	+ using associative huntington by force
	+ have 2: "\<And>x y. -(x \<squnion> -y) \<squnion> -(-y \<squnion> -x) = y"
	+ by (metis commutative huntington)
	+ show "x \<squnion> - y = z \<squnion> - z \<Longrightarrow> x \<squnion> y = x"
	+ by (metis 1 2 associative commutative top_unique)
	+ show "x \<squnion> y = x \<Longrightarrow> x \<squnion> - y = z \<squnion> - z"
	+ by (metis associative huntington commutative top_unique)
	+ qed
	+qed
	+
	+end
	+
	+subsection \<open>Lee Byrne's Formulation B\<close>
	+
	+text \<open>
	+The following axiomatisation is from \cite[Formulation B]{Byrne1946}.
	+\<close>
	+
	+text \<open>Theorem 4\<close>
	+
	+class boolean_algebra_2 = sup + uminus +
	+ assumes ba2_associative_commutative: "(x \<squnion> y) \<squnion> z = (y \<squnion> z) \<squnion> x"
	+ assumes ba2_complement: "x \<squnion> -y = z \<squnion> -z \<longleftrightarrow> x \<squnion> y = x"
	+begin
	+
	+subclass boolean_algebra_1
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (smt ba2_associative_commutative ba2_complement)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (metis ba2_associative_commutative ba2_complement)
	+ show "\<And>x y z. (x \<squnion> - y = z \<squnion> - z) = (x \<squnion> y = x)"
	+ by (simp add: ba2_complement)
	+qed
	+
	+end
	+
	+context boolean_algebra_1
	+begin
	+
	+sublocale ba1_ba2: boolean_algebra_2
	+proof
	+ show "\<And>x y z. x \<squnion> y \<squnion> z = y \<squnion> z \<squnion> x"
	+ using ba1_associative commutative by force
	+ show "\<And>x y z. (x \<squnion> - y = z \<squnion> - z) = (x \<squnion> y = x)"
	+ by (simp add: ba1_complement)
	+qed
	+
	+end
	+
	+subsection \<open>Meredith's Equational Axioms\<close>
	+
	+text \<open>
	+The following axiomatisation is from \cite[page 221 (1) \{A,N\}]{MeredithPrior1968}.
	+\<close>
	+
	+class boolean_algebra_mp = sup + uminus +
	+ assumes ba_mp_1: "-(-x \<squnion> y) \<squnion> x = x"
	+ assumes ba_mp_2: "-(-x \<squnion> y) \<squnion> (z \<squnion> y) = y \<squnion> (z \<squnion> x)"
	+begin
	+
	+subclass huntington
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (metis ba_mp_1 ba_mp_2)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (metis ba_mp_1 ba_mp_2)
	+ show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
	+ by (metis ba_mp_1 ba_mp_2)
	+qed
	+
	+end
	+
	+context huntington
	+begin
	+
	+sublocale mp_h: boolean_algebra_mp
	+proof
	+ show 1: "\<And>x y. - (- x \<squnion> y) \<squnion> x = x"
	+ by (metis h_ba1.ba1_associative h_ba1.ba1_complement huntington)
	+ show "\<And>x y z. - (- x \<squnion> y) \<squnion> (z \<squnion> y) = y \<squnion> (z \<squnion> x)"
	+ proof -
	+ fix x y z
	+ have "y = -(-x \<squnion> -y) \<squnion> y"
	+ using 1 h_ba1.ba1_commutative by auto
	+ thus "-(-x \<squnion> y) \<squnion> (z \<squnion> y) = y \<squnion> (z \<squnion> x)"
	+ by (metis h_ba1.ba1_associative h_ba1.ba1_commutative huntington)
	+ qed
	+qed
	+
	+end
	+
	+subsection \<open>An Equational Axiomatisation based on Semilattices\<close>
	+
	+text \<open>
	+The following version is an equational axiomatisation based on semilattices.
	+We add the double complement rule and that \<open>top\<close> is unique.
	+The final axiom \<open>ba3_export\<close> encodes the logical statement $P \vee Q = P \vee (\neg P \wedge Q)$.
	+Its dual appears in \cite{BalbesHorn1970}.
	+\<close>
	+
	+text \<open>Theorem 5\<close>
	+
	+class boolean_algebra_3 = sup + uminus +
	+ assumes ba3_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ assumes ba3_commutative: "x \<squnion> y = y \<squnion> x"
	+ assumes ba3_idempotent[simp]: "x \<squnion> x = x"
	+ assumes ba3_double_complement[simp]: "--x = x"
	+ assumes ba3_top_unique: "x \<squnion> -x = y \<squnion> -y"
	+ assumes ba3_export: "x \<squnion> -(x \<squnion> y) = x \<squnion> -y"
	+begin
	+
	+subclass huntington
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (simp add: ba3_associative)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (simp add: ba3_commutative)
	+ show "\<And>x y. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
	+ by (metis ba3_commutative ba3_double_complement ba3_export ba3_idempotent ba3_top_unique)
	+qed
	+
	+end
	+
	+context huntington
	+begin
	+
	+sublocale h_ba3: boolean_algebra_3
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (simp add: h_ba1.ba1_associative)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (simp add: h_ba1.ba1_commutative)
	+ show 3: "\<And>x. x \<squnion> x = x"
	+ using h_ba1.ba1_complement by blast
	+ show 4: "\<And>x. - - x = x"
	+ by (metis h_ba1.ba1_commutative huntington top_unique)
	+ show "\<And>x y. x \<squnion> - x = y \<squnion> - y"
	+ by (simp add: top_unique)
	+ show "\<And>x y. x \<squnion> - (x \<squnion> y) = x \<squnion> - y"
	+ using 3 4 by (smt h_ba1.ba1_ba2.ba2_associative_commutative h_ba1.ba1_complement)
	+qed
	+
	+end
	+
	+section \<open>Subset Boolean Algebras\<close>
	+
	+text \<open>
	+We apply Huntington's axioms to the range of a unary operation, which serves as complement on the range.
	+This gives a Boolean algebra structure on the range without imposing any further constraints on the set.
	+The obtained structure is used as a reference in the subsequent development and to inherit the results proved here.
	+This is taken from \cite{Guttmann2012c,GuttmannStruthWeber2011b} and follows the development of Boolean algebras in \cite{Maddux1996}.
	+\<close>
	+
	+text \<open>Definition 6\<close>
	+
	+class subset_boolean_algebra = sup + uminus +
	+ assumes sub_associative: "-x \<squnion> (-y \<squnion> -z) = (-x \<squnion> -y) \<squnion> -z"
	+ assumes sub_commutative: "-x \<squnion> -y = -y \<squnion> -x"
	+ assumes sub_complement: "-x = -(--x \<squnion> -y) \<squnion> -(--x \<squnion> --y)"
	+ assumes sub_sup_closed: "-x \<squnion> -y = --(-x \<squnion> -y)"
	+begin
	+
	+text \<open>uniqueness of \<open>top\<close>, resulting in the lemma \<open>top_def\<close> to replace the assumption \<open>sub_top_def\<close>\<close>
	+
	+lemma top_unique:
	+ "-x \<squnion> --x = -y \<squnion> --y"
	+ by (metis sub_associative sub_commutative sub_complement)
	+
	+text \<open>consequences for join and complement\<close>
	+
	+lemma double_negation[simp]:
	+ "---x = -x"
	+ by (metis sub_complement sub_sup_closed)
	+
	+lemma complement_1:
	+ "--x = -(-x \<squnion> -y) \<squnion> -(-x \<squnion> --y)"
	+ by (metis double_negation sub_complement)
	+
	+lemma sup_right_zero_var:
	+ "-x \<squnion> (-y \<squnion> --y) = -z \<squnion> --z"
	+ by (smt complement_1 sub_associative sub_sup_closed top_unique)
	+
	+lemma sup_right_unit_idempotent:
	+ "-x \<squnion> -x = -x \<squnion> -(-y \<squnion> --y)"
	+ by (metis complement_1 double_negation sub_sup_closed sup_right_zero_var)
	+
	+lemma sup_idempotent[simp]:
	+ "-x \<squnion> -x = -x"
	+ by (smt complement_1 double_negation sub_associative sup_right_unit_idempotent)
	+
	+lemma complement_2:
	+ "-x = -(-(-x \<squnion> -y) \<squnion> -(-x \<squnion> --y))"
	+ using complement_1 by auto
	+
	+lemma sup_eq_cases:
	+ "-x \<squnion> -y = -x \<squnion> -z \<Longrightarrow> --x \<squnion> -y = --x \<squnion> -z \<Longrightarrow> -y = -z"
	+ by (metis complement_2 sub_commutative)
	+
	+lemma sup_eq_cases_2:
	+ "-y \<squnion> -x = -z \<squnion> -x \<Longrightarrow> -y \<squnion> --x = -z \<squnion> --x \<Longrightarrow> -y = -z"
	+ using sub_commutative sup_eq_cases by auto
	+
	+end
	+
	+text \<open>Definition 7\<close>
	+
	+class subset_extended = sup + inf + minus + uminus + bot + top + ord +
	+ assumes sub_top_def: "top = (THE x . \<forall>y . x = -y \<squnion> --y)" (* define without imposing uniqueness *)
	+ assumes sub_bot_def: "bot = -(THE x . \<forall>y . x = -y \<squnion> --y)"
	+ assumes sub_inf_def: "-x \<sqinter> -y = -(--x \<squnion> --y)"
	+ assumes sub_minus_def: "-x - -y = -(--x \<squnion> -y)"
	+ assumes sub_less_eq_def: "-x \<le> -y \<longleftrightarrow> -x \<squnion> -y = -y"
	+ assumes sub_less_def: "-x < -y \<longleftrightarrow> -x \<squnion> -y = -y \<and> \<not> (-y \<squnion> -x = -x)"
	+
	+class subset_boolean_algebra_extended = subset_boolean_algebra + subset_extended
	+begin
	+
	+lemma top_def:
	+ "top = -x \<squnion> --x"
	+ using sub_top_def top_unique by blast
	+
	+text \<open>consequences for meet\<close>
	+
	+lemma inf_closed:
	+ "-x \<sqinter> -y = --(-x \<sqinter> -y)"
	+ by (simp add: sub_inf_def)
	+
	+lemma inf_associative:
	+ "-x \<sqinter> (-y \<sqinter> -z) = (-x \<sqinter> -y) \<sqinter> -z"
	+ using sub_associative sub_inf_def sub_sup_closed by auto
	+
	+lemma inf_commutative:
	+ "-x \<sqinter> -y = -y \<sqinter> -x"
	+ by (simp add: sub_commutative sub_inf_def)
	+
	+lemma inf_idempotent[simp]:
	+ "-x \<sqinter> -x = -x"
	+ by (simp add: sub_inf_def)
	+
	+lemma inf_absorb[simp]:
	+ "(-x \<squnion> -y) \<sqinter> -x = -x"
	+ by (metis complement_1 sup_idempotent sub_inf_def sub_associative sub_sup_closed)
	+
	+lemma sup_absorb[simp]:
	+ "-x \<squnion> (-x \<sqinter> -y) = -x"
	+ by (metis sub_associative sub_complement sub_inf_def sup_idempotent)
	+
	+lemma inf_demorgan:
	+ "-(-x \<sqinter> -y) = --x \<squnion> --y"
	+ using sub_inf_def sub_sup_closed by auto
	+
	+lemma sub_sup_demorgan:
	+ "-(-x \<squnion> -y) = --x \<sqinter> --y"
	+ by (simp add: sub_inf_def)
	+
	+lemma sup_cases:
	+ "-x = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> --y)"
	+ by (metis inf_closed inf_demorgan sub_complement)
	+
	+lemma inf_cases:
	+ "-x = (-x \<squnion> -y) \<sqinter> (-x \<squnion> --y)"
	+ by (metis complement_2 sub_sup_closed sub_sup_demorgan)
	+
	+lemma inf_complement_intro:
	+ "(-x \<squnion> -y) \<sqinter> --x = -y \<sqinter> --x"
	+proof -
	+ have "(-x \<squnion> -y) \<sqinter> --x = (-x \<squnion> -y) \<sqinter> (--x \<squnion> -y) \<sqinter> --x"
	+ by (metis inf_absorb inf_associative sub_sup_closed)
	+ also have "... = -y \<sqinter> --x"
	+ by (metis inf_cases sub_commutative)
	+ finally show ?thesis
	+ .
	+qed
	+
	+lemma sup_complement_intro:
	+ "-x \<squnion> -y = -x \<squnion> (--x \<sqinter> -y)"
	+ by (metis inf_absorb inf_commutative inf_complement_intro sub_sup_closed sup_cases)
	+
	+lemma inf_left_dist_sup:
	+ "-x \<sqinter> (-y \<squnion> -z) = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z)"
	+proof -
	+ have "-x \<sqinter> (-y \<squnion> -z) = (-x \<sqinter> (-y \<squnion> -z) \<sqinter> -y) \<squnion> (-x \<sqinter> (-y \<squnion> -z) \<sqinter> --y)"
	+ by (metis sub_inf_def sub_sup_closed sup_cases)
	+ also have "... = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z \<sqinter> --y)"
	+ by (metis inf_absorb inf_associative inf_complement_intro sub_sup_closed)
	+ also have "... = (-x \<sqinter> -y) \<squnion> ((-x \<sqinter> -y \<sqinter> -z) \<squnion> (-x \<sqinter> -z \<sqinter> --y))"
	+ using sub_associative sub_inf_def sup_absorb by auto
	+ also have "... = (-x \<sqinter> -y) \<squnion> ((-x \<sqinter> -z \<sqinter> -y) \<squnion> (-x \<sqinter> -z \<sqinter> --y))"
	+ by (metis inf_associative inf_commutative)
	+ also have "... = (-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z)"
	+ by (metis sub_inf_def sup_cases)
	+ finally show ?thesis
	+ .
	+qed
	+
	+lemma sup_left_dist_inf:
	+ "-x \<squnion> (-y \<sqinter> -z) = (-x \<squnion> -y) \<sqinter> (-x \<squnion> -z)"
	+proof -
	+ have "-x \<squnion> (-y \<sqinter> -z) = -(--x \<sqinter> (--y \<squnion> --z))"
	+ by (metis sub_inf_def sub_sup_closed sub_sup_demorgan)
	+ also have "... = (-x \<squnion> -y) \<sqinter> (-x \<squnion> -z)"
	+ by (metis inf_left_dist_sup sub_sup_closed sub_sup_demorgan)
	+ finally show ?thesis
	+ .
	+qed
	+
	+lemma sup_right_dist_inf:
	+ "(-y \<sqinter> -z) \<squnion> -x = (-y \<squnion> -x) \<sqinter> (-z \<squnion> -x)"
	+ using sub_commutative sub_inf_def sup_left_dist_inf by auto
	+
	+lemma inf_right_dist_sup:
	+ "(-y \<squnion> -z) \<sqinter> -x = (-y \<sqinter> -x) \<squnion> (-z \<sqinter> -x)"
	+ by (metis inf_commutative inf_left_dist_sup sub_sup_closed)
	+
	+lemma case_duality:
	+ "(--x \<sqinter> -y) \<squnion> (-x \<sqinter> -z) = (-x \<squnion> -y) \<sqinter> (--x \<squnion> -z)"
	+proof -
	+ have 1: "-(--x \<sqinter> --y) \<sqinter> ----x = --x \<sqinter> -y"
	+ using inf_commutative inf_complement_intro sub_sup_closed sub_sup_demorgan by auto
	+ have 2: "-(----x \<squnion> -(--x \<squnion> -z)) = -----x \<sqinter> ---z"
	+ by (metis (no_types) double_negation sup_complement_intro sub_sup_demorgan)
	+ have 3: "-(--x \<sqinter> --y) \<sqinter> -x = -x"
	+ using inf_commutative inf_left_dist_sup sub_sup_closed sub_sup_demorgan by auto
	+ hence "-(--x \<sqinter> --y) = -x \<squnion> -y"
	+ using sub_sup_closed sub_sup_demorgan by auto
	+ thus ?thesis
	+ by (metis double_negation 1 2 3 inf_associative inf_left_dist_sup sup_complement_intro)
	+qed
	+
	+lemma case_duality_2:
	+ "(-x \<sqinter> -y) \<squnion> (--x \<sqinter> -z) = (-x \<squnion> -z) \<sqinter> (--x \<squnion> -y)"
	+ using case_duality sub_commutative sub_inf_def by auto
	+
	+lemma complement_cases:
	+ "((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> -((-v \<sqinter> -y) \<squnion> (--v \<sqinter> -z)) = (-v \<sqinter> -w \<sqinter> --y) \<squnion> (--v \<sqinter> -x \<sqinter> --z)"
	+proof -
	+ have 1: "(--v \<squnion> -w) = --(--v \<squnion> -w) \<and> (-v \<squnion> -x) = --(-v \<squnion> -x) \<and> (--v \<squnion> --y) = --(--v \<squnion> --y) \<and> (-v \<squnion> --z) = --(-v \<squnion> --z)"
	+ using sub_inf_def sub_sup_closed by auto
	+ have 2: "(-v \<squnion> (-x \<sqinter> --z)) = --(-v \<squnion> (-x \<sqinter> --z))"
	+ using sub_inf_def sub_sup_closed by auto
	+ have "((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> -((-v \<sqinter> -y) \<squnion> (--v \<sqinter> -z)) = ((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> (-(-v \<sqinter> -y) \<sqinter> -(--v \<sqinter> -z))"
	+ using sub_inf_def by auto
	+ also have "... = ((-v \<sqinter> -w) \<squnion> (--v \<sqinter> -x)) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> --z))"
	+ using inf_demorgan by auto
	+ also have "... = (--v \<squnion> -w) \<sqinter> (-v \<squnion> -x) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> --z))"
	+ by (metis case_duality double_negation)
	+ also have "... = (--v \<squnion> -w) \<sqinter> ((-v \<squnion> -x) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> --z)))"
	+ by (metis 1 inf_associative sub_inf_def)
	+ also have "... = (--v \<squnion> -w) \<sqinter> ((-v \<squnion> -x) \<sqinter> (--v \<squnion> --y) \<sqinter> (-v \<squnion> --z))"
	+ by (metis 1 inf_associative)
	+ also have "... = (--v \<squnion> -w) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> -x) \<sqinter> (-v \<squnion> --z))"
	+ by (metis 1 inf_commutative)
	+ also have "... = (--v \<squnion> -w) \<sqinter> ((--v \<squnion> --y) \<sqinter> ((-v \<squnion> -x) \<sqinter> (-v \<squnion> --z)))"
	+ by (metis 1 inf_associative)
	+ also have "... = (--v \<squnion> -w) \<sqinter> ((--v \<squnion> --y) \<sqinter> (-v \<squnion> (-x \<sqinter> --z)))"
	+ by (simp add: sup_left_dist_inf)
	+ also have "... = (--v \<squnion> -w) \<sqinter> (--v \<squnion> --y) \<sqinter> (-v \<squnion> (-x \<sqinter> --z))"
	+ using 1 2 by (metis inf_associative)
	+ also have "... = (--v \<squnion> (-w \<sqinter> --y)) \<sqinter> (-v \<squnion> (-x \<sqinter> --z))"
	+ by (simp add: sup_left_dist_inf)
	+ also have "... = (-v \<sqinter> (-w \<sqinter> --y)) \<squnion> (--v \<sqinter> (-x \<sqinter> --z))"
	+ by (metis case_duality complement_1 complement_2 sub_inf_def)
	+ also have "... = (-v \<sqinter> -w \<sqinter> --y) \<squnion> (--v \<sqinter> -x \<sqinter> --z)"
	+ by (simp add: inf_associative)
	+ finally show ?thesis
	+ .
	+qed
	+
	+lemma inf_cases_2: "--x = -(-x \<sqinter> -y) \<sqinter> -(-x \<sqinter> --y)"
	+ using sub_inf_def sup_cases by auto
	+
	+text \<open>consequences for \<open>top\<close> and \<open>bot\<close>\<close>
	+
	+lemma sup_complement[simp]:
	+ "-x \<squnion> --x = top"
	+ using top_def by auto
	+
	+lemma inf_complement[simp]:
	+ "-x \<sqinter> --x = bot"
	+ by (metis sub_bot_def sub_inf_def sub_top_def top_def)
	+
	+lemma complement_bot[simp]:
	+ "-bot = top"
	+ using inf_complement inf_demorgan sup_complement by fastforce
	+
	+lemma complement_top[simp]:
	+ "-top = bot"
	+ using sub_bot_def sub_top_def by blast
	+
	+lemma sup_right_zero[simp]:
	+ "-x \<squnion> top = top"
	+ using sup_right_zero_var by auto
	+
	+lemma sup_left_zero[simp]:
	+ "top \<squnion> -x = top"
	+ by (metis complement_bot sub_commutative sup_right_zero)
	+
	+lemma inf_right_unit[simp]:
	+ "-x \<sqinter> bot = bot"
	+ by (metis complement_bot complement_top double_negation sub_sup_demorgan sup_right_zero)
	+
	+lemma inf_left_unit[simp]:
	+ "bot \<sqinter> -x = bot"
	+ by (metis complement_top inf_commutative inf_right_unit)
	+
	+lemma sup_right_unit[simp]:
	+ "-x \<squnion> bot = -x"
	+ using sup_right_unit_idempotent by auto
	+
	+lemma sup_left_unit[simp]:
	+ "bot \<squnion> -x = -x"
	+ by (metis complement_top sub_commutative sup_right_unit)
	+
	+lemma inf_right_zero[simp]:
	+ "-x \<sqinter> top = -x"
	+ by (metis inf_left_dist_sup sup_cases top_def)
	+
	+lemma sub_inf_left_zero[simp]:
	+ "top \<sqinter> -x = -x"
	+ using inf_absorb top_def by fastforce
	+
	+lemma bot_double_complement[simp]:
	+ "--bot = bot"
	+ by simp
	+
	+lemma top_double_complement[simp]:
	+ "--top = top"
	+ by simp
	+
	+text \<open>consequences for the order\<close>
	+
	+lemma reflexive:
	+ "-x \<le> -x"
	+ by (simp add: sub_less_eq_def)
	+
	+lemma transitive:
	+ "-x \<le> -y \<Longrightarrow> -y \<le> -z \<Longrightarrow> -x \<le> -z"
	+ by (metis sub_associative sub_less_eq_def)
	+
	+lemma antisymmetric:
	+ "-x \<le> -y \<Longrightarrow> -y \<le> -x \<Longrightarrow> -x = -y"
	+ by (simp add: sub_commutative sub_less_eq_def)
	+
	+lemma sub_bot_least:
	+ "bot \<le> -x"
	+ using sup_left_unit complement_top sub_less_eq_def by blast
	+
	+lemma top_greatest:
	+ "-x \<le> top"
	+ using complement_bot sub_less_eq_def sup_right_zero by blast
	+
	+lemma upper_bound_left:
	+ "-x \<le> -x \<squnion> -y"
	+ by (metis sub_associative sub_less_eq_def sub_sup_closed sup_idempotent)
	+
	+lemma upper_bound_right:
	+ "-y \<le> -x \<squnion> -y"
	+ using sub_commutative upper_bound_left by fastforce
	+
	+lemma sub_sup_left_isotone:
	+ assumes "-x \<le> -y"
	+ shows "-x \<squnion> -z \<le> -y \<squnion> -z"
	+proof -
	+ have "-x \<squnion> -y = -y"
	+ by (meson assms sub_less_eq_def)
	+ thus ?thesis
	+ by (metis (full_types) sub_associative sub_commutative sub_sup_closed upper_bound_left)
	+qed
	+
	+lemma sub_sup_right_isotone:
	+ "-x \<le> -y \<Longrightarrow> -z \<squnion> -x \<le> -z \<squnion> -y"
	+ by (simp add: sub_commutative sub_sup_left_isotone)
	+
	+lemma sup_isotone:
	+ assumes "-p \<le> -q"
	+ and "-r \<le> -s"
	+ shows "-p \<squnion> -r \<le> -q \<squnion> -s"
	+proof -
	+ have "\<And>x y. \<not> -x \<le> -y \<squnion> -r \<or> -x \<le> -y \<squnion> -s"
	+ by (metis (full_types) assms(2) sub_sup_closed sub_sup_right_isotone transitive)
	+ thus ?thesis
	+ by (metis (no_types) assms(1) sub_sup_closed sub_sup_left_isotone)
	+qed
	+
	+lemma sub_complement_antitone:
	+ "-x \<le> -y \<Longrightarrow> --y \<le> --x"
	+ by (metis inf_absorb inf_demorgan sub_less_eq_def)
	+
	+lemma less_eq_inf:
	+ "-x \<le> -y \<longleftrightarrow> -x \<sqinter> -y = -x"
	+ by (metis inf_absorb inf_commutative sub_less_eq_def upper_bound_right sup_absorb)
	+
	+lemma inf_complement_left_antitone:
	+ "-x \<le> -y \<Longrightarrow> -(-y \<sqinter> -z) \<le> -(-x \<sqinter> -z)"
	+ by (simp add: sub_complement_antitone inf_demorgan sub_sup_left_isotone)
	+
	+lemma sub_inf_left_isotone:
	+ "-x \<le> -y \<Longrightarrow> -x \<sqinter> -z \<le> -y \<sqinter> -z"
	+ using sub_complement_antitone inf_closed inf_complement_left_antitone by fastforce
	+
	+lemma sub_inf_right_isotone:
	+ "-x \<le> -y \<Longrightarrow> -z \<sqinter> -x \<le> -z \<sqinter> -y"
	+ by (simp add: inf_commutative sub_inf_left_isotone)
	+
	+lemma inf_isotone:
	+ assumes "-p \<le> -q"
	+ and "-r \<le> -s"
	+ shows "-p \<sqinter> -r \<le> -q \<sqinter> -s"
	+proof -
	+ have "\<forall>w x y z. (-w \<le> -x \<sqinter> -y \<or> \<not> -w \<le> -x \<sqinter> -z) \<or> \<not> -z \<le> -y"
	+ by (metis (no_types) inf_closed sub_inf_right_isotone transitive)
	+ thus ?thesis
	+ by (metis (no_types) assms inf_closed sub_inf_left_isotone)
	+qed
	+
	+lemma least_upper_bound:
	+ "-x \<le> -z \<and> -y \<le> -z \<longleftrightarrow> -x \<squnion> -y \<le> -z"
	+ by (metis sub_sup_closed transitive upper_bound_right sup_idempotent sup_isotone upper_bound_left)
	+
	+lemma lower_bound_left:
	+ "-x \<sqinter> -y \<le> -x"
	+ by (metis sub_inf_def upper_bound_right sup_absorb)
	+
	+lemma lower_bound_right:
	+ "-x \<sqinter> -y \<le> -y"
	+ using inf_commutative lower_bound_left by fastforce
	+
	+lemma greatest_lower_bound:
	+ "-x \<le> -y \<and> -x \<le> -z \<longleftrightarrow> -x \<le> -y \<sqinter> -z"
	+ by (metis inf_closed sub_inf_left_isotone less_eq_inf transitive lower_bound_left lower_bound_right)
	+
	+lemma less_eq_sup_top:
	+ "-x \<le> -y \<longleftrightarrow> --x \<squnion> -y = top"
	+ by (metis complement_1 inf_commutative inf_complement_intro sub_inf_left_zero less_eq_inf sub_complement sup_complement_intro top_def)
	+
	+lemma less_eq_inf_bot:
	+ "-x \<le> -y \<longleftrightarrow> -x \<sqinter> --y = bot"
	+ by (metis complement_bot complement_top double_negation inf_demorgan less_eq_sup_top sub_inf_def)
	+
	+lemma shunting:
	+ "-x \<sqinter> -y \<le> -z \<longleftrightarrow> -y \<le> --x \<squnion> -z"
	+proof (cases "--x \<squnion> (-z \<squnion> --y) = top")
	+ case True
	+ have "\<forall>v w. -v \<le> -w \<or> -w \<squnion> --v \<noteq> top"
	+ using less_eq_sup_top sub_commutative by blast
	+ thus ?thesis
	+ by (metis True sub_associative sub_commutative sub_inf_def sub_sup_closed)
	+next
	+ case False
	+ hence "--x \<squnion> (-z \<squnion> --y) \<noteq> top \<and> \<not> -y \<le> -z \<squnion> --x"
	+ by (metis (no_types) less_eq_sup_top sub_associative sub_commutative sub_sup_closed)
	+ thus ?thesis
	+ using less_eq_sup_top sub_associative sub_commutative sub_inf_def sub_sup_closed by auto
	+qed
	+
	+lemma shunting_right:
	+ "-x \<sqinter> -y \<le> -z \<longleftrightarrow> -x \<le> -z \<squnion> --y"
	+ by (metis inf_commutative sub_commutative shunting)
	+
	+lemma sup_less_eq_cases:
	+ assumes "-z \<le> -x \<squnion> -y"
	+ and "-z \<le> --x \<squnion> -y"
	+ shows "-z \<le> -y"
	+proof -
	+ have "-z \<le> (-x \<squnion> -y) \<sqinter> (--x \<squnion> -y)"
	+ by (metis assms greatest_lower_bound sub_sup_closed)
	+ also have "... = -y"
	+ by (metis inf_cases sub_commutative)
	+ finally show ?thesis
	+ .
	+qed
	+
	+lemma sup_less_eq_cases_2:
	+ "-x \<squnion> -y \<le> -x \<squnion> -z \<Longrightarrow> --x \<squnion> -y \<le> --x \<squnion> -z \<Longrightarrow> -y \<le> -z"
	+ by (metis least_upper_bound sup_less_eq_cases sub_sup_closed)
	+
	+lemma sup_less_eq_cases_3:
	+ "-y \<squnion> -x \<le> -z \<squnion> -x \<Longrightarrow> -y \<squnion> --x \<le> -z \<squnion> --x \<Longrightarrow> -y \<le> -z"
	+ by (simp add: sup_less_eq_cases_2 sub_commutative)
	+
	+lemma inf_less_eq_cases:
	+ "-x \<sqinter> -y \<le> -z \<Longrightarrow> --x \<sqinter> -y \<le> -z \<Longrightarrow> -y \<le> -z"
	+ by (simp add: shunting sup_less_eq_cases)
	+
	+lemma inf_less_eq_cases_2:
	+ "-x \<sqinter> -y \<le> -x \<sqinter> -z \<Longrightarrow> --x \<sqinter> -y \<le> --x \<sqinter> -z \<Longrightarrow> -y \<le> -z"
	+ by (metis greatest_lower_bound inf_closed inf_less_eq_cases)
	+
	+lemma inf_less_eq_cases_3:
	+ "-y \<sqinter> -x \<le> -z \<sqinter> -x \<Longrightarrow> -y \<sqinter> --x \<le> -z \<sqinter> --x \<Longrightarrow> -y \<le> -z"
	+ by (simp add: inf_commutative inf_less_eq_cases_2)
	+
	+lemma inf_eq_cases:
	+ "-x \<sqinter> -y = -x \<sqinter> -z \<Longrightarrow> --x \<sqinter> -y = --x \<sqinter> -z \<Longrightarrow> -y = -z"
	+ by (metis inf_commutative sup_cases)
	+
	+lemma inf_eq_cases_2:
	+ "-y \<sqinter> -x = -z \<sqinter> -x \<Longrightarrow> -y \<sqinter> --x = -z \<sqinter> --x \<Longrightarrow> -y = -z"
	+ using inf_commutative inf_eq_cases by auto
	+
	+lemma wnf_lemma_1:
	+ "((-x \<squnion> -y) \<sqinter> (--x \<squnion> -z)) \<squnion> -x = -x \<squnion> -y"
	+proof -
	+ have "\<forall>u v w. (-u \<sqinter> (-v \<squnion> --w)) \<squnion> -w = -u \<squnion> -w"
	+ by (metis inf_right_zero sub_associative sub_sup_closed sup_complement sup_idempotent sup_right_dist_inf)
	+ thus ?thesis
	+ by (metis (no_types) sub_associative sub_commutative sub_sup_closed sup_idempotent)
	+qed
	+
	+lemma wnf_lemma_2:
	+ "((-x \<squnion> -y) \<sqinter> (-z \<squnion> --y)) \<squnion> -y = -x \<squnion> -y"
	+ using sub_commutative wnf_lemma_1 by fastforce
	+
	+lemma wnf_lemma_3:
	+ "((-x \<squnion> -z) \<sqinter> (--x \<squnion> -y)) \<squnion> --x = --x \<squnion> -y"
	+ by (metis case_duality case_duality_2 double_negation sub_commutative wnf_lemma_2)
	+
	+lemma wnf_lemma_4:
	+ "((-z \<squnion> -y) \<sqinter> (-x \<squnion> --y)) \<squnion> --y = -x \<squnion> --y"
	+ using sub_commutative wnf_lemma_3 by auto
	+
	+end
	+
	+class subset_boolean_algebra' = sup + uminus +
	+ assumes sub_associative': "-x \<squnion> (-y \<squnion> -z) = (-x \<squnion> -y) \<squnion> -z"
	+ assumes sub_commutative': "-x \<squnion> -y = -y \<squnion> -x"
	+ assumes sub_complement': "-x = -(--x \<squnion> -y) \<squnion> -(--x \<squnion> --y)"
	+ assumes sub_sup_closed': "\<exists>z . -x \<squnion> -y = -z"
	+begin
	+
	+subclass subset_boolean_algebra
	+proof
	+ show "\<And>x y z. - x \<squnion> (- y \<squnion> - z) = - x \<squnion> - y \<squnion> - z"
	+ by (simp add: sub_associative')
	+ show "\<And>x y. - x \<squnion> - y = - y \<squnion> - x"
	+ by (simp add: sub_commutative')
	+ show "\<And>x y. - x = - (- - x \<squnion> - y) \<squnion> - (- - x \<squnion> - - y)"
	+ by (simp add: sub_complement')
	+ show "\<And>x y. - x \<squnion> - y = - - (- x \<squnion> - y)"
	+ proof -
	+ fix x y
	+ have "\<forall>x y. -y \<squnion> (-(--y \<squnion> -x) \<squnion> -(---x \<squnion> -y)) = -y \<squnion> --x"
	+ by (metis (no_types) sub_associative' sub_commutative' sub_complement')
	+ hence "\<forall>x. ---x = -x"
	+ by (metis (no_types) sub_commutative' sub_complement')
	+ thus "-x \<squnion> -y = --(-x \<squnion> -y)"
	+ by (metis sub_sup_closed')
	+ qed
	+qed
	+
	+end
	+
	+text \<open>
	+We introduce a type for the range of complement and show that it is an instance of \<open>boolean_algebra\<close>.
	+\<close>
	+
	+typedef (overloaded) 'a boolean_subset = "{ x::'a::uminus . \<exists>y . x = -y }"
	+ by auto
	+
	+lemma simp_boolean_subset[simp]:
	+ "\<exists>y . Rep_boolean_subset x = -y"
	+ using Rep_boolean_subset by simp
	+
	+setup_lifting type_definition_boolean_subset
	+
	+text \<open>Theorem 8.1\<close>
	+
	+instantiation boolean_subset :: (subset_boolean_algebra) huntington
	+begin
	+
	+lift_definition sup_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> 'a boolean_subset" is sup
	+ using sub_sup_closed by auto
	+
	+lift_definition uminus_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset" is uminus
	+ by auto
	+
	+instance
	+proof
	+ show "\<And>x y z::'a boolean_subset. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ apply transfer
	+ using sub_associative by blast
	+ show "\<And>x y::'a boolean_subset. x \<squnion> y = y \<squnion> x"
	+ apply transfer
	+ using sub_commutative by blast
	+ show "\<And>x y::'a boolean_subset. x = - (- x \<squnion> y) \<squnion> - (- x \<squnion> - y)"
	+ apply transfer
	+ using sub_complement by blast
	+qed
	+
	+end
	+
	+text \<open>Theorem 8.2\<close>
	+
	+instantiation boolean_subset :: (subset_boolean_algebra_extended) huntington_extended
	+begin
	+
	+lift_definition inf_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> 'a boolean_subset" is inf
	+ using inf_closed by auto
	+
	+lift_definition minus_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> 'a boolean_subset" is minus
	+ using sub_minus_def by auto
	+
	+lift_definition bot_boolean_subset :: "'a boolean_subset" is bot
	+ by (metis complement_top)
	+
	+lift_definition top_boolean_subset :: "'a boolean_subset" is top
	+ by (metis complement_bot)
	+
	+lift_definition less_eq_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> bool" is less_eq .
	+
	+lift_definition less_boolean_subset :: "'a boolean_subset \<Rightarrow> 'a boolean_subset \<Rightarrow> bool" is less .
	+
	+instance
	+proof
	+ show 1: "top = (THE x. \<forall>y::'a boolean_subset. x = y \<squnion> - y)"
	+ proof (rule the_equality[symmetric])
	+ show "\<forall>y::'a boolean_subset. top = y \<squnion> - y"
	+ apply transfer
	+ by auto
	+ show "\<And>x::'a boolean_subset. \<forall>y. x = y \<squnion> - y \<Longrightarrow> x = top"
	+ apply transfer
	+ by force
	+ qed
	+ have "(bot::'a boolean_subset) = - top"
	+ apply transfer
	+ by simp
	+ thus "bot = - (THE x. \<forall>y::'a boolean_subset. x = y \<squnion> - y)"
	+ using 1 by simp
	+ show "\<And>x y::'a boolean_subset. x \<sqinter> y = - (- x \<squnion> - y)"
	+ apply transfer
	+ using sub_inf_def by blast
	+ show "\<And>x y::'a boolean_subset. x - y = - (- x \<squnion> y)"
	+ apply transfer
	+ using sub_minus_def by blast
	+ show "\<And>x y::'a boolean_subset. (x \<le> y) = (x \<squnion> y = y)"
	+ apply transfer
	+ using sub_less_eq_def by blast
	+ show "\<And>x y::'a boolean_subset. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
	+ apply transfer
	+ using sub_less_def by blast
	+qed
	+
	+end
	+
	+section \<open>Subset Boolean algebras with Additional Structure\<close>
	+
	+text \<open>
	+We now discuss axioms that make the range of a unary operation a Boolean algebra, but add further properties that are common to the intended models.
	+In the intended models, the unary operation can be a complement, a pseudocomplement or the antidomain operation.
	+For simplicity, we mostly call the unary operation `complement'.
	+
	+We first look at structures based only on join and complement, and then add axioms for the remaining operations of Boolean algebras.
	+In the intended models, the operation that is meet on the range of the complement can be a meet in the whole algebra or composition.
	+\<close>
	+
	+subsection \<open>Axioms Derived from the New Axiomatisation\<close>
	+
	+text \<open>
	+The axioms of the first algebra are based on \<open>boolean_algebra_3\<close>.
	+\<close>
	+
	+text \<open>Definition 9\<close>
	+
	+class subset_boolean_algebra_1 = sup + uminus +
	+ assumes sba1_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ assumes sba1_commutative: "x \<squnion> y = y \<squnion> x"
	+ assumes sba1_idempotent[simp]: "x \<squnion> x = x"
	+ assumes sba1_double_complement[simp]: "---x = -x"
	+ assumes sba1_bot_unique: "-(x \<squnion> -x) = -(y \<squnion> -y)"
	+ assumes sba1_export: "-x \<squnion> -(-x \<squnion> y) = -x \<squnion> -y"
	+begin
	+
	+text \<open>Theorem 11.1\<close>
	+
	+subclass subset_boolean_algebra
	+proof
	+ show "\<And>x y z. - x \<squnion> (- y \<squnion> - z) = - x \<squnion> - y \<squnion> - z"
	+ by (simp add: sba1_associative)
	+ show "\<And>x y. - x \<squnion> - y = - y \<squnion> - x"
	+ by (simp add: sba1_commutative)
	+ show "\<And>x y. - x = - (- - x \<squnion> - y) \<squnion> - (- - x \<squnion> - - y)"
	+ by (smt sba1_bot_unique sba1_commutative sba1_double_complement sba1_export sba1_idempotent)
	+ thus "\<And>x y. - x \<squnion> - y = - - (- x \<squnion> - y)"
	+ by (metis sba1_double_complement sba1_export)
	+qed
	+
	+definition "sba1_bot \<equiv> THE x . \<forall>z . x = -(z \<squnion> -z)"
	+
	+lemma sba1_bot:
	+ "sba1_bot = -(z \<squnion> -z)"
	+ using sba1_bot_def sba1_bot_unique by auto
	+
	+end
	+
	+text \<open>Boolean algebra operations based on join and complement\<close>
	+
	+text \<open>Definition 10\<close>
	+
	+class subset_extended_1 = sup + inf + minus + uminus + bot + top + ord +
	+ assumes ba_bot: "bot = (THE x . \<forall>z . x = -(z \<squnion> -z))"
	+ assumes ba_top: "top = -(THE x . \<forall>z . x = -(z \<squnion> -z))"
	+ assumes ba_inf: "-x \<sqinter> -y = -(--x \<squnion> --y)"
	+ assumes ba_minus: "-x - -y = -(--x \<squnion> -y)"
	+ assumes ba_less_eq: "x \<le> y \<longleftrightarrow> x \<squnion> y = y"
	+ assumes ba_less: "x < y \<longleftrightarrow> x \<squnion> y = y \<and> \<not> (y \<squnion> x = x)"
	+
	+class subset_extended_2 = subset_extended_1 +
	+ assumes ba_bot_unique: "-(x \<squnion> -x) = -(y \<squnion> -y)"
	+begin
	+
	+lemma ba_bot_def:
	+ "bot = -(z \<squnion> -z)"
	+ using ba_bot ba_bot_unique by auto
	+
	+lemma ba_top_def:
	+ "top = --(z \<squnion> -z)"
	+ using ba_bot_def ba_top by simp
	+
	+end
	+
	+text \<open>Subset forms Boolean Algebra, extended by Boolean algebra operations\<close>
	+
	+class subset_boolean_algebra_1_extended = subset_boolean_algebra_1 + subset_extended_1
	+begin
	+
	+subclass subset_extended_2
	+proof
	+ show "\<And>x y. - (x \<squnion> - x) = - (y \<squnion> - y)"
	+ by (simp add: sba1_bot_unique)
	+qed
	+
	+subclass semilattice_sup
	+proof
	+ show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
	+ by (simp add: ba_less ba_less_eq)
	+ show "\<And>x. x \<le> x"
	+ by (simp add: ba_less_eq)
	+ show "\<And>x y z. x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
	+ by (metis sba1_associative ba_less_eq)
	+ show "\<And>x y. x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
	+ by (simp add: sba1_commutative ba_less_eq)
	+ show "\<And>x y. x \<le> x \<squnion> y"
	+ by (simp add: sba1_associative ba_less_eq)
	+ thus "\<And>y x. y \<le> x \<squnion> y"
	+ by (simp add: sba1_commutative)
	+ show "\<And>y x z. y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
	+ by (metis sba1_associative ba_less_eq)
	+qed
	+
	+text \<open>Theorem 11.2\<close>
	+
	+subclass subset_boolean_algebra_extended
	+proof
	+ show "top = (THE x. \<forall>y. x = - y \<squnion> - - y)"
	+ by (smt ba_bot ba_bot_def ba_top sub_sup_closed the_equality)
	+ thus "bot = - (THE x. \<forall>y. x = - y \<squnion> - - y)"
	+ using ba_bot_def ba_top_def by force
	+ show "\<And>x y. - x \<sqinter> - y = - (- - x \<squnion> - - y)"
	+ by (simp add: ba_inf)
	+ show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
	+ by (simp add: ba_minus)
	+ show "\<And>x y. (- x \<le> - y) = (- x \<squnion> - y = - y)"
	+ using le_iff_sup by auto
	+ show "\<And>x y. (- x < - y) = (- x \<squnion> - y = - y \<and> - y \<squnion> - x \<noteq> - x)"
	+ by (simp add: ba_less)
	+qed
	+
	+end
	+
	+subsection \<open>Stronger Assumptions based on Join and Complement\<close>
	+
	+text \<open>
	+We add further axioms covering properties common to the antidomain and (pseudo)complement instances.
	+\<close>
	+
	+text \<open>Definition 12\<close>
	+
	+class subset_boolean_algebra_2 = sup + uminus +
	+ assumes sba2_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ assumes sba2_commutative: "x \<squnion> y = y \<squnion> x"
	+ assumes sba2_idempotent[simp]: "x \<squnion> x = x"
	+ assumes sba2_bot_unit: "x \<squnion> -(y \<squnion> -y) = x"
	+ assumes sba2_sub_sup_demorgan: "-(x \<squnion> y) = -(--x \<squnion> --y)"
	+ assumes sba2_export: "-x \<squnion> -(-x \<squnion> y) = -x \<squnion> -y"
	+begin
	+
	+text \<open>Theorem 13.1\<close>
	+
	+subclass subset_boolean_algebra_1
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (simp add: sba2_associative)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (simp add: sba2_commutative)
	+ show "\<And>x. x \<squnion> x = x"
	+ by simp
	+ show "\<And>x. - - - x = - x"
	+ by (metis sba2_idempotent sba2_sub_sup_demorgan)
	+ show "\<And>x y. - (x \<squnion> - x) = - (y \<squnion> - y)"
	+ by (metis sba2_bot_unit sba2_commutative)
	+ show "\<And>x y. - x \<squnion> - (- x \<squnion> y) = - x \<squnion> - y"
	+ by (simp add: sba2_export)
	+qed
	+
	+text \<open>Theorem 13.2\<close>
	+
	+lemma double_complement_dist_sup:
	+ "--(x \<squnion> y) = --x \<squnion> --y"
	+ by (metis sba2_commutative sba2_export sba2_idempotent sba2_sub_sup_demorgan)
	+
	+lemma maddux_3_3[simp]:
	+ "-(x \<squnion> y) \<squnion> -(x \<squnion> -y) = -x"
	+ by (metis double_complement_dist_sup sba1_double_complement sba2_commutative sub_complement)
	+
	+lemma huntington_3_pp[simp]:
	+ "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = --x"
	+ using sba2_commutative maddux_3_3 by fastforce
	+
	+end
	+
	+class subset_boolean_algebra_2_extended = subset_boolean_algebra_2 + subset_extended_1
	+begin
	+
	+subclass subset_boolean_algebra_1_extended ..
	+
	+subclass bounded_semilattice_sup_bot
	+proof
	+ show "\<And>x. bot \<le> x"
	+ using sba2_bot_unit ba_bot_def sup_right_divisibility by auto
	+qed
	+
	+text \<open>Theorem 13.3\<close>
	+
	+lemma complement_antitone:
	+ "x \<le> y \<Longrightarrow> -y \<le> -x"
	+ by (metis le_iff_sup maddux_3_3 sba2_export sup_monoid.add_commute)
	+
	+lemma double_complement_isotone:
	+ "x \<le> y \<Longrightarrow> --x \<le> --y"
	+ by (simp add: complement_antitone)
	+
	+lemma sup_demorgan:
	+ "-(x \<squnion> y) = -x \<sqinter> -y"
	+ using sba2_sub_sup_demorgan ba_inf by auto
	+
	+end
	+
	+subsection \<open>Axioms for Meet\<close>
	+
	+text \<open>
	+We add further axioms of \<open>inf\<close> covering properties common to the antidomain and pseudocomplement instances.
	+We omit the left distributivity rule and the right zero rule as they do not hold in some models.
	+In particular, the operation \<open>inf\<close> does not have to be commutative.
	+\<close>
	+
	+text \<open>Definition 14\<close>
	+
	+class subset_boolean_algebra_3_extended = subset_boolean_algebra_2_extended +
	+ assumes sba3_inf_associative: "x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
	+ assumes sba3_inf_right_dist_sup: "(x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
	+ assumes sba3_inf_complement_bot: "-x \<sqinter> x = bot"
	+ assumes sba3_inf_left_unit[simp]: "top \<sqinter> x = x"
	+ assumes sba3_complement_inf_double_complement: "-(x \<sqinter> --y) = -(x \<sqinter> y)"
	+begin
	+
	+text \<open>Theorem 15\<close>
	+
	+lemma inf_left_zero:
	+ "bot \<sqinter> x = bot"
	+ by (metis inf_right_unit sba3_inf_associative sba3_inf_complement_bot)
	+
	+lemma inf_double_complement_export:
	+ "--(--x \<sqinter> y) = --x \<sqinter> --y"
	+ by (metis inf_closed sba3_complement_inf_double_complement)
	+
	+lemma inf_left_isotone:
	+ "x \<le> y \<Longrightarrow> x \<sqinter> z \<le> y \<sqinter> z"
	+ using sba3_inf_right_dist_sup sup_right_divisibility by auto
	+
	+lemma inf_complement_export:
	+ "--(-x \<sqinter> y) = -x \<sqinter> --y"
	+ by (metis inf_double_complement_export sba1_double_complement)
	+
	+lemma double_complement_above:
	+ "--x \<sqinter> x = x"
	+ by (metis sup_monoid.add_0_right complement_bot inf_demorgan sba1_double_complement sba3_inf_complement_bot sba3_inf_right_dist_sup sba3_inf_left_unit)
	+
	+lemma "x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y" nitpick [expect=genuine] oops
	+lemma "x \<sqinter> top = x" nitpick [expect=genuine] oops
	+lemma "x \<sqinter> y = y \<sqinter> x" nitpick [expect=genuine] oops
	+
	+end
	+
	+subsection \<open>Stronger Assumptions for Meet\<close>
	+
	+text \<open>
	+The following axioms also hold in both models, but follow from the axioms of \<open>subset_boolean_algebra_5_operations\<close>.
	+\<close>
	+
	+text \<open>Definition 16\<close>
	+
	+class subset_boolean_algebra_4_extended = subset_boolean_algebra_3_extended +
	+ assumes sba4_inf_right_unit[simp]: "x \<sqinter> top = x"
	+ assumes inf_right_isotone: "x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
	+begin
	+
	+lemma "x \<squnion> top = top" nitpick [expect=genuine] oops
	+lemma "x \<sqinter> bot = bot" nitpick [expect=genuine] oops
	+lemma "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)" nitpick [expect=genuine] oops
	+lemma "(x \<sqinter> y = bot) = (x \<le> - y)" nitpick [expect=genuine] oops
	+
	+end
	+
	+section \<open>Boolean Algebras in Stone Algebras\<close>
	+
	+text \<open>
	+We specialise \<open>inf\<close> to meet and complement to pseudocomplement.
	+This puts Stone algebras into the picture; for these it is well known that regular elements form a Boolean subalgebra \cite{Graetzer1971}.
	+\<close>
	+
	+text \<open>Definition 17\<close>
	+
	+class subset_boolean_algebra_5_extended = subset_boolean_algebra_3_extended +
	+ assumes sba5_inf_commutative: "x \<sqinter> y = y \<sqinter> x"
	+ assumes sba5_inf_absorb: "x \<sqinter> (x \<squnion> y) = x"
	+begin
	+
	+subclass distrib_lattice_bot
	+proof
	+ show "\<And>x y. x \<sqinter> y \<le> x"
	+ by (metis sba5_inf_commutative sba3_inf_right_dist_sup sba5_inf_absorb sup_right_divisibility)
	+ show "\<And>x y. x \<sqinter> y \<le> y"
	+ by (metis inf_left_isotone sba5_inf_absorb sba5_inf_commutative sup_ge2)
	+ show "\<And>x y z. x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
	+ by (metis inf_left_isotone sba5_inf_absorb sup.orderE sup_monoid.add_commute)
	+ show "\<And>x y z. x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z) "
	+ by (metis sba3_inf_right_dist_sup sba5_inf_absorb sba5_inf_commutative sup_assoc)
	+qed
	+
	+lemma inf_demorgan_2:
	+ "-(x \<sqinter> y) = -x \<squnion> -y"
	+ using sba3_complement_inf_double_complement sba5_inf_commutative sub_sup_closed sub_sup_demorgan by auto
	+
	+lemma inf_export:
	+ "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
	+ using inf_demorgan_2 sba3_inf_complement_bot sba3_inf_right_dist_sup sba5_inf_commutative by auto
	+
	+lemma complement_inf[simp]:
	+ "x \<sqinter> -x = bot"
	+ using sba3_inf_complement_bot sba5_inf_commutative by auto
	+
	+text \<open>Theorem 18.2\<close>
	+
	+subclass stone_algebra
	+proof
	+ show "\<And>x. x \<le> top"
	+ by (simp add: inf.absorb_iff2)
	+ show "\<And>x y. (x \<sqinter> y = bot) = (x \<le> - y)"
	+ by (metis (full_types) complement_bot complement_inf inf.cobounded1 inf.order_iff inf_export sba3_complement_inf_double_complement sba3_inf_left_unit)
	+ show "\<And>x. - x \<squnion> - - x = top"
	+ by simp
	+qed
	+
	+text \<open>Theorem 18.1\<close>
	+
	+subclass subset_boolean_algebra_4_extended
	+proof
	+ show "\<And>x. x \<sqinter> top = x"
	+ by simp
	+ show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
	+ using inf.sup_right_isotone by blast
	+qed
	+
	+end
	+
	+context stone_algebra_extended
	+begin
	+
	+text \<open>Theorem 18.3\<close>
	+
	+subclass subset_boolean_algebra_5_extended
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ using sup_assoc by auto
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (simp add: sup_commute)
	+ show "\<And>x. x \<squnion> x = x"
	+ by simp
	+ show "\<And>x y. x \<squnion> - (y \<squnion> - y) = x"
	+ by simp
	+ show "\<And>x y. - (x \<squnion> y) = - (- - x \<squnion> - - y)"
	+ by auto
	+ show "\<And>x y. - x \<squnion> - (- x \<squnion> y) = - x \<squnion> - y"
	+ by (metis maddux_3_21_pp p_dist_sup regular_closed_p)
	+ show "bot = (THE x. \<forall>z. x = - (z \<squnion> - z))"
	+ by simp
	+ thus "top = - (THE x. \<forall>z. x = - (z \<squnion> - z))"
	+ using p_bot by blast
	+ show "\<And>x y. - x \<sqinter> - y = - (- - x \<squnion> - - y)"
	+ by simp
	+ show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
	+ by auto
	+ show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
	+ by (simp add: le_iff_sup)
	+ thus "\<And>x y. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
	+ by (simp add: less_le_not_le)
	+ show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
	+ by (simp add: inf.sup_monoid.add_assoc)
	+ show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
	+ by (simp add: inf_sup_distrib2)
	+ show "\<And>x. - x \<sqinter> x = bot"
	+ by simp
	+ show "\<And>x. top \<sqinter> x = x"
	+ by simp
	+ show "\<And>x y. - (x \<sqinter> - - y) = - (x \<sqinter> y)"
	+ by simp
	+ show "\<And>x y. x \<sqinter> y = y \<sqinter> x"
	+ by (simp add: inf_commute)
	+ show "\<And>x y. x \<sqinter> (x \<squnion> y) = x"
	+ by simp
	+qed
	+
	+end
	+
	+section \<open>Domain Semirings\<close>
	+
	+text \<open>
	+The following development of tests in IL-semirings, prepredomain semirings, predomain semirings and domain semirings is mostly based on \cite{MoellerDesharnais2019}; see also \cite{DesharnaisMoeller2014}.
	+See \cite{DesharnaisMoellerStruth2006b} for domain axioms in idempotent semirings.
	+See \cite{DesharnaisJipsenStruth2009,JacksonStokes2004} for domain axioms in semigroups and monoids.
	+Some variants have been implemented in \cite{GomesGuttmannHoefnerStruthWeber2016}.
	+\<close>
	+
	+subsection \<open>Idempotent Left Semirings\<close>
	+
	+text \<open>Definition 19\<close>
	+
	+class il_semiring = sup + inf + bot + top + ord +
	+ assumes il_associative: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ assumes il_commutative: "x \<squnion> y = y \<squnion> x"
	+ assumes il_idempotent[simp]: "x \<squnion> x = x"
	+ assumes il_bot_unit: "x \<squnion> bot = x"
	+ assumes il_inf_associative: "x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
	+ assumes il_inf_right_dist_sup: "(x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
	+ assumes il_inf_left_unit[simp]: "top \<sqinter> x = x"
	+ assumes il_inf_right_unit[simp]: "x \<sqinter> top = x"
	+ assumes il_sub_inf_left_zero[simp]: "bot \<sqinter> x = bot"
	+ assumes il_sub_inf_right_isotone: "x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
	+ assumes il_less_eq: "x \<le> y \<longleftrightarrow> x \<squnion> y = y"
	+ assumes il_less_def: "x < y \<longleftrightarrow> x \<le> y \<and> \<not>(y \<le> x)"
	+begin
	+
	+lemma il_unit_bot: "bot \<squnion> x = x"
	+ using il_bot_unit il_commutative by fastforce
	+
	+subclass order
	+proof
	+ show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
	+ by (simp add: il_less_def)
	+ show "\<And>x. x \<le> x"
	+ by (simp add: il_less_eq)
	+ show "\<And>x y z. x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
	+ by (metis il_associative il_less_eq)
	+ show "\<And>x y. x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
	+ by (simp add: il_commutative il_less_eq)
	+qed
	+
	+lemma il_sub_inf_right_isotone_var:
	+ "(x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
	+ by (smt il_associative il_commutative il_idempotent il_less_eq il_sub_inf_right_isotone)
	+
	+lemma il_sub_inf_left_isotone:
	+ "x \<le> y \<Longrightarrow> x \<sqinter> z \<le> y \<sqinter> z"
	+ by (metis il_inf_right_dist_sup il_less_eq)
	+
	+lemma il_sub_inf_left_isotone_var:
	+ "(y \<sqinter> x) \<squnion> (z \<sqinter> x) \<le> (y \<squnion> z) \<sqinter> x"
	+ by (simp add: il_inf_right_dist_sup)
	+
	+lemma sup_left_isotone:
	+ "x \<le> y \<Longrightarrow> x \<squnion> z \<le> y \<squnion> z"
	+ by (smt il_associative il_commutative il_idempotent il_less_eq)
	+
	+lemma sup_right_isotone:
	+ "x \<le> y \<Longrightarrow> z \<squnion> x \<le> z \<squnion> y"
	+ by (simp add: il_commutative sup_left_isotone)
	+
	+lemma bot_least:
	+ "bot \<le> x"
	+ by (simp add: il_less_eq il_unit_bot)
	+
	+lemma less_eq_bot:
	+ "x \<le> bot \<longleftrightarrow> x = bot"
	+ by (simp add: il_bot_unit il_less_eq)
	+
	+abbreviation are_complementary :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
	+ where "are_complementary x y \<equiv> x \<squnion> y = top \<and> x \<sqinter> y = bot \<and> y \<sqinter> x = bot"
	+
	+abbreviation test :: "'a \<Rightarrow> bool"
	+ where "test x \<equiv> \<exists>y . are_complementary x y"
	+
	+definition tests :: "'a set"
	+ where "tests = { x . test x }"
	+
	+lemma bot_test:
	+ "test bot"
	+ by (simp add: il_unit_bot)
	+
	+lemma top_test:
	+ "test top"
	+ by (simp add: il_bot_unit)
	+
	+lemma test_sub_identity:
	+ "test x \<Longrightarrow> x \<le> top"
	+ using il_associative il_less_eq by auto
	+
	+lemma neg_unique:
	+ "are_complementary x y \<Longrightarrow> are_complementary x z \<Longrightarrow> y = z"
	+ by (metis antisym il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone_var)
	+
	+definition neg :: "'a \<Rightarrow> 'a" ("!")
	+ where "!x \<equiv> THE y . are_complementary x y"
	+
	+lemma neg_char:
	+ assumes "test x"
	+ shows "are_complementary x (!x)"
	+proof (unfold neg_def)
	+ from assms obtain y where 1: "are_complementary x y"
	+ by auto
	+ show "are_complementary x (THE y. are_complementary x y)"
	+ proof (rule theI)
	+ show "are_complementary x y"
	+ using 1 by simp
	+ show "\<And>z. are_complementary x z \<Longrightarrow> z = y"
	+ using 1 neg_unique by blast
	+ qed
	+qed
	+
	+lemma are_complementary_symmetric:
	+ "are_complementary x y \<longleftrightarrow> are_complementary y x"
	+ using il_commutative by auto
	+
	+lemma neg_test:
	+ "test x \<Longrightarrow> test (!x)"
	+ using are_complementary_symmetric neg_char by blast
	+
	+lemma are_complementary_test:
	+ "test x \<Longrightarrow> are_complementary x y \<Longrightarrow> test y"
	+ using il_commutative by auto
	+
	+lemma neg_involutive:
	+ "test x \<Longrightarrow> !(!x) = x"
	+ using are_complementary_symmetric neg_char neg_unique by blast
	+
	+lemma test_inf_left_below:
	+ "test x \<Longrightarrow> x \<sqinter> y \<le> y"
	+ by (metis il_associative il_idempotent il_inf_left_unit il_inf_right_dist_sup il_less_eq)
	+
	+lemma test_inf_right_below:
	+ "test x \<Longrightarrow> y \<sqinter> x \<le> y"
	+ by (metis il_inf_right_unit il_sub_inf_right_isotone test_sub_identity)
	+
	+lemma neg_bot:
	+ "!bot = top"
	+ using il_unit_bot neg_char by fastforce
	+
	+lemma neg_top:
	+ "!top = bot"
	+ using bot_test neg_bot neg_involutive by fastforce
	+
	+lemma test_inf_idempotent:
	+ "test x \<Longrightarrow> x \<sqinter> x = x"
	+ by (metis il_bot_unit il_inf_left_unit il_inf_right_dist_sup)
	+
	+lemma test_inf_semicommutative:
	+ assumes "test x"
	+ and "test y"
	+ shows "x \<sqinter> y \<le> y \<sqinter> x"
	+proof -
	+ have "x \<sqinter> y = (y \<sqinter> x \<sqinter> y) \<squnion> (!y \<sqinter> x \<sqinter> y)"
	+ by (metis assms(2) il_inf_left_unit il_inf_right_dist_sup neg_char)
	+ also have "... \<le> (y \<sqinter> x \<sqinter> y) \<squnion> (!y \<sqinter> y)"
	+ proof -
	+ obtain z where "are_complementary y z"
	+ using assms(2) by blast
	+ hence "y \<sqinter> (x \<sqinter> y) \<squnion> !y \<sqinter> (x \<sqinter> y) \<le> y \<sqinter> (x \<sqinter> y)"
	+ by (metis assms(1) calculation il_sub_inf_left_isotone il_bot_unit il_idempotent il_inf_associative il_less_eq neg_char test_inf_right_below)
	+ thus ?thesis
	+ by (simp add: il_associative il_inf_associative il_less_eq)
	+ qed
	+ also have "... \<le> (y \<sqinter> x) \<squnion> (!y \<sqinter> y)"
	+ by (metis assms(2) il_bot_unit il_inf_right_unit il_sub_inf_right_isotone neg_char test_sub_identity)
	+ also have "... = y \<sqinter> x"
	+ by (simp add: assms(2) il_bot_unit neg_char)
	+ finally show ?thesis
	+ .
	+qed
	+
	+lemma test_inf_commutative:
	+ "test x \<Longrightarrow> test y \<Longrightarrow> x \<sqinter> y = y \<sqinter> x"
	+ by (simp add: antisym test_inf_semicommutative)
	+
	+lemma test_inf_bot:
	+ "test x \<Longrightarrow> x \<sqinter> bot = bot"
	+ using il_inf_associative test_inf_idempotent by fastforce
	+
	+lemma test_absorb_1:
	+ "test x \<Longrightarrow> test y \<Longrightarrow> x \<squnion> (x \<sqinter> y) = x"
	+ using il_commutative il_less_eq test_inf_right_below by auto
	+
	+lemma test_absorb_2:
	+ "test x \<Longrightarrow> test y \<Longrightarrow> x \<squnion> (y \<sqinter> x) = x"
	+ by (metis test_absorb_1 test_inf_commutative)
	+
	+lemma test_absorb_3:
	+ "test x \<Longrightarrow> test y \<Longrightarrow> x \<sqinter> (x \<squnion> y) = x"
	+ apply (rule antisym)
	+ apply (metis il_associative il_inf_right_unit il_less_eq il_sub_inf_right_isotone test_sub_identity)
	+ by (metis il_sub_inf_right_isotone_var test_absorb_1 test_inf_idempotent)
	+
	+lemma test_absorb_4:
	+ "test x \<Longrightarrow> test y \<Longrightarrow> (x \<squnion> y) \<sqinter> x = x"
	+ by (smt il_inf_right_dist_sup test_inf_idempotent il_commutative il_less_eq test_inf_left_below)
	+
	+lemma test_import_1:
	+ assumes "test x"
	+ and "test y"
	+ shows "x \<squnion> (!x \<sqinter> y) = x \<squnion> y"
	+proof -
	+ have "x \<squnion> (!x \<sqinter> y) = x \<squnion> ((y \<squnion> !y) \<sqinter> x) \<squnion> (!x \<sqinter> y)"
	+ by (simp add: assms(2) neg_char)
	+ also have "... = x \<squnion> (!y \<sqinter> x) \<squnion> (x \<sqinter> y) \<squnion> (!x \<sqinter> y)"
	+ by (smt assms il_associative il_commutative il_inf_right_dist_sup test_inf_commutative)
	+ also have "... = x \<squnion> ((x \<squnion> !x) \<sqinter> y)"
	+ by (smt calculation il_associative il_commutative il_idempotent il_inf_right_dist_sup)
	+ also have "... = x \<squnion> y"
	+ by (simp add: assms(1) neg_char)
	+ finally show ?thesis
	+ .
	+qed
	+
	+lemma test_import_2:
	+ assumes "test x"
	+ and "test y"
	+ shows "x \<squnion> (y \<sqinter> !x) = x \<squnion> y"
	+proof -
	+ obtain z where 1: "are_complementary y z"
	+ using assms(2) by moura
	+ obtain w where 2: "are_complementary x w"
	+ using assms(1) by auto
	+ hence "x \<sqinter> !x = bot"
	+ using neg_char by blast
	+ hence "!x \<sqinter> y = y \<sqinter> !x"
	+ using 1 2 by (metis il_commutative neg_char test_inf_commutative)
	+ thus ?thesis
	+ using 1 2 by (metis test_import_1)
	+qed
	+
	+lemma test_import_3:
	+ assumes "test x"
	+ shows "(!x \<squnion> y) \<sqinter> x = y \<sqinter> x"
	+ by (simp add: assms(1) il_inf_right_dist_sup il_unit_bot neg_char)
	+
	+lemma test_import_4:
	+ assumes "test x"
	+ and "test y"
	+ shows "(!x \<squnion> y) \<sqinter> x = x \<sqinter> y"
	+ by (metis assms test_import_3 test_inf_commutative)
	+
	+lemma test_inf:
	+ "test x \<Longrightarrow> test y \<Longrightarrow> test z \<Longrightarrow> z \<le> x \<sqinter> y \<longleftrightarrow> z \<le> x \<and> z \<le> y"
	+ apply (rule iffI)
	+ using dual_order.trans test_inf_left_below test_inf_right_below apply blast
	+ by (smt il_less_eq il_sub_inf_right_isotone test_absorb_4)
	+
	+lemma test_shunting:
	+ assumes "test x"
	+ and "test y"
	+ shows "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> !y \<squnion> z"
	+proof
	+ assume 1: "x \<sqinter> y \<le> z"
	+ have "x = (!y \<sqinter> x) \<squnion> (y \<sqinter> x)"
	+ by (metis assms(2) il_commutative il_inf_left_unit il_inf_right_dist_sup neg_char)
	+ also have "... \<le> !y \<squnion> (y \<sqinter> x)"
	+ by (simp add: assms(1) sup_left_isotone test_inf_right_below)
	+ also have "... \<le> !y \<squnion> z"
	+ using 1 by (simp add: assms sup_right_isotone test_inf_commutative)
	+ finally show "x \<le> !y \<squnion> z"
	+ .
	+next
	+ assume "x \<le> !y \<squnion> z"
	+ hence "x \<sqinter> y \<le> (!y \<squnion> z) \<sqinter> y"
	+ using il_sub_inf_left_isotone by blast
	+ also have "... = z \<sqinter> y"
	+ by (simp add: assms(2) test_import_3)
	+ also have "... \<le> z"
	+ by (simp add: assms(2) test_inf_right_below)
	+ finally show "x \<sqinter> y \<le> z"
	+ .
	+qed
	+
	+lemma test_shunting_bot:
	+ assumes "test x"
	+ and "test y"
	+ shows "x \<le> y \<longleftrightarrow> x \<sqinter> !y \<le> bot"
	+ by (simp add: assms il_bot_unit neg_involutive neg_test test_shunting)
	+
	+lemma test_shunting_bot_eq:
	+ assumes "test x"
	+ and "test y"
	+ shows "x \<le> y \<longleftrightarrow> x \<sqinter> !y = bot"
	+ by (simp add: assms test_shunting_bot less_eq_bot)
	+
	+lemma neg_antitone:
	+ assumes "test x"
	+ and "test y"
	+ and "x \<le> y"
	+ shows "!y \<le> !x"
	+proof -
	+ have 1: "x \<sqinter> !y = bot"
	+ using assms test_shunting_bot_eq by blast
	+ have 2: "x \<squnion> !x = top"
	+ by (simp add: assms(1) neg_char)
	+ have "are_complementary y (!y)"
	+ by (simp add: assms(2) neg_char)
	+ thus ?thesis
	+ using 1 2 by (metis il_unit_bot il_commutative il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone test_sub_identity)
	+qed
	+
	+lemma test_sup_neg_1:
	+ assumes "test x"
	+ and "test y"
	+ shows "(x \<squnion> y) \<squnion> (!x \<sqinter> !y) = top"
	+proof -
	+ have "x \<squnion> !x = top"
	+ by (simp add: assms(1) neg_char)
	+ hence "x \<squnion> (y \<squnion> !x) = top"
	+ by (metis assms(2) il_associative il_commutative il_idempotent)
	+ hence "x \<squnion> (y \<squnion> !x \<sqinter> !y) = top"
	+ by (simp add: assms neg_test test_import_2)
	+ thus ?thesis
	+ by (simp add: il_associative)
	+qed
	+
	+lemma test_sup_neg_2:
	+ assumes "test x"
	+ and "test y"
	+ shows "(x \<squnion> y) \<sqinter> (!x \<sqinter> !y) = bot"
	+proof -
	+ have 1: "are_complementary y (!y)"
	+ by (simp add: assms(2) neg_char)
	+ obtain z where 2: "are_complementary x z"
	+ using assms(1) by auto
	+ hence "!x = z"
	+ using neg_char neg_unique by blast
	+ thus ?thesis
	+ using 1 2 by (metis are_complementary_symmetric il_inf_associative neg_involutive test_import_3 test_inf_bot test_inf_commutative)
	+qed
	+
	+lemma de_morgan_1:
	+ assumes "test x"
	+ and "test y"
	+ and "test (x \<sqinter> y)"
	+ shows "!(x \<sqinter> y) = !x \<squnion> !y"
	+proof (rule antisym)
	+ have 1: "test (!(x \<sqinter> y))"
	+ by (simp add: assms neg_test)
	+ have "x \<le> (x \<sqinter> y) \<squnion> !y"
	+ by (metis (full_types) assms il_commutative neg_char test_shunting test_shunting_bot_eq)
	+ hence "x \<sqinter> !(x \<sqinter> y) \<le> !y"
	+ using 1 by (simp add: assms(1,3) neg_involutive test_shunting)
	+ hence "!(x \<sqinter> y) \<sqinter> x \<le> !y"
	+ using 1 by (metis assms(1) test_inf_commutative)
	+ thus "!(x \<sqinter> y) \<le> !x \<squnion> !y"
	+ using 1 assms(1) test_shunting by blast
	+ have 2: "!x \<le> !(x \<sqinter> y)"
	+ by (simp add: assms neg_antitone test_inf_right_below)
	+ have "!y \<le> !(x \<sqinter> y)"
	+ by (simp add: assms neg_antitone test_inf_left_below)
	+ thus "!x \<squnion> !y \<le> !(x \<sqinter> y)"
	+ using 2 by (metis il_associative il_less_eq)
	+qed
	+
	+lemma de_morgan_2:
	+ assumes "test x"
	+ and "test y"
	+ and "test (x \<squnion> y)"
	+ shows "!(x \<squnion> y) = !x \<sqinter> !y"
	+proof (rule antisym)
	+ have 1: "!(x \<squnion> y) \<le> !x"
	+ by (metis assms il_inf_left_unit il_sub_inf_left_isotone neg_antitone test_absorb_3 test_sub_identity)
	+ have "!(x \<squnion> y) \<le> !y"
	+ by (metis assms il_commutative il_inf_left_unit il_sub_inf_left_isotone neg_antitone test_absorb_3 test_sub_identity)
	+ thus "!(x \<squnion> y) \<le> !x \<sqinter> !y"
	+ using 1 by (simp add: assms neg_test test_inf)
	+ have "top \<le> x \<squnion> y \<squnion> !(x \<squnion> y)"
	+ by (simp add: assms(3) neg_char)
	+ hence "top \<sqinter> !x \<le> y \<squnion> !(x \<squnion> y)"
	+ by (smt assms(1) assms(3) il_commutative il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone il_unit_bot neg_char test_sub_identity)
	+ thus "!x \<sqinter> !y \<le> !(x \<squnion> y)"
	+ by (simp add: assms(1) assms(2) neg_involutive neg_test test_shunting)
	+qed
	+
	+lemma test_inf_closed_sup_complement:
	+ assumes "test x"
	+ and "test y"
	+ and "\<forall>u v . test u \<and> test v \<longrightarrow> test (u \<sqinter> v)"
	+ shows "!x \<sqinter> !y \<sqinter> (x \<squnion> y) = bot"
	+proof -
	+ have 1: "!(!x \<sqinter> !y) = x \<squnion> y"
	+ by (simp add: assms de_morgan_1 neg_involutive neg_test)
	+ have "test (!(!x \<sqinter> !y))"
	+ by (metis assms neg_test)
	+ thus ?thesis
	+ using 1 by (metis assms(1,2) de_morgan_2 neg_char)
	+qed
	+
	+lemma test_sup_complement_sup_closed:
	+ assumes "test x"
	+ and "test y"
	+ and "\<forall>u v . test u \<and> test v \<longrightarrow> !u \<sqinter> !v \<sqinter> (u \<squnion> v) = bot"
	+ shows "test (x \<squnion> y)"
	+ by (meson assms test_sup_neg_1 test_sup_neg_2)
	+
	+lemma test_inf_closed_sup_closed:
	+ assumes "test x"
	+ and "test y"
	+ and "\<forall>u v . test u \<and> test v \<longrightarrow> test (u \<sqinter> v)"
	+ shows "test (x \<squnion> y)"
	+ using assms test_inf_closed_sup_complement test_sup_complement_sup_closed by simp
	+
	+end
	+
	+subsection \<open>Prepredomain Semirings\<close>
	+
	+class dom =
	+ fixes d :: "'a \<Rightarrow> 'a"
	+
	+class ppd_semiring = il_semiring + dom +
	+ assumes d_closed: "test (d x)"
	+ assumes d1: "x \<le> d x \<sqinter> x"
	+begin
	+
	+lemma d_sub_identity:
	+ "d x \<le> top"
	+ using d_closed test_sub_identity by blast
	+
	+lemma d1_eq:
	+ "x = d x \<sqinter> x"
	+proof -
	+ have "x = (d x \<squnion> top) \<sqinter> x"
	+ using d_sub_identity il_less_eq by auto
	+ thus ?thesis
	+ using d1 il_commutative il_inf_right_dist_sup il_less_eq by force
	+qed
	+
	+lemma d_increasing_sub_identity:
	+ "x \<le> top \<Longrightarrow> x \<le> d x"
	+ by (metis d1_eq il_inf_right_unit il_sub_inf_right_isotone)
	+
	+lemma d_top:
	+ "d top = top"
	+ by (simp add: d_increasing_sub_identity d_sub_identity dual_order.antisym)
	+
	+lemma d_bot_only:
	+ "d x = bot \<Longrightarrow> x = bot"
	+ by (metis d1_eq il_sub_inf_left_zero)
	+
	+lemma d_strict: "d bot \<le> bot" nitpick [expect=genuine] oops
	+lemma d_isotone_var: "d x \<le> d (x \<squnion> y)" nitpick [expect=genuine] oops
	+lemma d_fully_strict: "d x = bot \<longleftrightarrow> x = bot" nitpick [expect=genuine] oops
	+lemma test_d_fixpoint: "test x \<Longrightarrow> d x = x" nitpick [expect=genuine] oops
	+
	+end
	+
	+subsection \<open>Predomain Semirings\<close>
	+
	+class pd_semiring = ppd_semiring +
	+ assumes d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
	+begin
	+
	+lemma d_strict:
	+ "d bot \<le> bot"
	+ using bot_test d2 by fastforce
	+
	+lemma d_strict_eq:
	+ "d bot = bot"
	+ using d_strict il_bot_unit il_less_eq by auto
	+
	+lemma test_d_fixpoint:
	+ "test x \<Longrightarrow> d x = x"
	+ by (metis antisym d1_eq d2 test_inf_idempotent test_inf_right_below)
	+
	+lemma d_surjective:
	+ "test x \<Longrightarrow> \<exists>y . d y = x"
	+ using test_d_fixpoint by blast
	+
	+lemma test_d_fixpoint_iff:
	+ "test x \<longleftrightarrow> d x = x"
	+ by (metis d_closed test_d_fixpoint)
	+
	+lemma d_surjective_iff:
	+ "test x \<longleftrightarrow> (\<exists>y . d y = x)"
	+ using d_surjective d_closed by blast
	+
	+lemma tests_d_range:
	+ "tests = range d"
	+ using tests_def image_def d_surjective_iff by auto
	+
	+lemma llp:
	+ assumes "test y"
	+ shows "d x \<le> y \<longleftrightarrow> x \<le> y \<sqinter> x"
	+ by (metis assms d1_eq d2 eq_iff il_sub_inf_left_isotone test_inf_left_below)
	+
	+lemma gla:
	+ assumes "test y"
	+ shows "y \<le> !(d x) \<longleftrightarrow> y \<sqinter> x \<le> bot"
	+proof -
	+ obtain ad where 1: "\<forall>x. are_complementary (d x) (ad x)"
	+ using d_closed by moura
	+ hence 2: "\<forall>x y. d (d y \<sqinter> x) \<le> d y"
	+ using d2 by blast
	+ have 3: "\<forall>x. ad x \<sqinter> x = bot"
	+ using 1 by (metis d1_eq il_inf_associative il_sub_inf_left_zero)
	+ have 4: "\<forall>x y. d y \<sqinter> x \<squnion> ad y \<sqinter> x = top \<sqinter> x"
	+ using 1 by (metis il_inf_right_dist_sup)
	+ have 5: "\<forall>x y z. z \<sqinter> y \<le> x \<sqinter> y \<or> (z \<squnion> x) \<sqinter> y \<noteq> x \<sqinter> y"
	+ by (simp add: il_inf_right_dist_sup il_less_eq)
	+ have 6: "\<forall>x. !(d x) = ad x"
	+ using 1 neg_char neg_unique by blast
	+ have 7: "\<forall>x. top \<sqinter> x = x"
	+ by auto
	+ hence "\<forall>x. y \<sqinter> x \<squnion> !y \<sqinter> x = x"
	+ by (metis assms il_inf_right_dist_sup neg_char)
	+ thus ?thesis
	+ using 1 2 3 4 5 6 7 by (metis assms d1_eq il_commutative il_less_eq test_d_fixpoint)
	+qed
	+
	+lemma gla_var:
	+ "test y \<Longrightarrow> y \<sqinter> d x \<le> bot \<longleftrightarrow> y \<sqinter> x \<le> bot"
	+ using gla d_closed il_bot_unit test_shunting by auto
	+
	+lemma llp_var:
	+ assumes "test y"
	+ shows "y \<le> !(d x) \<longleftrightarrow> x \<le> !y \<sqinter> x"
	+ apply (rule iffI)
	+ apply (metis (no_types, hide_lams) assms gla Least_equality il_inf_left_unit il_inf_right_dist_sup il_less_eq il_unit_bot order.refl neg_char)
	+ by (metis assms gla gla_var llp il_commutative il_sub_inf_right_isotone neg_char)
	+
	+lemma d_idempotent:
	+ "d (d x) = d x"
	+ using d_closed test_d_fixpoint_iff by auto
	+
	+lemma d_neg:
	+ "test x \<Longrightarrow> d (!x) = !x"
	+ using il_commutative neg_char test_d_fixpoint_iff by fastforce
	+
	+lemma d_fully_strict:
	+ "d x = bot \<longleftrightarrow> x = bot"
	+ using d_strict_eq d_bot_only by blast
	+
	+lemma d_ad_comp:
	+ "!(d x) \<sqinter> x = bot"
	+proof -
	+ have "\<forall>x. !(d x) \<sqinter> d x = bot"
	+ by (simp add: d_closed neg_char)
	+ thus ?thesis
	+ by (metis d1_eq il_inf_associative il_sub_inf_left_zero)
	+qed
	+
	+lemma d_isotone:
	+ assumes "x \<le> y"
	+ shows "d x \<le> d y"
	+proof -
	+ obtain ad where 1: "\<forall>x. are_complementary (d x) (ad x)"
	+ using d_closed by moura
	+ hence "ad y \<sqinter> x \<le> bot"
	+ by (metis assms d1_eq il_inf_associative il_sub_inf_left_zero il_sub_inf_right_isotone)
	+ thus ?thesis
	+ using 1 by (metis d2 il_bot_unit il_inf_left_unit il_inf_right_dist_sup il_less_eq)
	+qed
	+
	+lemma d_isotone_var:
	+ "d x \<le> d (x \<squnion> y)"
	+ using d_isotone il_associative il_less_eq by auto
	+
	+lemma d3_conv:
	+ "d (x \<sqinter> y) \<le> d (x \<sqinter> d y)"
	+ by (metis (mono_tags, hide_lams) d1_eq d2 d_closed il_inf_associative)
	+
	+lemma d_test_inf_idempotent:
	+ "d x \<sqinter> d x = d x"
	+ by (metis d_idempotent d1_eq)
	+
	+lemma d_test_inf_closed:
	+ assumes "test x"
	+ and "test y"
	+ shows "d (x \<sqinter> y) = x \<sqinter> y"
	+proof (rule antisym)
	+ have "d (x \<sqinter> y) = d (x \<sqinter> y) \<sqinter> d (x \<sqinter> y)"
	+ by (simp add: d_test_inf_idempotent)
	+ also have "... \<le> x \<sqinter> d (x \<sqinter> y)"
	+ by (simp add: assms(1) d2 il_sub_inf_left_isotone)
	+ also have "... \<le> x \<sqinter> y"
	+ by (metis assms d_isotone il_sub_inf_right_isotone test_inf_left_below test_d_fixpoint)
	+ finally show "d (x \<sqinter> y) \<le> x \<sqinter> y"
	+ .
	+ show "x \<sqinter> y \<le> d (x \<sqinter> y)"
	+ using assms d_increasing_sub_identity dual_order.trans test_inf_left_below test_sub_identity by blast
	+qed
	+
	+lemma test_inf_closed:
	+ "test x \<Longrightarrow> test y \<Longrightarrow> test (x \<sqinter> y)"
	+ using d_test_inf_closed test_d_fixpoint_iff by simp
	+
	+lemma test_sup_closed:
	+ "test x \<Longrightarrow> test y \<Longrightarrow> test (x \<squnion> y)"
	+ using test_inf_closed test_inf_closed_sup_closed by simp
	+
	+lemma d_export:
	+ assumes "test x"
	+ shows "d (x \<sqinter> y) = x \<sqinter> d y"
	+proof (rule antisym)
	+ have 1: "d (x \<sqinter> y) \<le> x"
	+ by (simp add: assms d2)
	+ have "d (x \<sqinter> y) \<le> d y"
	+ by (metis assms d_isotone_var il_inf_left_unit il_inf_right_dist_sup)
	+ thus "d (x \<sqinter> y) \<le> x \<sqinter> d y"
	+ using 1 by (metis assms d_idempotent llp dual_order.trans il_sub_inf_right_isotone)
	+ have "y = (!x \<sqinter> y) \<squnion> (x \<sqinter> y)"
	+ by (metis assms il_commutative il_inf_left_unit il_inf_right_dist_sup neg_char)
	+ also have "... = (!x \<sqinter> y) \<squnion> (d (x \<sqinter> y) \<sqinter> x \<sqinter> y)"
	+ by (metis d1_eq il_inf_associative)
	+ also have "... = (!x \<sqinter> y) \<squnion> (d (x \<sqinter> y) \<sqinter> y)"
	+ using 1 by (smt calculation d1_eq il_associative il_commutative il_inf_associative il_inf_right_dist_sup il_less_eq il_sub_inf_right_isotone_var)
	+ also have "... = (!x \<squnion> d (x \<sqinter> y)) \<sqinter> y"
	+ by (simp add: il_inf_right_dist_sup)
	+ finally have "y \<le> (!x \<squnion> d (x \<sqinter> y)) \<sqinter> y"
	+ by simp
	+ hence "d y \<le> !x \<squnion> d (x \<sqinter> y)"
	+ using assms llp test_sup_closed neg_test d_closed by simp
	+ hence "d y \<sqinter> x \<le> d (x \<sqinter> y)"
	+ by (simp add: assms d_closed test_shunting)
	+ thus "x \<sqinter> d y \<le> d (x \<sqinter> y)"
	+ by (metis assms d_closed test_inf_commutative)
	+qed
	+
	+lemma test_inf_left_dist_sup:
	+ assumes "test x"
	+ and "test y"
	+ and "test z"
	+ shows "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
	+proof -
	+ have "x \<sqinter> (y \<squnion> z) = (y \<squnion> z) \<sqinter> x"
	+ using assms test_sup_closed test_inf_commutative by smt
	+ also have "... = (y \<sqinter> x) \<squnion> (z \<sqinter> x)"
	+ using il_inf_right_dist_sup by simp
	+ also have "... = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
	+ using assms test_sup_closed test_inf_commutative by smt
	+ finally show ?thesis
	+ .
	+qed
	+
	+lemma "!x \<squnion> !y = !(!(!x \<squnion> !y))" nitpick [expect=genuine] oops
	+lemma "d x = !(!x)" nitpick [expect=genuine] oops
	+
	+sublocale subset_boolean_algebra where uminus = "\<lambda> x . !(d x)"
	+proof
	+ show "\<And>x y z. !(d x) \<squnion> (!(d y) \<squnion> !(d z)) = !(d x) \<squnion> !(d y) \<squnion> !(d z)"
	+ using il_associative by blast
	+ show "\<And>x y. !(d x) \<squnion> !(d y) = !(d y) \<squnion> !(d x)"
	+ by (simp add: il_commutative)
	+ show "\<And>x y. !(d x) \<squnion> !(d y) = !(d (!(d (!(d x) \<squnion> !(d y)))))"
	+ proof -
	+ fix x y
	+ have "test (!(d x)) \<and> test (!(d y))"
	+ by (simp add: d_closed neg_test)
	+ hence "test (!(d x) \<squnion> !(d y))"
	+ by (simp add: test_sup_closed)
	+ thus "!(d x) \<squnion> !(d y) = !(d (!(d (!(d x) \<squnion> !(d y)))))"
	+ by (simp add: d_neg neg_involutive test_d_fixpoint)
	+ qed
	+ show "\<And>x y. !(d x) = !(d (!(d (!(d x))) \<squnion> !(d y))) \<squnion> !(d (!(d (!(d x))) \<squnion> !(d (!(d y)))))"
	+ proof -
	+ fix x y
	+ have "!(d (!(d (!(d x))) \<squnion> !(d y))) \<squnion> !(d (!(d (!(d x))) \<squnion> !(d (!(d y))))) = !(d x \<squnion> !(d y)) \<squnion> !(d x \<squnion> d y)"
	+ using d_closed neg_test test_sup_closed neg_involutive test_d_fixpoint by auto
	+ also have "... = (!(d x) \<sqinter> d y) \<squnion> (!(d x) \<sqinter> !(d y))"
	+ using d_closed neg_test test_sup_closed neg_involutive de_morgan_2 by auto
	+ also have "... = !(d x) \<sqinter> (d y \<squnion> !(d y))"
	+ using d_closed neg_test test_inf_left_dist_sup by auto
	+ also have "... = !(d x) \<sqinter> top"
	+ by (simp add: neg_char d_closed)
	+ finally show "!(d x) = !(d (!(d (!(d x))) \<squnion> !(d y))) \<squnion> !(d (!(d (!(d x))) \<squnion> !(d (!(d y)))))"
	+ by simp
	+ qed
	+qed
	+
	+lemma d_dist_sup:
	+ "d (x \<squnion> y) = d x \<squnion> d y"
	+proof (rule antisym)
	+ have "x \<le> d x \<sqinter> x"
	+ by (simp add: d1)
	+ also have "... \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
	+ using il_associative il_inf_right_dist_sup il_less_eq il_sub_inf_right_isotone by auto
	+ finally have 1: "x \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
	+ .
	+ have "y \<le> d y \<sqinter> y"
	+ by (simp add: d1)
	+ also have "... \<le> (d y \<squnion> d x) \<sqinter> (y \<squnion> x)"
	+ using il_associative il_idempotent il_inf_right_dist_sup il_less_eq il_sub_inf_right_isotone by simp
	+ finally have "y \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
	+ using il_commutative by auto
	+ hence "x \<squnion> y \<le> (d x \<squnion> d y) \<sqinter> (x \<squnion> y)"
	+ using 1 by (metis il_associative il_less_eq)
	+ thus "d (x \<squnion> y) \<le> d x \<squnion> d y"
	+ using llp test_sup_closed neg_test d_closed by simp
	+ show "d x \<squnion> d y \<le> d (x \<squnion> y)"
	+ using d_isotone_var il_associative il_commutative il_less_eq by fastforce
	+qed
	+
	+end
	+
	+class pd_semiring_extended = pd_semiring + uminus +
	+ assumes uminus_def: "-x = !(d x)"
	+begin
	+
	+subclass subset_boolean_algebra
	+ by (metis subset_boolean_algebra_axioms uminus_def ext)
	+
	+end
	+
	+subsection \<open>Domain Semirings\<close>
	+
	+class d_semiring = pd_semiring +
	+ assumes d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
	+begin
	+
	+lemma d3_eq: "d (x \<sqinter> d y) = d (x \<sqinter> y)"
	+ by (simp add: antisym d3 d3_conv)
	+
	+end
	+
	+text \<open>
	+Axioms (d1), (d2) and (d3) are independent in IL-semirings.
	+\<close>
	+
	+context il_semiring
	+begin
	+
	+context
	+ fixes d :: "'a \<Rightarrow> 'a"
	+ assumes d_closed: "test (d x)"
	+begin
	+
	+context
	+ assumes d1: "x \<le> d x \<sqinter> x"
	+ assumes d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
	+begin
	+
	+lemma d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)" nitpick [expect=genuine] oops
	+
	+end
	+
	+context
	+ assumes d1: "x \<le> d x \<sqinter> x"
	+ assumes d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
	+begin
	+
	+lemma d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p" nitpick [expect=genuine] oops
	+
	+end
	+
	+context
	+ assumes d2: "test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
	+ assumes d3: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
	+begin
	+
	+lemma d1: "x \<le> d x \<sqinter> x" nitpick [expect=genuine] oops
	+
	+end
	+
	+end
	+
	+end
	+
	+class d_semiring_var = ppd_semiring +
	+ assumes d3_var: "d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
	+ assumes d_strict_eq_var: "d bot = bot"
	+begin
	+
	+lemma d2_var:
	+ assumes "test p"
	+ shows "d (p \<sqinter> x) \<le> p"
	+proof -
	+ have "!p \<sqinter> p \<sqinter> x = bot"
	+ by (simp add: assms neg_char)
	+ hence "d (!p \<sqinter> p \<sqinter> x) = bot"
	+ by (simp add: d_strict_eq_var)
	+ hence "d (!p \<sqinter> d (p \<sqinter> x)) = bot"
	+ by (metis d3_var il_inf_associative less_eq_bot)
	+ hence "!p \<sqinter> d (p \<sqinter> x) = bot"
	+ using d_bot_only by blast
	+ thus ?thesis
	+ by (metis (no_types, hide_lams) assms d_sub_identity il_bot_unit il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone neg_char)
	+qed
	+
	+subclass d_semiring
	+proof
	+ show "\<And>p x. test p \<Longrightarrow> d (p \<sqinter> x) \<le> p"
	+ by (simp add: d2_var)
	+ show "\<And>x y. d (x \<sqinter> d y) \<le> d (x \<sqinter> y)"
	+ by (simp add: d3_var)
	+qed
	+
	+end
	+
	+section \<open>Antidomain Semirings\<close>
	+
	+text \<open>
	+We now develop prepreantidomain semirings, preantidomain semirings and antidomain semirings.
	+See \cite{DesharnaisStruth2008b,DesharnaisStruth2008a,DesharnaisStruth2011} for related work on internal axioms for antidomain.
	+\<close>
	+
	+subsection \<open>Prepreantidomain Semirings\<close>
	+
	+text \<open>Definition 20\<close>
	+
	+class ppa_semiring = il_semiring + uminus +
	+ assumes a_inf_complement_bot: "-x \<sqinter> x = bot"
	+ assumes a_stone[simp]: "-x \<squnion> --x = top"
	+begin
	+
	+text \<open>Theorem 21\<close>
	+
	+lemma l1:
	+ "-top = bot"
	+ by (metis a_inf_complement_bot il_inf_right_unit)
	+
	+lemma l2:
	+ "-bot = top"
	+ by (metis l1 a_stone il_unit_bot)
	+
	+lemma l3:
	+ "-x \<le> -y \<Longrightarrow> -x \<sqinter> y = bot"
	+ by (metis a_inf_complement_bot il_bot_unit il_inf_right_dist_sup il_less_eq)
	+
	+lemma l5:
	+ "--x \<le> --y \<Longrightarrow> -y \<le> -x"
	+ by (metis (mono_tags, hide_lams) l3 a_stone bot_least il_bot_unit il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone sup_right_isotone)
	+
	+lemma l4:
	+ "---x = -x"
	+ by (metis l5 a_inf_complement_bot a_stone antisym bot_least il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_sub_inf_right_isotone il_unit_bot)
	+
	+lemma l6:
	+ "-x \<sqinter> --x = bot"
	+ by (metis l3 l5 a_inf_complement_bot a_stone il_inf_left_unit il_inf_right_dist_sup il_inf_right_unit il_less_eq il_sub_inf_right_isotone il_unit_bot)
	+
	+lemma l7:
	+ "-x \<sqinter> -y = -y \<sqinter> -x"
	+ using l6 a_inf_complement_bot a_stone test_inf_commutative by blast
	+
	+lemma l8:
	+ "x \<le> --x \<sqinter> x"
	+ by (metis a_inf_complement_bot a_stone il_idempotent il_inf_left_unit il_inf_right_dist_sup il_less_eq il_unit_bot)
	+
	+sublocale ppa_ppd: ppd_semiring where d = "\<lambda>x . --x"
	+proof
	+ show "\<And>x. test (- - x)"
	+ using l4 l6 by force
	+ show "\<And>x. x \<le> - - x \<sqinter> x"
	+ by (simp add: l8)
	+qed
	+
	+(*
	+The following statements have counterexamples, but they take a while to find.
	+
	+lemma "- x = - (- - x \<squnion> - y) \<squnion> - (- - x \<squnion> - - y)" nitpick [card=8, expect=genuine] oops
	+lemma "- x \<squnion> - y = - - (- x \<squnion> - y)" nitpick [card=8, expect=genuine] oops
	+*)
	+
	+end
	+
	+subsection \<open>Preantidomain Semirings\<close>
	+
	+text \<open>Definition 22\<close>
	+
	+class pa_semiring = ppa_semiring +
	+ assumes pad2: "--x \<le> -(-x \<sqinter> y)"
	+begin
	+
	+text \<open>Theorem 23\<close>
	+
	+lemma l10:
	+ "-x \<sqinter> y = bot \<Longrightarrow> -x \<le> -y"
	+ by (metis a_stone il_inf_left_unit il_inf_right_dist_sup il_unit_bot l4 pad2)
	+
	+lemma l10_iff:
	+ "-x \<sqinter> y = bot \<longleftrightarrow> -x \<le> -y"
	+ using l10 l3 by blast
	+
	+lemma l13:
	+ "--(--x \<sqinter> y) \<le> --x"
	+ by (metis l4 l5 pad2)
	+
	+lemma l14:
	+ "-(x \<sqinter> --y) \<le> -(x \<sqinter> y)"
	+ by (metis il_inf_associative l4 pad2 ppa_ppd.d1_eq)
	+
	+lemma l9:
	+ "x \<le> y \<Longrightarrow> -y \<le> -x"
	+ by (metis l10 a_inf_complement_bot il_commutative il_less_eq il_sub_inf_right_isotone il_unit_bot)
	+
	+lemma l11:
	+ "- x \<squnion> - y = - (- - x \<sqinter> - - y)"
	+proof -
	+ have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
	+ by (simp add: il_less_eq)
	+ have 4: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
	+ using 1 by metis
	+ have 5: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
	+ by (simp add: il_sub_inf_right_isotone_var)
	+ have 6: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
	+ by (simp add: pad2)
	+ have 7: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ by (simp add: il_associative)
	+ have 8: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
	+ using 7 by metis
	+ have 9: "\<And>x y . x \<squnion> y = y \<squnion> x"
	+ by (simp add: il_commutative)
	+ have 10: "\<And>x . x \<squnion> bot = x"
	+ by (simp add: il_bot_unit)
	+ have 11: "\<And>x . x \<squnion> x = x"
	+ by simp
	+ have 12: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
	+ by (simp add: il_inf_associative)
	+ have 13: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
	+ using 12 by metis
	+ have 14: "\<And>x . top \<sqinter> x = x"
	+ by simp
	+ have 15: "\<And>x . x \<sqinter> top = x"
	+ by simp
	+ have 16: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
	+ by (simp add: il_inf_right_dist_sup)
	+ have 17: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
	+ using 16 by metis
	+ have 18: "\<And>x . bot \<sqinter> x = bot"
	+ by simp
	+ have 19: "\<And>x . - x \<squnion> - - x = top"
	+ by simp
	+ have 20: "\<And>x . - x \<sqinter> x = bot"
	+ by (simp add: a_inf_complement_bot)
	+ have 23: "\<And>x y z . ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
	+ using 4 5 by metis
	+ have 24: "\<And>x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) = x \<sqinter> (y \<squnion> z)"
	+ using 9 23 by metis
	+ have 25: "\<And>x y . - - x \<squnion> - (- x \<sqinter> y) = - (- x \<sqinter> y)"
	+ using 4 6 by metis
	+ have 26: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
	+ using 8 9 by metis
	+ have 27: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
	+ using 9 24 26 by metis
	+ have 30: "\<And>x . bot \<squnion> x = x"
	+ using 9 10 by metis
	+ have 31: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
	+ using 8 11 by metis
	+ have 34: "\<And>u x y z . ((x \<squnion> y) \<sqinter> z) \<squnion> u = (x \<sqinter> z) \<squnion> ((y \<sqinter> z) \<squnion> u)"
	+ using 8 17 by metis
	+ have 35: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> (u \<sqinter> z) = ((x \<sqinter> y) \<squnion> u) \<sqinter> z"
	+ using 13 17 by metis
	+ have 36: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> (u \<sqinter> y)) = (x \<squnion> (z \<sqinter> u)) \<sqinter> y"
	+ using 13 17 by metis
	+ have 39: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
	+ using 8 19 by metis
	+ have 41: "\<And>x y . - x \<sqinter> (x \<sqinter> y) = bot"
	+ using 13 18 20 by metis
	+ have 42: "- top = bot"
	+ using 15 20 by metis
	+ have 43: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
	+ using 17 20 30 by metis
	+ have 44: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
	+ using 9 17 20 30 by metis
	+ have 46: "\<And>x . - bot \<squnion> - - x = - bot"
	+ using 9 20 25 by metis
	+ have 50: "- bot = top"
	+ using 19 30 42 by metis
	+ have 51: "\<And>x . top \<squnion> - - x = top"
	+ using 46 50 by metis
	+ have 63: "\<And>x y . x \<squnion> ((x \<sqinter> - y) \<squnion> (x \<sqinter> - - y)) = x"
	+ using 9 15 19 26 27 by metis
	+ have 66: "\<And>x y . (- (x \<squnion> y) \<sqinter> x) \<squnion> (- (x \<squnion> y) \<sqinter> y) = bot"
	+ using 9 20 27 30 by metis
	+ have 67: "\<And>x y z . (x \<sqinter> - - y) \<squnion> (x \<sqinter> - (- y \<sqinter> z)) = x \<sqinter> - (- y \<sqinter> z)"
	+ using 11 25 27 by metis
	+ have 70: "\<And>x y . x \<squnion> (x \<sqinter> - - y) = x"
	+ using 9 15 27 31 51 by metis
	+ have 82: "\<And>x . top \<squnion> - x = top"
	+ using 9 19 31 by metis
	+ have 89: "\<And>x y . x \<squnion> (- y \<sqinter> x) = x"
	+ using 14 17 82 by metis
	+ have 102: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - - z)) = y \<squnion> x"
	+ using 26 70 by metis
	+ have 104: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
	+ using 9 63 102 by metis
	+ have 112: "\<And>x y z . (- x \<sqinter> y) \<squnion> ((- - x \<sqinter> y) \<squnion> z) = y \<squnion> z"
	+ using 14 19 34 by metis
	+ have 117: "\<And>x y z . x \<squnion> ((x \<sqinter> - y) \<squnion> z) = x \<squnion> z"
	+ using 8 104 by metis
	+ have 120: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - z)) = y \<squnion> x"
	+ using 26 104 by metis
	+ have 124: "\<And>x . - - x \<sqinter> x = x"
	+ using 14 19 43 by metis
	+ have 128: "\<And>x y . - - x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
	+ using 13 124 by metis
	+ have 131: "\<And>x . - x \<squnion> - - - x = - x"
	+ using 9 25 124 by metis
	+ have 133: "\<And>x . - - - x = - x"
	+ using 9 104 124 131 by metis
	+ have 135: "\<And>x y . - x \<squnion> - (- - x \<sqinter> y) = - (- - x \<sqinter> y)"
	+ using 25 133 by metis
	+ have 137: "\<And>x y . (- x \<squnion> y) \<sqinter> - - x = y \<sqinter> - - x"
	+ using 43 133 by metis
	+ have 145: "\<And>x y z . ((- (x \<sqinter> y) \<sqinter> x) \<squnion> z) \<sqinter> y = z \<sqinter> y"
	+ using 20 30 35 by metis
	+ have 183: "\<And>x y z . (x \<squnion> (- - (y \<sqinter> z) \<sqinter> y)) \<sqinter> z = (x \<squnion> y) \<sqinter> z"
	+ using 17 36 124 by metis
	+ have 289: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
	+ using 25 39 82 by metis
	+ have 316: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
	+ using 14 43 289 by metis
	+ have 317: "\<And>x y z . - (- x \<sqinter> y) \<sqinter> (x \<sqinter> z) = x \<sqinter> z"
	+ using 13 316 by metis
	+ have 320: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
	+ using 9 25 316 by metis
	+ have 321: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> x = bot"
	+ using 41 316 by metis
	+ have 374: "\<And>x y . - x \<squnion> - (x \<sqinter> y) = - (x \<sqinter> y)"
	+ using 25 128 133 by metis
	+ have 388: "\<And>x y . - (x \<sqinter> y) \<sqinter> - x = - x"
	+ using 128 316 by metis
	+ have 389: "\<And>x y . - - (x \<sqinter> y) \<sqinter> - x = bot"
	+ using 128 321 by metis
	+ have 405: "\<And>x y z . - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = - x \<sqinter> z"
	+ using 13 388 by metis
	+ have 406: "\<And>x y z . - (x \<sqinter> (y \<sqinter> z)) \<sqinter> - (x \<sqinter> y) = - (x \<sqinter> y)"
	+ using 13 388 by metis
	+ have 420: "\<And>x y . - x \<sqinter> - - (- x \<sqinter> y) = - - (- x \<sqinter> y)"
	+ using 316 388 by metis
	+ have 422: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = bot"
	+ using 13 18 389 by metis
	+ have 758: "\<And>x y z . x \<squnion> (x \<sqinter> (- y \<sqinter> - z)) = x"
	+ using 13 104 117 by metis
	+ have 1092: "\<And>x y . - (x \<squnion> y) \<sqinter> x = bot"
	+ using 9 30 31 66 by metis
	+ have 1130: "\<And>x y z . (- (x \<squnion> y) \<squnion> z) \<sqinter> x = z \<sqinter> x"
	+ using 17 30 1092 by metis
	+ have 1156: "\<And>x y . - - x \<sqinter> - (- x \<sqinter> y) = - - x"
	+ using 67 104 124 133 by metis
	+ have 2098: "\<And>x y . - - (x \<squnion> y) \<sqinter> x = x"
	+ using 14 19 1130 by metis
	+ have 2125: "\<And>x y . - - (x \<squnion> y) \<sqinter> y = y"
	+ using 9 2098 by metis
	+ have 2138: "\<And>x y . - x \<squnion> - - (x \<squnion> y) = top"
	+ using 9 289 2098 by metis
	+ have 2139: "\<And>x y . - x \<sqinter> - (x \<squnion> y) = - (x \<squnion> y)"
	+ using 316 2098 by metis
	+ have 2192: "\<And>x y . - - x \<sqinter> (- y \<sqinter> x) = - y \<sqinter> x"
	+ using 89 2125 by metis
	+ have 2202: "\<And>x y . - x \<squnion> - - (y \<squnion> x) = top"
	+ using 9 289 2125 by metis
	+ have 2344: "\<And>x y . - (- x \<sqinter> y) \<squnion> - - y = top"
	+ using 89 2202 by metis
	+ have 2547: "\<And>x y z . - x \<squnion> ((- - x \<sqinter> - y) \<squnion> z) = - x \<squnion> (- y \<squnion> z)"
	+ using 112 117 by metis
	+ have 3023: "\<And>x y . - x \<squnion> - (- y \<sqinter> - x) = top"
	+ using 9 133 2344 by metis
	+ have 3134: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> y = y"
	+ using 14 43 3023 by metis
	+ have 3135: "\<And>x y . - x \<sqinter> (- y \<sqinter> - x) = - y \<sqinter> - x"
	+ using 14 44 3023 by metis
	+ have 3962: "\<And>x y . - - (x \<squnion> y) \<sqinter> - - x = - - x"
	+ using 14 137 2138 by metis
	+ have 5496: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> - (x \<squnion> z) = bot"
	+ using 422 2139 by metis
	+ have 9414: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> y = - x \<sqinter> y"
	+ using 9 104 183 320 by metis
	+ have 9520: "\<And>x y z . - - (- x \<sqinter> y) \<sqinter> - - (x \<sqinter> z) = bot"
	+ using 374 5496 by metis
	+ have 11070: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> (- x \<sqinter> - z) = - (- - x \<sqinter> y)"
	+ using 317 758 by metis
	+ have 12371: "\<And>x y . - x \<sqinter> - (- - x \<sqinter> y) = - x"
	+ using 133 1156 by metis
	+ have 12377: "\<And>x y . - x \<sqinter> - (x \<sqinter> y) = - x"
	+ using 128 133 1156 by metis
	+ have 12384: "\<And>x y . - (x \<squnion> y) \<sqinter> - y = - (x \<squnion> y)"
	+ using 133 1156 2125 by metis
	+ have 12394: "\<And>x y . - - (- x \<sqinter> - y) = - x \<sqinter> - y"
	+ using 1156 3134 9414 by metis
	+ have 12640: "\<And>x y . - x \<sqinter> - (- y \<sqinter> x) = - x"
	+ using 89 12384 by metis
	+ have 24648: "\<And>x y . (- x \<sqinter> - y) \<squnion> - (- x \<sqinter> - y) = top"
	+ using 19 12394 by metis
	+ have 28270: "\<And>x y z . - - (x \<sqinter> y) \<squnion> - (- x \<sqinter> z) = - (- x \<sqinter> z)"
	+ using 374 405 by metis
	+ have 28339: "\<And>x y . - (- - (x \<sqinter> y) \<sqinter> x) = - (x \<sqinter> y)"
	+ using 124 406 12371 by metis
	+ have 28423: "\<And>x y . - (- x \<sqinter> - y) = - (- y \<sqinter> - x)"
	+ using 13 3135 12394 28339 by metis
	+ have 28487: "\<And>x y . - x \<sqinter> - y = - y \<sqinter> - x"
	+ using 2098 3962 12394 28423 by metis
	+ have 52423: "\<And>x y . - (- x \<sqinter> - (- x \<sqinter> y)) \<sqinter> y = y"
	+ using 14 145 24648 28487 by metis
	+ have 52522: "\<And>x y . - x \<sqinter> - (- x \<sqinter> y) = - x \<sqinter> - y"
	+ using 13 12377 12394 12640 28487 52423 by metis
	+ have 61103: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> z = - x \<squnion> (- y \<squnion> z)"
	+ using 112 2547 12371 52522 by metis
	+ have 61158: "\<And>x y . - - (- x \<sqinter> y) = - x \<sqinter> - - y"
	+ using 420 52522 by metis
	+ have 61231: "\<And>x y z . - x \<sqinter> (- - y \<sqinter> - (x \<sqinter> z)) = - x \<sqinter> - - y"
	+ using 13 15 50 133 9520 52522 61158 by metis
	+ have 61313: "\<And>x y . - x \<squnion> - y = - (- - y \<sqinter> x)"
	+ using 120 11070 61103 by metis
	+ have 61393: "\<And>x y . - (- x \<sqinter> - - y) = - (- x \<sqinter> y)"
	+ using 13 28270 61158 61231 61313 by metis
	+ have 61422: "\<And>x y . - (- - x \<sqinter> y) = - (- - y \<sqinter> x)"
	+ using 13 135 2192 61158 61313 by metis
	+ show ?thesis
	+ using 61313 61393 61422 by metis
	+qed
	+
	+lemma l12:
	+ "- x \<sqinter> - y = - (x \<squnion> y)"
	+proof -
	+ have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
	+ by (simp add: il_less_eq)
	+ have 4: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
	+ using 1 by metis
	+ have 5: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
	+ by (simp add: il_sub_inf_right_isotone_var)
	+ have 6: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
	+ by (simp add: pad2)
	+ have 7: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ by (simp add: il_associative)
	+ have 8: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
	+ using 7 by metis
	+ have 9: "\<And>x y . x \<squnion> y = y \<squnion> x"
	+ by (simp add: il_commutative)
	+ have 10: "\<And>x . x \<squnion> bot = x"
	+ by (simp add: il_bot_unit)
	+ have 11: "\<And>x . x \<squnion> x = x"
	+ by simp
	+ have 12: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
	+ by (simp add: il_inf_associative)
	+ have 13: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
	+ using 12 by metis
	+ have 14: "\<And>x . top \<sqinter> x = x"
	+ by simp
	+ have 15: "\<And>x . x \<sqinter> top = x"
	+ by simp
	+ have 16: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
	+ by (simp add: il_inf_right_dist_sup)
	+ have 17: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
	+ using 16 by metis
	+ have 18: "\<And>x . bot \<sqinter> x = bot"
	+ by simp
	+ have 19: "\<And>x . - x \<squnion> - - x = top"
	+ by simp
	+ have 20: "\<And>x . - x \<sqinter> x = bot"
	+ by (simp add: a_inf_complement_bot)
	+ have 22: "\<And>x y z . ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
	+ using 4 5 by metis
	+ have 23: "\<And>x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) = x \<sqinter> (y \<squnion> z)"
	+ using 9 22 by metis
	+ have 24: "\<And>x y . - - x \<squnion> - (- x \<sqinter> y) = - (- x \<sqinter> y)"
	+ using 4 6 by metis
	+ have 25: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
	+ using 8 9 by metis
	+ have 26: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
	+ using 9 23 25 by metis
	+ have 29: "\<And>x . bot \<squnion> x = x"
	+ using 9 10 by metis
	+ have 30: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
	+ using 8 11 by metis
	+ have 32: "\<And>x y . x \<squnion> (y \<squnion> x) = y \<squnion> x"
	+ using 8 9 11 by metis
	+ have 33: "\<And>u x y z . ((x \<squnion> y) \<sqinter> z) \<squnion> u = (x \<sqinter> z) \<squnion> ((y \<sqinter> z) \<squnion> u)"
	+ using 8 17 by metis
	+ have 34: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> (u \<sqinter> z) = ((x \<sqinter> y) \<squnion> u) \<sqinter> z"
	+ using 13 17 by metis
	+ have 35: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> (u \<sqinter> y)) = (x \<squnion> (z \<sqinter> u)) \<sqinter> y"
	+ using 13 17 by metis
	+ have 36: "\<And>x y . (top \<squnion> x) \<sqinter> y = y \<squnion> (x \<sqinter> y)"
	+ using 14 17 by metis
	+ have 37: "\<And>x y . (x \<squnion> top) \<sqinter> y = y \<squnion> (x \<sqinter> y)"
	+ using 9 14 17 by metis
	+ have 38: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
	+ using 8 19 by metis
	+ have 40: "\<And>x y . - x \<sqinter> (x \<sqinter> y) = bot"
	+ using 13 18 20 by metis
	+ have 41: "- top = bot"
	+ using 15 20 by metis
	+ have 42: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
	+ using 17 20 29 by metis
	+ have 43: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
	+ using 9 17 20 29 by metis
	+ have 45: "\<And>x . - bot \<squnion> - - x = - bot"
	+ using 9 20 24 by metis
	+ have 46: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<squnion> (u \<sqinter> y)) = z \<squnion> ((x \<squnion> u) \<sqinter> y)"
	+ using 17 25 by metis
	+ have 47: "\<And>x y . - x \<squnion> (y \<squnion> - - x) = y \<squnion> top"
	+ using 19 25 by metis
	+ have 49: "- bot = top"
	+ using 19 29 41 by metis
	+ have 50: "\<And>x . top \<squnion> - - x = top"
	+ using 45 49 by metis
	+ have 54: "\<And>u x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> ((x \<sqinter> (y \<squnion> z)) \<squnion> u)) = (x \<sqinter> (y \<squnion> z)) \<squnion> u"
	+ using 8 26 by metis
	+ have 58: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> ((x \<sqinter> (y \<sqinter> u)) \<squnion> (x \<sqinter> (y \<sqinter> (z \<squnion> u)))) = x \<sqinter> (y \<sqinter> (z \<squnion> u))"
	+ using 13 26 by metis
	+ have 60: "\<And>x y . x \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> (y \<squnion> top))) = x \<sqinter> (y \<squnion> top)"
	+ using 15 25 26 by metis
	+ have 62: "\<And>x y . x \<squnion> ((x \<sqinter> - y) \<squnion> (x \<sqinter> - - y)) = x"
	+ using 9 15 19 25 26 by metis
	+ have 65: "\<And>x y . (- (x \<squnion> y) \<sqinter> x) \<squnion> (- (x \<squnion> y) \<sqinter> y) = bot"
	+ using 9 20 26 29 by metis
	+ have 66: "\<And>x y z . (x \<sqinter> - - y) \<squnion> (x \<sqinter> - (- y \<sqinter> z)) = x \<sqinter> - (- y \<sqinter> z)"
	+ using 11 24 26 by metis
	+ have 69: "\<And>x y . x \<squnion> (x \<sqinter> - - y) = x"
	+ using 9 15 26 30 50 by metis
	+ have 81: "\<And>x . top \<squnion> - x = top"
	+ using 9 19 30 by metis
	+ have 82: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
	+ using 11 26 30 by metis
	+ have 83: "\<And>x y . x \<squnion> (x \<sqinter> (y \<squnion> top)) = x \<sqinter> (y \<squnion> top)"
	+ using 60 82 by metis
	+ have 88: "\<And>x y . x \<squnion> (- y \<sqinter> x) = x"
	+ using 14 17 81 by metis
	+ have 89: "\<And>x y . top \<squnion> (x \<squnion> - y) = x \<squnion> top"
	+ using 25 81 by metis
	+ have 91: "\<And>x y z . x \<squnion> (y \<squnion> (z \<squnion> x)) = y \<squnion> (z \<squnion> x)"
	+ using 8 32 by metis
	+ have 94: "\<And>x y z . x \<squnion> (y \<squnion> (- z \<sqinter> x)) = y \<squnion> x"
	+ using 25 88 by metis
	+ have 101: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - - z)) = y \<squnion> x"
	+ using 25 69 by metis
	+ have 102: "\<And>x . x \<squnion> (x \<sqinter> bot) = x"
	+ using 41 49 69 by metis
	+ have 103: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
	+ using 9 62 101 by metis
	+ have 109: "\<And>x y . x \<squnion> (y \<squnion> (x \<sqinter> bot)) = y \<squnion> x"
	+ using 25 102 by metis
	+ have 111: "\<And>x y z . (- x \<sqinter> y) \<squnion> ((- - x \<sqinter> y) \<squnion> z) = y \<squnion> z"
	+ using 14 19 33 by metis
	+ have 116: "\<And>x y z . x \<squnion> ((x \<sqinter> - y) \<squnion> z) = x \<squnion> z"
	+ using 8 103 by metis
	+ have 119: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - z)) = y \<squnion> x"
	+ using 25 103 by metis
	+ have 123: "\<And>x . - - x \<sqinter> x = x"
	+ using 14 19 42 by metis
	+ have 127: "\<And>x y . - - x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
	+ using 13 123 by metis
	+ have 130: "\<And>x . - x \<squnion> - - - x = - x"
	+ using 9 24 123 by metis
	+ have 132: "\<And>x . - - - x = - x"
	+ using 9 103 123 130 by metis
	+ have 134: "\<And>x y . - x \<squnion> - (- - x \<sqinter> y) = - (- - x \<sqinter> y)"
	+ using 24 132 by metis
	+ have 136: "\<And>x y . (- x \<squnion> y) \<sqinter> - - x = y \<sqinter> - - x"
	+ using 42 132 by metis
	+ have 138: "\<And>x . - x \<sqinter> - x = - x"
	+ using 123 132 by metis
	+ have 144: "\<And>x y z . ((- (x \<sqinter> y) \<sqinter> x) \<squnion> z) \<sqinter> y = z \<sqinter> y"
	+ using 20 29 34 by metis
	+ have 157: "\<And>x y . (- x \<squnion> y) \<sqinter> - x = (top \<squnion> y) \<sqinter> - x"
	+ using 17 36 138 by metis
	+ have 182: "\<And>x y z . (x \<squnion> (- - (y \<sqinter> z) \<sqinter> y)) \<sqinter> z = (x \<squnion> y) \<sqinter> z"
	+ using 17 35 123 by metis
	+ have 288: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
	+ using 24 38 81 by metis
	+ have 315: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
	+ using 14 42 288 by metis
	+ have 316: "\<And>x y z . - (- x \<sqinter> y) \<sqinter> (x \<sqinter> z) = x \<sqinter> z"
	+ using 13 315 by metis
	+ have 319: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
	+ using 9 24 315 by metis
	+ have 320: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> x = bot"
	+ using 40 315 by metis
	+ have 373: "\<And>x y . - x \<squnion> - (x \<sqinter> y) = - (x \<sqinter> y)"
	+ using 24 127 132 by metis
	+ have 387: "\<And>x y . - (x \<sqinter> y) \<sqinter> - x = - x"
	+ using 127 315 by metis
	+ have 388: "\<And>x y . - - (x \<sqinter> y) \<sqinter> - x = bot"
	+ using 127 320 by metis
	+ have 404: "\<And>x y z . - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = - x \<sqinter> z"
	+ using 13 387 by metis
	+ have 405: "\<And>x y z . - (x \<sqinter> (y \<sqinter> z)) \<sqinter> - (x \<sqinter> y) = - (x \<sqinter> y)"
	+ using 13 387 by metis
	+ have 419: "\<And>x y . - x \<sqinter> - - (- x \<sqinter> y) = - - (- x \<sqinter> y)"
	+ using 315 387 by metis
	+ have 420: "\<And>x y . - - x \<sqinter> - - (x \<sqinter> y) = - - (x \<sqinter> y)"
	+ using 387 by metis
	+ have 421: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> (- x \<sqinter> z) = bot"
	+ using 13 18 388 by metis
	+ have 536: "\<And>x y . (x \<squnion> - - y) \<sqinter> y = (x \<squnion> top) \<sqinter> y"
	+ using 42 47 by metis
	+ have 662: "\<And>u x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> (z \<squnion> y)) \<squnion> u) = (x \<sqinter> (z \<squnion> y)) \<squnion> u"
	+ using 9 32 54 by metis
	+ have 705: "\<And>u x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> (y \<squnion> (z \<sqinter> bot))) \<squnion> u) = (x \<sqinter> (y \<squnion> z)) \<squnion> u"
	+ using 25 54 109 662 by metis
	+ have 755: "\<And>x y z . (x \<sqinter> - y) \<squnion> (z \<squnion> x) = z \<squnion> x"
	+ using 32 91 116 by metis
	+ have 757: "\<And>x y z . x \<squnion> (x \<sqinter> (- y \<sqinter> - z)) = x"
	+ using 13 103 116 by metis
	+ have 930: "\<And>x y z . (- (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> y)) \<squnion> (- (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> z)) = bot"
	+ using 9 20 29 58 by metis
	+ have 1091: "\<And>x y . - (x \<squnion> y) \<sqinter> x = bot"
	+ using 9 29 30 65 by metis
	+ have 1092: "\<And>x y . - (x \<squnion> y) \<sqinter> y = bot"
	+ using 29 30 65 1091 by metis
	+ have 1113: "\<And>u x y z . - (x \<squnion> ((y \<squnion> z) \<sqinter> u)) \<sqinter> (x \<squnion> (z \<sqinter> u)) = bot"
	+ using 29 46 65 1091 by metis
	+ have 1117: "\<And>x y z . - (x \<squnion> y) \<sqinter> (x \<squnion> (- z \<sqinter> y)) = bot"
	+ using 29 65 94 1092 by metis
	+ have 1128: "\<And>x y z . - (x \<squnion> (y \<squnion> z)) \<sqinter> (x \<squnion> y) = bot"
	+ using 8 1091 by metis
	+ have 1129: "\<And>x y z . (- (x \<squnion> y) \<squnion> z) \<sqinter> x = z \<sqinter> x"
	+ using 17 29 1091 by metis
	+ have 1155: "\<And>x y . - - x \<sqinter> - (- x \<sqinter> y) = - - x"
	+ using 66 103 123 132 by metis
	+ have 1578: "\<And>x y z . - (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> y) = bot"
	+ using 82 1091 by metis
	+ have 1594: "\<And>x y z . - (x \<sqinter> (y \<squnion> z)) \<sqinter> (x \<sqinter> z) = bot"
	+ using 29 930 1578 by metis
	+ have 2094: "\<And>x y z . - (x \<squnion> (y \<sqinter> (z \<squnion> top))) \<sqinter> (x \<squnion> y) = bot"
	+ using 83 1128 by metis
	+ have 2097: "\<And>x y . - - (x \<squnion> y) \<sqinter> x = x"
	+ using 14 19 1129 by metis
	+ have 2124: "\<And>x y . - - (x \<squnion> y) \<sqinter> y = y"
	+ using 9 2097 by metis
	+ have 2135: "\<And>x y . - - ((top \<squnion> x) \<sqinter> y) \<sqinter> y = y"
	+ using 36 2097 by metis
	+ have 2136: "\<And>x y . - - ((x \<squnion> top) \<sqinter> y) \<sqinter> y = y"
	+ using 37 2097 by metis
	+ have 2137: "\<And>x y . - x \<squnion> - - (x \<squnion> y) = top"
	+ using 9 288 2097 by metis
	+ have 2138: "\<And>x y . - x \<sqinter> - (x \<squnion> y) = - (x \<squnion> y)"
	+ using 315 2097 by metis
	+ have 2151: "\<And>x y . - x \<squnion> - (x \<squnion> y) = - x"
	+ using 9 132 373 2097 by metis
	+ have 2191: "\<And>x y . - - x \<sqinter> (- y \<sqinter> x) = - y \<sqinter> x"
	+ using 88 2124 by metis
	+ have 2201: "\<And>x y . - x \<squnion> - - (y \<squnion> x) = top"
	+ using 9 288 2124 by metis
	+ have 2202: "\<And>x y . - x \<sqinter> - (y \<squnion> x) = - (y \<squnion> x)"
	+ using 315 2124 by metis
	+ have 2320: "\<And>x y . - (x \<sqinter> (y \<squnion> top)) = - x"
	+ using 83 373 2151 by metis
	+ have 2343: "\<And>x y . - (- x \<sqinter> y) \<squnion> - - y = top"
	+ using 88 2201 by metis
	+ have 2546: "\<And>x y z . - x \<squnion> ((- - x \<sqinter> - y) \<squnion> z) = - x \<squnion> (- y \<squnion> z)"
	+ using 111 116 by metis
	+ have 2706: "\<And>x y z . - x \<squnion> (y \<squnion> - - ((top \<squnion> z) \<sqinter> - x)) = y \<squnion> - - ((top \<squnion> z) \<sqinter> - x)"
	+ using 755 2135 by metis
	+ have 2810: "\<And>x y . - x \<sqinter> - ((y \<squnion> top) \<sqinter> x) = - ((y \<squnion> top) \<sqinter> x)"
	+ using 315 2136 by metis
	+ have 3022: "\<And>x y . - x \<squnion> - (- y \<sqinter> - x) = top"
	+ using 9 132 2343 by metis
	+ have 3133: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> y = y"
	+ using 14 42 3022 by metis
	+ have 3134: "\<And>x y . - x \<sqinter> (- y \<sqinter> - x) = - y \<sqinter> - x"
	+ using 14 43 3022 by metis
	+ have 3961: "\<And>x y . - - (x \<squnion> y) \<sqinter> - - x = - - x"
	+ using 14 136 2137 by metis
	+ have 4644: "\<And>x y z . - (x \<sqinter> - y) \<sqinter> (x \<sqinter> - (y \<squnion> z)) = bot"
	+ using 1594 2151 by metis
	+ have 5495: "\<And>x y z . - - (x \<sqinter> y) \<sqinter> - (x \<squnion> z) = bot"
	+ using 421 2138 by metis
	+ have 9413: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> y = - x \<sqinter> y"
	+ using 9 103 182 319 by metis
	+ have 9519: "\<And>x y z . - - (- x \<sqinter> y) \<sqinter> - - (x \<sqinter> z) = bot"
	+ using 373 5495 by metis
	+ have 11069: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> (- x \<sqinter> - z) = - (- - x \<sqinter> y)"
	+ using 316 757 by metis
	+ have 12370: "\<And>x y . - x \<sqinter> - (- - x \<sqinter> y) = - x"
	+ using 132 1155 by metis
	+ have 12376: "\<And>x y . - x \<sqinter> - (x \<sqinter> y) = - x"
	+ using 127 132 1155 by metis
	+ have 12383: "\<And>x y . - (x \<squnion> y) \<sqinter> - y = - (x \<squnion> y)"
	+ using 132 1155 2124 by metis
	+ have 12393: "\<And>x y . - - (- x \<sqinter> - y) = - x \<sqinter> - y"
	+ using 1155 3133 9413 by metis
	+ have 12407: "\<And>x y . - - x \<sqinter> - - (x \<squnion> y) = - - x"
	+ using 1155 2138 by metis
	+ have 12639: "\<And>x y . - x \<sqinter> - (- y \<sqinter> x) = - x"
	+ using 88 12383 by metis
	+ have 24647: "\<And>x y . (- x \<sqinter> - y) \<squnion> - (- x \<sqinter> - y) = top"
	+ using 19 12393 by metis
	+ have 28269: "\<And>x y z . - - (x \<sqinter> y) \<squnion> - (- x \<sqinter> z) = - (- x \<sqinter> z)"
	+ using 373 404 by metis
	+ have 28338: "\<And>x y . - (- - (x \<sqinter> y) \<sqinter> x) = - (x \<sqinter> y)"
	+ using 123 405 12370 by metis
	+ have 28422: "\<And>x y . - (- x \<sqinter> - y) = - (- y \<sqinter> - x)"
	+ using 13 3134 12393 28338 by metis
	+ have 28485: "\<And>x y . - x \<sqinter> - y = - y \<sqinter> - x"
	+ using 2097 3961 12393 28422 by metis
	+ have 30411: "\<And>x y . - x \<sqinter> (x \<squnion> (x \<sqinter> y)) = bot"
	+ using 9 82 2094 2320 by metis
	+ have 30469: "\<And>x . - x \<sqinter> (x \<squnion> - - x) = bot"
	+ using 9 123 132 30411 by metis
	+ have 37513: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> - (y \<squnion> x) = bot"
	+ using 2202 4644 by metis
	+ have 52421: "\<And>x y . - (- x \<sqinter> - (- x \<sqinter> y)) \<sqinter> y = y"
	+ using 14 144 24647 28485 by metis
	+ have 52520: "\<And>x y . - x \<sqinter> - (- x \<sqinter> y) = - x \<sqinter> - y"
	+ using 13 12376 12393 12639 28485 52421 by metis
	+ have 52533: "\<And>x y z . - - (x \<squnion> (y \<sqinter> (z \<squnion> top))) \<sqinter> (x \<squnion> y) = x \<squnion> y"
	+ using 15 49 2094 52421 by metis
	+ have 61101: "\<And>x y z . - (- - x \<sqinter> y) \<squnion> z = - x \<squnion> (- y \<squnion> z)"
	+ using 111 2546 12370 52520 by metis
	+ have 61156: "\<And>x y . - - (- x \<sqinter> y) = - x \<sqinter> - - y"
	+ using 419 52520 by metis
	+ have 61162: "\<And>x y . - (x \<squnion> (x \<sqinter> y)) = - x"
	+ using 15 49 2138 30411 52520 by metis
	+ have 61163: "\<And>x . - (x \<squnion> - - x) = - x"
	+ using 15 49 2138 30469 52520 by metis
	+ have 61229: "\<And>x y z . - x \<sqinter> (- - y \<sqinter> - (x \<sqinter> z)) = - x \<sqinter> - - y"
	+ using 13 15 49 132 9519 52520 61156 by metis
	+ have 61311: "\<And>x y . - x \<squnion> - y = - (- - y \<sqinter> x)"
	+ using 119 11069 61101 by metis
	+ have 61391: "\<And>x y . - (- x \<sqinter> - - y) = - (- x \<sqinter> y)"
	+ using 13 28269 61156 61229 61311 by metis
	+ have 61420: "\<And>x y . - (- - x \<sqinter> y) = - (- - y \<sqinter> x)"
	+ using 13 134 2191 61156 61311 by metis
	+ have 61454: "\<And>x y . - (x \<squnion> - (- y \<sqinter> - x)) = - y \<sqinter> - x"
	+ using 9 132 3133 61156 61162 by metis
	+ have 61648: "\<And>x y . - x \<sqinter> (x \<squnion> (- y \<sqinter> - - x)) = bot"
	+ using 1117 61163 by metis
	+ have 62434: "\<And>x y . - (- - x \<sqinter> y) \<sqinter> x = - y \<sqinter> x"
	+ using 43 61311 by metis
	+ have 63947: "\<And>x y . - (- x \<sqinter> y) \<sqinter> - (- y \<squnion> x) = bot"
	+ using 37513 61391 by metis
	+ have 64227: "\<And>x y . - (x \<squnion> (- y \<sqinter> - - x)) = - x"
	+ using 15 49 2138 52520 61648 by metis
	+ have 64239: "\<And>x y . - (x \<squnion> (- - x \<squnion> y)) = - (x \<squnion> y)"
	+ using 9 25 12407 64227 by metis
	+ have 64241: "\<And>x y . - (x \<squnion> (- - x \<sqinter> - y)) = - x"
	+ using 28485 64227 by metis
	+ have 64260: "\<And>x y . - (x \<squnion> - - (x \<sqinter> y)) = - x"
	+ using 420 64241 by metis
	+ have 64271: "\<And>x y . - (- x \<squnion> (y \<squnion> - - (y \<sqinter> x))) = - (- x \<squnion> y)"
	+ using 9 25 42 64260 by metis
	+ have 64281: "\<And>x y . - (- x \<squnion> y) = - (y \<squnion> - - ((top \<squnion> y) \<sqinter> - x))"
	+ using 9 25 157 2706 64260 by metis
	+ have 64282: "\<And>x y . - (x \<squnion> - - ((x \<squnion> top) \<sqinter> y)) = - (x \<squnion> - - y)"
	+ using 9 25 132 536 2810 28485 61311 64260 by metis
	+ have 65110: "\<And>x y . - ((- x \<sqinter> y) \<squnion> (- y \<squnion> x)) = bot"
	+ using 9 14 49 37513 63947 by metis
	+ have 65231: "\<And>x y . - (x \<squnion> ((- x \<sqinter> y) \<squnion> - y)) = bot"
	+ using 9 25 65110 by metis
	+ have 65585: "\<And>x y . - (x \<squnion> - y) = - - y \<sqinter> - x"
	+ using 61311 61454 64239 by metis
	+ have 65615: "\<And>x y . - x \<sqinter> - ((x \<squnion> top) \<sqinter> y) = - y \<sqinter> - x"
	+ using 132 28485 64282 65585 by metis
	+ have 65616: "\<And>x y . - (- x \<squnion> y) = - y \<sqinter> - ((top \<squnion> y) \<sqinter> - x)"
	+ using 132 28485 64281 65585 by metis
	+ have 65791: "\<And>x y . - x \<sqinter> - ((top \<squnion> x) \<sqinter> - y) = - - y \<sqinter> - x"
	+ using 89 132 12376 28485 64271 65585 65615 65616 by metis
	+ have 65933: "\<And>x y . - (- x \<squnion> y) = - - x \<sqinter> - y"
	+ using 65616 65791 by metis
	+ have 66082: "\<And>x y z . - (x \<squnion> (y \<squnion> - z)) = - - z \<sqinter> - (x \<squnion> y)"
	+ using 8 65585 by metis
	+ have 66204: "\<And>x y . - - x \<sqinter> - (y \<squnion> (- y \<sqinter> x)) = bot"
	+ using 65231 66082 by metis
	+ have 66281: "\<And>x y z . - (x \<squnion> (- y \<squnion> z)) = - - y \<sqinter> - (x \<squnion> z)"
	+ using 25 65933 by metis
	+ have 67527: "\<And>x y . - - (x \<squnion> (- x \<sqinter> y)) \<sqinter> y = y"
	+ using 14 49 62434 66204 by metis
	+ have 67762: "\<And>x y . - (- - x \<sqinter> (y \<squnion> (- y \<sqinter> x))) = - x"
	+ using 61420 67527 by metis
	+ have 68018: "\<And>x y z . - (x \<squnion> y) \<sqinter> (x \<squnion> (y \<sqinter> (z \<squnion> top))) = bot"
	+ using 8 83 1113 2320 by metis
	+ have 71989: "\<And>x y z . - (x \<squnion> (y \<sqinter> (z \<squnion> top))) = - (x \<squnion> y)"
	+ using 9 29 52533 67762 68018 by metis
	+ have 71997: "\<And>x y z . - ((x \<sqinter> (y \<squnion> top)) \<squnion> z) = - (x \<squnion> z)"
	+ using 17 2320 71989 by metis
	+ have 72090: "\<And>x y z . - (x \<squnion> ((x \<sqinter> y) \<squnion> z)) = - (x \<squnion> z)"
	+ using 10 14 705 71997 by metis
	+ have 72139: "\<And>x y . - (x \<squnion> y) = - x \<sqinter> - y"
	+ using 25 123 132 2138 65933 66281 72090 by metis
	+ show ?thesis
	+ using 72139 by metis
	+qed
	+
	+lemma l15:
	+ "--(x \<squnion> y) = --x \<squnion> --y"
	+ by (simp add: l11 l12 l4)
	+
	+lemma l13_var:
	+ "- - (- x \<sqinter> y) = - x \<sqinter> - - y"
	+proof -
	+ have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
	+ by (simp add: il_less_eq)
	+ have 4: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
	+ using 1 by metis
	+ have 5: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
	+ by (simp add: il_sub_inf_right_isotone_var)
	+ have 6: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
	+ by (simp add: pad2)
	+ have 7: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ by (simp add: il_associative)
	+ have 8: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
	+ using 7 by metis
	+ have 9: "\<And>x y . x \<squnion> y = y \<squnion> x"
	+ by (simp add: il_commutative)
	+ have 10: "\<And>x . x \<squnion> bot = x"
	+ by (simp add: il_bot_unit)
	+ have 11: "\<And>x . x \<squnion> x = x"
	+ by simp
	+ have 12: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
	+ by (simp add: il_inf_associative)
	+ have 13: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
	+ using 12 by metis
	+ have 14: "\<And>x . top \<sqinter> x = x"
	+ by simp
	+ have 15: "\<And>x . x \<sqinter> top = x"
	+ by simp
	+ have 16: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
	+ by (simp add: il_inf_right_dist_sup)
	+ have 17: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
	+ using 16 by metis
	+ have 19: "\<And>x . - x \<squnion> - - x = top"
	+ by simp
	+ have 20: "\<And>x . - x \<sqinter> x = bot"
	+ by (simp add: a_inf_complement_bot)
	+ have 22: "\<And>x y z . ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) \<squnion> (x \<sqinter> (y \<squnion> z)) = x \<sqinter> (y \<squnion> z)"
	+ using 4 5 by metis
	+ have 23: "\<And>x y z . (x \<sqinter> (y \<squnion> z)) \<squnion> ((x \<sqinter> y) \<squnion> (x \<sqinter> z)) = x \<sqinter> (y \<squnion> z)"
	+ using 9 22 by metis
	+ have 24: "\<And>x y . - - x \<squnion> - (- x \<sqinter> y) = - (- x \<sqinter> y)"
	+ using 4 6 by metis
	+ have 25: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
	+ using 8 9 by metis
	+ have 26: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
	+ using 9 23 25 by metis
	+ have 29: "\<And>x . bot \<squnion> x = x"
	+ using 9 10 by metis
	+ have 30: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
	+ using 8 11 by metis
	+ have 34: "\<And>u x y z . (x \<sqinter> (y \<sqinter> z)) \<squnion> (u \<sqinter> z) = ((x \<sqinter> y) \<squnion> u) \<sqinter> z"
	+ using 13 17 by metis
	+ have 35: "\<And>u x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> (u \<sqinter> y)) = (x \<squnion> (z \<sqinter> u)) \<sqinter> y"
	+ using 13 17 by metis
	+ have 38: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
	+ using 8 19 by metis
	+ have 41: "- top = bot"
	+ using 15 20 by metis
	+ have 42: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
	+ using 17 20 29 by metis
	+ have 43: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
	+ using 9 17 20 29 by metis
	+ have 45: "\<And>x . - bot \<squnion> - - x = - bot"
	+ using 9 20 24 by metis
	+ have 49: "- bot = top"
	+ using 19 29 41 by metis
	+ have 50: "\<And>x . top \<squnion> - - x = top"
	+ using 45 49 by metis
	+ have 62: "\<And>x y . x \<squnion> ((x \<sqinter> - y) \<squnion> (x \<sqinter> - - y)) = x"
	+ using 9 15 19 25 26 by metis
	+ have 65: "\<And>x y . (- (x \<squnion> y) \<sqinter> x) \<squnion> (- (x \<squnion> y) \<sqinter> y) = bot"
	+ using 9 20 26 29 by metis
	+ have 66: "\<And>x y z . (x \<sqinter> - - y) \<squnion> (x \<sqinter> - (- y \<sqinter> z)) = x \<sqinter> - (- y \<sqinter> z)"
	+ using 11 24 26 by metis
	+ have 69: "\<And>x y . x \<squnion> (x \<sqinter> - - y) = x"
	+ using 9 15 26 30 50 by metis
	+ have 81: "\<And>x . top \<squnion> - x = top"
	+ using 9 19 30 by metis
	+ have 88: "\<And>x y . x \<squnion> (- y \<sqinter> x) = x"
	+ using 14 17 81 by metis
	+ have 101: "\<And>x y z . x \<squnion> (y \<squnion> (x \<sqinter> - - z)) = y \<squnion> x"
	+ using 25 69 by metis
	+ have 103: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
	+ using 9 62 101 by metis
	+ have 123: "\<And>x . - - x \<sqinter> x = x"
	+ using 14 19 42 by metis
	+ have 127: "\<And>x y . - - x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
	+ using 13 123 by metis
	+ have 130: "\<And>x . - x \<squnion> - - - x = - x"
	+ using 9 24 123 by metis
	+ have 132: "\<And>x . - - - x = - x"
	+ using 9 103 123 130 by metis
	+ have 136: "\<And>x y . (- x \<squnion> y) \<sqinter> - - x = y \<sqinter> - - x"
	+ using 42 132 by metis
	+ have 144: "\<And>x y z . ((- (x \<sqinter> y) \<sqinter> x) \<squnion> z) \<sqinter> y = z \<sqinter> y"
	+ using 20 29 34 by metis
	+ have 182: "\<And>x y z . (x \<squnion> (- - (y \<sqinter> z) \<sqinter> y)) \<sqinter> z = (x \<squnion> y) \<sqinter> z"
	+ using 17 35 123 by metis
	+ have 288: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
	+ using 24 38 81 by metis
	+ have 315: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
	+ using 14 42 288 by metis
	+ have 319: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
	+ using 9 24 315 by metis
	+ have 387: "\<And>x y . - (x \<sqinter> y) \<sqinter> - x = - x"
	+ using 127 315 by metis
	+ have 405: "\<And>x y z . - (x \<sqinter> (y \<sqinter> z)) \<sqinter> - (x \<sqinter> y) = - (x \<sqinter> y)"
	+ using 13 387 by metis
	+ have 419: "\<And>x y . - x \<sqinter> - - (- x \<sqinter> y) = - - (- x \<sqinter> y)"
	+ using 315 387 by metis
	+ have 1091: "\<And>x y . - (x \<squnion> y) \<sqinter> x = bot"
	+ using 9 29 30 65 by metis
	+ have 1129: "\<And>x y z . (- (x \<squnion> y) \<squnion> z) \<sqinter> x = z \<sqinter> x"
	+ using 17 29 1091 by metis
	+ have 1155: "\<And>x y . - - x \<sqinter> - (- x \<sqinter> y) = - - x"
	+ using 66 103 123 132 by metis
	+ have 2097: "\<And>x y . - - (x \<squnion> y) \<sqinter> x = x"
	+ using 14 19 1129 by metis
	+ have 2124: "\<And>x y . - - (x \<squnion> y) \<sqinter> y = y"
	+ using 9 2097 by metis
	+ have 2137: "\<And>x y . - x \<squnion> - - (x \<squnion> y) = top"
	+ using 9 288 2097 by metis
	+ have 2201: "\<And>x y . - x \<squnion> - - (y \<squnion> x) = top"
	+ using 9 288 2124 by metis
	+ have 2343: "\<And>x y . - (- x \<sqinter> y) \<squnion> - - y = top"
	+ using 88 2201 by metis
	+ have 3022: "\<And>x y . - x \<squnion> - (- y \<sqinter> - x) = top"
	+ using 9 132 2343 by metis
	+ have 3133: "\<And>x y . - (- x \<sqinter> - y) \<sqinter> y = y"
	+ using 14 42 3022 by metis
	+ have 3134: "\<And>x y . - x \<sqinter> (- y \<sqinter> - x) = - y \<sqinter> - x"
	+ using 14 43 3022 by metis
	+ have 3961: "\<And>x y . - - (x \<squnion> y) \<sqinter> - - x = - - x"
	+ using 14 136 2137 by metis
	+ have 9413: "\<And>x y . - - (- x \<sqinter> y) \<sqinter> y = - x \<sqinter> y"
	+ using 9 103 182 319 by metis
	+ have 12370: "\<And>x y . - x \<sqinter> - (- - x \<sqinter> y) = - x"
	+ using 132 1155 by metis
	+ have 12376: "\<And>x y . - x \<sqinter> - (x \<sqinter> y) = - x"
	+ using 127 132 1155 by metis
	+ have 12383: "\<And>x y . - (x \<squnion> y) \<sqinter> - y = - (x \<squnion> y)"
	+ using 132 1155 2124 by metis
	+ have 12393: "\<And>x y . - - (- x \<sqinter> - y) = - x \<sqinter> - y"
	+ using 1155 3133 9413 by metis
	+ have 12639: "\<And>x y . - x \<sqinter> - (- y \<sqinter> x) = - x"
	+ using 88 12383 by metis
	+ have 24647: "\<And>x y . (- x \<sqinter> - y) \<squnion> - (- x \<sqinter> - y) = top"
	+ using 19 12393 by metis
	+ have 28338: "\<And>x y . - (- - (x \<sqinter> y) \<sqinter> x) = - (x \<sqinter> y)"
	+ using 123 405 12370 by metis
	+ have 28422: "\<And>x y . - (- x \<sqinter> - y) = - (- y \<sqinter> - x)"
	+ using 13 3134 12393 28338 by metis
	+ have 28485: "\<And>x y . - x \<sqinter> - y = - y \<sqinter> - x"
	+ using 2097 3961 12393 28422 by metis
	+ have 52421: "\<And>x y . - (- x \<sqinter> - (- x \<sqinter> y)) \<sqinter> y = y"
	+ using 14 144 24647 28485 by metis
	+ have 52520: "\<And>x y . - x \<sqinter> - (- x \<sqinter> y) = - x \<sqinter> - y"
	+ using 13 12376 12393 12639 28485 52421 by metis
	+ have 61156: "\<And>x y . - - (- x \<sqinter> y) = - x \<sqinter> - - y"
	+ using 419 52520 by metis
	+ show ?thesis
	+ using 61156 by metis
	+qed
	+
	+text \<open>Theorem 25.1\<close>
	+
	+subclass subset_boolean_algebra_2
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (simp add: il_associative)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (simp add: il_commutative)
	+ show "\<And>x. x \<squnion> x = x"
	+ by simp
	+ show "\<And>x y. x \<squnion> - (y \<squnion> - y) = x"
	+ using il_bot_unit l12 l6 by auto
	+ show "\<And>x y. - (x \<squnion> y) = - (- - x \<squnion> - - y)"
	+ by (metis l15 l4)
	+ show "\<And>x y. - x \<squnion> - (- x \<squnion> y) = - x \<squnion> - y"
	+ by (smt l11 l15 il_inf_right_dist_sup il_unit_bot l6 l7)
	+qed
	+
	+lemma aa_test:
	+ "p = --p \<Longrightarrow> test p"
	+ by (metis ppa_ppd.d_closed)
	+
	+lemma test_aa_increasing:
	+ "test p \<Longrightarrow> p \<le> --p"
	+ by (simp add: ppa_ppd.d_increasing_sub_identity test_sub_identity)
	+
	+lemma "test p \<Longrightarrow> - - (p \<sqinter> x) \<le> p" nitpick [expect=genuine] oops
	+lemma "test p \<Longrightarrow> --p \<le> p" nitpick [expect=genuine] oops
	+
	+end
	+
	+class pa_algebra = pa_semiring + minus +
	+ assumes pa_minus_def: "-x - -y = -(--x \<squnion> -y)"
	+begin
	+
	+subclass subset_boolean_algebra_2_extended
	+proof
	+ show "bot = (THE x. \<forall>z. x = - (z \<squnion> - z))"
	+ using l12 l6 by auto
	+ thus "top = - (THE x. \<forall>z. x = - (z \<squnion> - z))"
	+ using l2 by blast
	+ show "\<And>x y. - x \<sqinter> - y = - (- - x \<squnion> - - y)"
	+ by (metis l12 l4)
	+ show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
	+ by (simp add: pa_minus_def)
	+ show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
	+ by (simp add: il_less_eq)
	+ show "\<And>x y. (x < y) = (x \<squnion> y = y \<and> y \<squnion> x \<noteq> x)"
	+ by (simp add: il_less_eq less_le_not_le)
	+qed
	+
	+lemma "\<And>x y. - (x \<sqinter> - - y) = - (x \<sqinter> y)" nitpick [expect=genuine] oops
	+
	+end
	+
	+subsection \<open>Antidomain Semirings\<close>
	+
	+text \<open>Definition 24\<close>
	+
	+class a_semiring = ppa_semiring +
	+ assumes ad3: "-(x \<sqinter> y) \<le> -(x \<sqinter> --y)"
	+begin
	+
	+lemma l16:
	+ "- - x \<le> - (- x \<sqinter> y)"
	+proof -
	+ have 1: "\<And>x y . x \<le> y \<longleftrightarrow> x \<squnion> y = y"
	+ by (simp add: il_less_eq)
	+ have 3: "\<And>x y z . x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
	+ by (simp add: il_associative)
	+ have 4: "\<And>x y z . (x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
	+ using 3 by metis
	+ have 5: "\<And>x y . x \<squnion> y = y \<squnion> x"
	+ by (simp add: il_commutative)
	+ have 6: "\<And>x . x \<squnion> bot = x"
	+ by (simp add: il_bot_unit)
	+ have 7: "\<And>x . x \<squnion> x = x"
	+ by simp
	+ have 8: "\<And>x y . \<not>(x \<le> y) \<or> x \<squnion> y = y"
	+ using 1 by metis
	+ have 9: "\<And>x y . x \<le> y \<or> x \<squnion> y \<noteq> y"
	+ using 1 by metis
	+ have 10: "\<And>x y z . x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
	+ by (simp add: il_inf_associative)
	+ have 11: "\<And>x y z . (x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
	+ using 10 by metis
	+ have 12: "\<And>x . top \<sqinter> x = x"
	+ by simp
	+ have 13: "\<And>x . x \<sqinter> top = x"
	+ by simp
	+ have 14: "\<And>x y z . (x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
	+ by (simp add: il_sub_inf_right_isotone_var)
	+ have 15: "\<And>x y z . (x \<squnion> y) \<sqinter> z = (x \<sqinter> z) \<squnion> (y \<sqinter> z)"
	+ by (simp add: il_inf_right_dist_sup)
	+ have 16: "\<And>x y z . (x \<sqinter> y) \<squnion> (z \<sqinter> y) = (x \<squnion> z) \<sqinter> y"
	+ using 15 by metis
	+ have 17: "\<And>x . bot \<sqinter> x = bot"
	+ by simp
	+ have 18: "\<And>x . - x \<squnion> - - x = top"
	+ by simp
	+ have 19: "\<And>x . - x \<sqinter> x = bot"
	+ by (simp add: a_inf_complement_bot)
	+ have 20: "\<And>x y . - (x \<sqinter> y) \<le> - (x \<sqinter> - - y)"
	+ by (simp add: ad3)
	+ have 22: "\<And>x y z . x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
	+ using 4 5 by metis
	+ have 25: "\<And>x . bot \<squnion> x = x"
	+ using 5 6 by metis
	+ have 26: "\<And>x y . x \<squnion> (x \<squnion> y) = x \<squnion> y"
	+ using 4 7 by metis
	+ have 33: "\<And>x y z . (x \<sqinter> y) \<squnion> ((x \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z))) = x \<sqinter> (y \<squnion> z)"
	+ using 5 8 14 22 by metis
	+ have 47: "\<And>x y . - x \<squnion> (- - x \<squnion> y) = top \<squnion> y"
	+ using 4 18 by metis
	+ have 48: "\<And>x y . - - x \<squnion> (y \<squnion> - x) = y \<squnion> top"
	+ using 4 5 18 by metis
	+ have 51: "\<And>x y . - x \<sqinter> (x \<sqinter> y) = bot"
	+ using 11 17 19 by metis
	+ have 52: "- top = bot"
	+ using 13 19 by metis
	+ have 56: "\<And>x y . (- x \<squnion> y) \<sqinter> x = y \<sqinter> x"
	+ using 16 19 25 by metis
	+ have 57: "\<And>x y . (x \<squnion> - y) \<sqinter> y = x \<sqinter> y"
	+ using 5 16 19 25 by metis
	+ have 58: "\<And>x y . - (x \<sqinter> y) \<squnion> - (x \<sqinter> - - y) = - (x \<sqinter> - - y)"
	+ using 8 20 by metis
	+ have 60: "\<And>x . - x \<le> - - - x"
	+ using 12 20 by metis
	+ have 69: "- bot = top"
	+ using 18 25 52 by metis
	+ have 74: "\<And>x y . x \<le> x \<squnion> y"
	+ using 9 26 by metis
	+ have 78: "\<And>x . top \<squnion> - x = top"
	+ using 5 18 26 by metis
	+ have 80: "\<And>x y . x \<le> y \<squnion> x"
	+ using 5 74 by metis
	+ have 86: "\<And>x y z . x \<squnion> y \<le> x \<squnion> (z \<squnion> y)"
	+ using 22 80 by metis
	+ have 95: "\<And>x . - x \<squnion> - - - x = - - - x"
	+ using 8 60 by metis
	+ have 143: "\<And>x y . x \<squnion> (x \<sqinter> - y) = x"
	+ using 5 13 26 33 78 by metis
	+ have 370: "\<And>x y z . x \<squnion> (y \<sqinter> - z) \<le> x \<squnion> y"
	+ using 86 143 by metis
	+ have 907: "\<And>x . - x \<sqinter> - x = - x"
	+ using 12 18 57 by metis
	+ have 928: "\<And>x y . - x \<sqinter> (- x \<sqinter> y) = - x \<sqinter> y"
	+ using 11 907 by metis
	+ have 966: "\<And>x y . - (- x \<sqinter> - - (x \<sqinter> y)) = top"
	+ using 51 58 69 78 by metis
	+ have 1535: "\<And>x . - x \<squnion> - - - - x = top"
	+ using 47 78 95 by metis
	+ have 1630: "\<And>x y z . (x \<squnion> y) \<sqinter> - z \<le> (x \<sqinter> - z) \<squnion> y"
	+ using 16 370 by metis
	+ have 2422: "\<And>x . - x \<sqinter> - - - x = - - - x"
	+ using 12 57 1535 by metis
	+ have 6567: "\<And>x y . - x \<sqinter> - - (x \<sqinter> y) = bot"
	+ using 12 19 966 by metis
	+ have 18123: "\<And>x . - - - x = - x"
	+ using 95 143 2422 by metis
	+ have 26264: "\<And>x y . - x \<le> (- y \<sqinter> - x) \<squnion> - - y"
	+ using 12 18 1630 by metis
	+ have 26279: "\<And>x y . - - (x \<sqinter> y) \<le> - - x"
	+ using 25 6567 26264 by metis
	+ have 26307: "\<And>x y . - - (- x \<sqinter> y) \<le> - x"
	+ using 928 18123 26279 by metis
	+ have 26339: "\<And>x y . - x \<squnion> - - (- x \<sqinter> y) = - x"
	+ using 5 8 26307 by metis
	+ have 26564: "\<And>x y . - x \<squnion> - (- x \<sqinter> y) = top"
	+ using 5 48 78 18123 26339 by metis
	+ have 26682: "\<And>x y . - (- x \<sqinter> y) \<sqinter> x = x"
	+ using 12 56 26564 by metis
	+ have 26864: "\<And>x y . - - x \<le> - (- x \<sqinter> y)"
	+ using 18123 26279 26682 by metis
	+ show ?thesis
	+ using 26864 by metis
	+qed
	+
	+text \<open>Theorem 25.2\<close>
	+
	+subclass pa_semiring
	+proof
	+ show "\<And>x y. - - x \<le> - (- x \<sqinter> y)"
	+ by (rule l16)
	+qed
	+
	+lemma l17:
	+ "-(x \<sqinter> y) = -(x \<sqinter> --y)"
	+ by (simp add: ad3 antisym l14)
	+
	+lemma a_complement_inf_double_complement:
	+ "-(x \<sqinter> --y) = -(x \<sqinter> y)"
	+ using l17 by auto
	+
	+sublocale a_d: d_semiring_var where d = "\<lambda>x . --x"
	+proof
	+ show "\<And>x y. - - (x \<sqinter> - - y) \<le> - - (x \<sqinter> y)"
	+ using l17 by auto
	+ show "- - bot = bot"
	+ by (simp add: l1 l2)
	+qed
	+
	+lemma "test p \<Longrightarrow> - - (p \<sqinter> x) \<le> p"
	+ by (fact a_d.d2)
	+
	+end
	+
	+class a_algebra = a_semiring + minus +
	+ assumes a_minus_def: "-x - -y = -(--x \<squnion> -y)"
	+begin
	+
	+subclass pa_algebra
	+proof
	+ show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
	+ by (simp add: a_minus_def)
	+qed
	+
	+text \<open>Theorem 25.4\<close>
	+
	+subclass subset_boolean_algebra_4_extended
	+proof
	+ show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
	+ by (simp add: il_inf_associative)
	+ show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
	+ by (simp add: il_inf_right_dist_sup)
	+ show "\<And>x. - x \<sqinter> x = bot"
	+ by (simp add: a_inf_complement_bot)
	+ show "\<And>x. top \<sqinter> x = x"
	+ by simp
	+ show "\<And>x y. - (x \<sqinter> - - y) = - (x \<sqinter> y)"
	+ using l17 by auto
	+ show "\<And>x. x \<sqinter> top = x"
	+ by simp
	+ show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
	+ by (simp add: il_sub_inf_right_isotone)
	+qed
	+
	+end
	+
	+context subset_boolean_algebra_4_extended
	+begin
	+
	+subclass il_semiring
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (simp add: sup_assoc)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (simp add: sup_commute)
	+ show "\<And>x. x \<squnion> x = x"
	+ by simp
	+ show "\<And>x. x \<squnion> bot = x"
	+ by simp
	+ show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
	+ by (simp add: sba3_inf_associative)
	+ show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
	+ by (simp add: sba3_inf_right_dist_sup)
	+ show "\<And>x. top \<sqinter> x = x"
	+ by simp
	+ show "\<And>x. x \<sqinter> top = x"
	+ by simp
	+ show "\<And>x. bot \<sqinter> x = bot"
	+ by (simp add: inf_left_zero)
	+ show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
	+ by (simp add: inf_right_isotone)
	+ show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
	+ by (simp add: le_iff_sup)
	+ show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
	+ by (simp add: less_le_not_le)
	+qed
	+
	+subclass a_semiring
	+proof
	+ show "\<And>x. - x \<sqinter> x = bot"
	+ by (simp add: sba3_inf_complement_bot)
	+ show "\<And>x. - x \<squnion> - - x = top"
	+ by simp
	+ show "\<And>x y. - (x \<sqinter> y) \<le> - (x \<sqinter> - - y)"
	+ by (simp add: sba3_complement_inf_double_complement)
	+qed
	+
	+sublocale sba4_a: a_algebra
	+proof
	+ show "\<And>x y. - x - - y = - (- - x \<squnion> - y)"
	+ by (simp add: sub_minus_def)
	+qed
	+
	+end
	+
	+context stone_algebra
	+begin
	+
	+text \<open>Theorem 25.3\<close>
	+
	+subclass il_semiring
	+proof
	+ show "\<And>x y z. x \<squnion> (y \<squnion> z) = x \<squnion> y \<squnion> z"
	+ by (simp add: sup_assoc)
	+ show "\<And>x y. x \<squnion> y = y \<squnion> x"
	+ by (simp add: sup_commute)
	+ show "\<And>x. x \<squnion> x = x"
	+ by simp
	+ show "\<And>x. x \<squnion> bot = x"
	+ by simp
	+ show "\<And>x y z. x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
	+ by (simp add: inf.sup_monoid.add_assoc)
	+ show "\<And>x y z. (x \<squnion> y) \<sqinter> z = x \<sqinter> z \<squnion> y \<sqinter> z"
	+ by (simp add: inf_sup_distrib2)
	+ show "\<And>x. top \<sqinter> x = x"
	+ by simp
	+ show "\<And>x. x \<sqinter> top = x"
	+ by simp
	+ show "\<And>x. bot \<sqinter> x = bot"
	+ by simp
	+ show "\<And>x y z. x \<le> y \<Longrightarrow> z \<sqinter> x \<le> z \<sqinter> y"
	+ using inf.sup_right_isotone by blast
	+ show "\<And>x y. (x \<le> y) = (x \<squnion> y = y)"
	+ by (simp add: le_iff_sup)
	+ show "\<And>x y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
	+ by (simp add: less_le_not_le)
	+qed
	+
	+subclass a_semiring
	+proof
	+ show "\<And>x. - x \<sqinter> x = bot"
	+ by simp
	+ show "\<And>x. - x \<squnion> - - x = top"
	+ by simp
	+ show "\<And>x y. - (x \<sqinter> y) \<le> - (x \<sqinter> - - y)"
	+ by simp
	+qed
	+
	+end
	+
	+end
	+
	diff --git a/thys/Subset_Boolean_Algebras/document/root.bib b/thys/Subset_Boolean_Algebras/document/root.bib
	new file mode 100644
	--- /dev/null
	+++ b/thys/Subset_Boolean_Algebras/document/root.bib
	@@ -0,0 +1,268 @@
	+@STRING{afp = {Archive of Formal Proofs}}
	+@STRING{bams = {Bulletin of the American Mathematical Society}}
	+@STRING{dmj = {Duke Mathematical Journal}}
	+@STRING{iiua = {Institut f{\"u}r Informatik, Universit{\"a}t Augsburg}}
	+@STRING{jlamp = {Journal of Logical and Algebraic Methods in Programming}}
	+@STRING{lncs = {Lecture Notes in Computer Science}}
	+@STRING{sv = {Springer}}
	+@STRING{tocl = {ACM Transactions on Computational Logic}}
	+
	+@Article{BalbesHorn1970,
	+ author = {Balbes, R. and Horn, A.},
	+ title = {Stone lattices},
	+ journal = dmj,
	+ volume = 37,
	+ number = 3,
	+ pages = {537--545},
	+ year = 1970,
	+ note = {}
	+}
	+
	+@Article{Byrne1946,
	+ author = {Byrne, L.},
	+ title = {Two brief formulations of {B}oolean algebra},
	+ journal = bams,
	+ volume = 52,
	+ number = 4,
	+ pages = {269--272},
	+ year = 1946,
	+ note = {}
	+}
	+
	+@InProceedings{DesharnaisJipsenStruth2009,
	+ author = {Desharnais, J. and Jipsen, P. and Struth, G.},
	+ title = {Domain and Antidomain Semigroups},
	+ editor = {Berghammer, R. and Jaoua, A. M. and M{\"o}ller, B.},
	+ booktitle = {Relations and Kleene Algebra in Computer Science (RelMiCS/AKA 2009)},
	+ publisher = sv,
	+ series = lncs,
	+ volume = 5827,
	+ pages = {73--87},
	+ year = 2009,
	+ note = {}
	+}
	+
	+@InProceedings{DesharnaisMoeller2014,
	+ author = {Desharnais, J. and M{\"o}ller, B.},
	+ title = {Fuzzifying Modal Algebra},
	+ editor = {H{\"o}fner, P. and Jipsen, P. and Kahl, W. and M{\"u}ller, M. E.},
	+ booktitle = {Relational and Algebraic Methods in Computer Science (RAMiCS 2014)},
	+ publisher = sv,
	+ series = lncs,
	+ volume = 8428,
	+ pages = {395--411},
	+ year = 2014,
	+ note = {}
	+}
	+
	+@Article{DesharnaisMoellerStruth2006b,
	+ author = {Desharnais, J. and M{\"o}ller, B. and Struth, G.},
	+ title = {Kleene algebra with domain},
	+ journal = tocl,
	+ volume = 7,
	+ number = 4,
	+ pages = {798--833},
	+ year = 2006,
	+ note = {}
	+}
	+
	+@InProceedings{DesharnaisStruth2008a,
	+ author = {Desharnais, J. and Struth, G.},
	+ title = {Modal Semirings Revisited},
	+ editor = {Audebaud, P. and Paulin-Mohring, C.},
	+ booktitle = {Mathematics of Program Construction (MPC 2008)},
	+ publisher = sv,
	+ series = lncs,
	+ volume = 5133,
	+ pages = {360--387},
	+ year = 2008,
	+ note = {}
	+}
	+
	+@InProceedings{DesharnaisStruth2008b,
	+ author = {Desharnais, J. and Struth, G.},
	+ title = {Domain Axioms for a Family of Near-Semirings},
	+ editor = {Meseguer, J. and Ro{\c{s}}u, G.},
	+ booktitle = {Algebraic Methodology and Software Technology (AMAST 2008)},
	+ publisher = sv,
	+ series = lncs,
	+ volume = 5140,
	+ pages = {330--345},
	+ year = 2008,
	+ note = {}
	+}
	+
	+@Article{DesharnaisStruth2011,
	+ author = {Desharnais, J. and Struth, G.},
	+ title = {Internal axioms for domain semirings},
	+ journal = scp,
	+ volume = 76,
	+ number = 3,
	+ pages = {181--203},
	+ year = 2011,
	+ note = {}
	+}
	+
	+@Article{Frink1941,
	+ author = {Frink, Jr., O.},
	+ title = {Representations of {B}oolean algebras},
	+ journal = bams,
	+ volume = 47,
	+ number = 10,
	+ pages = {755--756},
	+ year = 1941,
	+ note = {}
	+}
	+
	+@Article{Frink1962,
	+ author = {Frink, O.},
	+ title = {Pseudo-complements in semi-lattices},
	+ journal = dmj,
	+ volume = 29,
	+ number = 4,
	+ pages = {505--514},
	+ year = 1962,
	+ note = {}
	+}
	+
	+@Book{Graetzer1971,
	+ author = {Gr{\"a}tzer, G.},
	+ title = {Lattice Theory: First Concepts and Distributive Lattices},
	+ publisher = {W. H. Freeman and Co.},
	+ year = 1971,
	+ note = {}
	+}
	+
	+@Article{GomesGuttmannHoefnerStruthWeber2016,
	+ author = {Gomes, V. B. F. and Guttmann, W. and H{\"o}fner, P. and Struth, G. and Weber, T.},
	+ title = {Kleene Algebras with Domain},
	+ journal = afp,
	+ year = 2016,
	+ note = {}
	+}
	+
	+@Article{Guttmann2012c,
	+ author = {Guttmann, W.},
	+ title = {Algebras for Iteration and Infinite Computations},
	+ journal = acta,
	+ volume = 49,
	+ number = 5,
	+ pages = {343--359},
	+ year = 2012,
	+ note = {}
	+}
	+
	+@Article{Guttmann2018c,
	+ author = {Guttmann, W.},
	+ title = {Verifying Minimum Spanning Tree Algorithms with {Stone} Relation Algebras},
	+ journal = jlamp,
	+ volume = 101,
	+ pages = {132--150},
	+ year = 2018,
	+ note = {}
	+}
	+
	+@InProceedings{GuttmannMoeller2020,
	+ author = {Guttmann, W. and M{\"o}ller, B.},
	+ title = {A Hierarchy of Algebras for {Boolean} Subsets},
	+ editor = {Fahrenberg, U. and Jipsen, P. and Winter, M.},
	+ booktitle = {Relational and Algebraic Methods in Computer Science (RAMiCS 2020)},
	+ publisher = sv,
	+ series = lncs,
	+ year = 2020,
	+ note = {To appear}
	+}
	+
	+@InProceedings{GuttmannStruthWeber2011b,
	+ author = {Guttmann, W. and Struth, G. and Weber, T.},
	+ title = {Automating Algebraic Methods in {Isabelle}},
	+ editor = {Qin, S. and Qiu, Z.},
	+ booktitle = {Formal Methods and Software Engineering (ICFEM 2011)},
	+ publisher = sv,
	+ series = lncs,
	+ volume = 6991,
	+ pages = {617--632},
	+ year = 2011,
	+ note = {}
	+}
	+
	+@Article{Hollenberg1997,
	+ author = {Hollenberg, M.},
	+ title = {An Equational Axiomatization of Dynamic Negation and Relational Composition},
	+ journal = {Journal of Logic, Language, and Information},
	+ volume = 6,
	+ number = 4,
	+ pages = {381--401},
	+ year = 1997,
	+ note = {}
	+}
	+
	+@Article{Huntington1933,
	+ author = {Huntington, E. V.},
	+ title = {Boolean Algebra. {A} Correction},
	+ journal = {Transactions of the American Mathematical Society},
	+ volume = 35,
	+ number = 2,
	+ pages = {557--558},
	+ year = 1933,
	+ note = {}
	+}
	+
	+@Article{JacksonStokes2004,
	+ author = {Jackson, M. and Stokes, T.},
	+ title = {Semilattice Pseudo-complements on Semigroups},
	+ journal = {Communications in Algebra},
	+ volume = 32,
	+ number = 8,
	+ pages = {2895--2918},
	+ year = 2004,
	+ note = {}
	+}
	+
	+@Article{Maddux1996,
	+ author = {Maddux, R. D.},
	+ title = {Relation-algebraic semantics},
	+ journal = tcs,
	+ volume = 160,
	+ number = {1--2},
	+ pages = {1--85},
	+ year = 1996,
	+ note = {}
	+}
	+
	+@Unpublished{McCune2010,
	+ author = {McCune, W.},
	+ title = {Prover9 and {Mace4}},
	+ year = {2005--2010},
	+ note = {Accessed 14 January 2020 at \url{https://www.cs.unm.edu/~mccune/prover9/}}
	+}
	+
	+@Article{MeredithPrior1968,
	+ author = {Meredith, C. A. and Prior, A. N.},
	+ title = {Equational Logic},
	+ journal = {Notre Dame Journal of Formal Logic},
	+ volume = 9,
	+ number = 3,
	+ pages = {212--226},
	+ year = 1968,
	+ note = {}
	+}
	+
	+@TechReport{MoellerDesharnais2019,
	+ author = {M{\"o}ller, B. and Desharnais, J.},
	+ title = {Basics of Modal Semirings and of {Kleene}/Omega Algebras},
	+ institution = iiua,
	+ type = {Report},
	+ number = {2019-03},
	+ year = 2019,
	+ note = {}
	+}
	+
	+@Article{WamplerDoty2016,
	+ author = {Wampler-Doty, M.},
	+ title = {A Complete Proof of the {Robbins} Conjecture},
	+ journal = afp,
	+ year = {2016, first version 2010},
	+ note = {}
	+}
	+
	diff --git a/thys/Subset_Boolean_Algebras/document/root.tex b/thys/Subset_Boolean_Algebras/document/root.tex
	new file mode 100644
	--- /dev/null
	+++ b/thys/Subset_Boolean_Algebras/document/root.tex
	@@ -0,0 +1,50 @@
	+\documentclass[11pt,a4paper]{article}
	+
	+\usepackage{isabelle,isabellesym}
	+\usepackage{amssymb,ragged2e}
	+\usepackage{pdfsetup}
	+
	+\isabellestyle{it}
	+\renewenvironment{isamarkuptext}{\par\isastyletext\begin{isapar}\justifying\color{blue}}{\end{isapar}}
	+\renewcommand\labelitemi{$*$}
	+
	+\begin{document}
	+
	+\title{A Hierarchy of Algebras for Boolean Subsets}
	+\author{Walter Guttmann and Bernhard M\"oller}
	+\maketitle
	+
	+\begin{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.
	+\end{abstract}
	+
	+\tableofcontents
	+
	+\section{Overview}
	+
	+A Boolean algebra often arises as a subalgebra of some overall algebra.
	+To avoid introducing a separate type for the subalgebra, the overall algebra can be enriched with a special operation leading into the intended subalgebra and axioms to guarantee that the range of this operation has a Boolean structure.
	+Examples for this are the antidomain operation in idempotent (left) semirings \cite{DesharnaisStruth2008b,DesharnaisStruth2008a,DesharnaisStruth2011}, dynamic negation \cite{Hollenberg1997}, the operation yielding tests in \cite{Guttmann2012c,GuttmannStruthWeber2011b}, and the pseudocomplement operation in Stone algebras \cite{Frink1962,Graetzer1971,Guttmann2018c}.
	+The present development looks at a common ground pattern.
	+
	+In Sections 2 and 3 we relate various axiomatisations of Boolean algebras from the literature and present a new equational one tailored to our needs.
	+Section 4 adapts this for the construction of Boolean subalgebras of larger overall algebras.
	+In Section 5 we add successively stronger assumptions to the overall algebra.
	+Sections 6, 7 and 8 show how Stone algebras, domain semirings and antidomain semirings fit into this hierarchy.
	+
	+This Isabelle/HOL theory formally verifies results in \cite{GuttmannMoeller2020}.
	+See that paper for further details and related work.
	+Some proofs in this theory have been translated from proofs found by Prover9 \cite{McCune2010} using a program we wrote.
	+
	+\begin{flushleft}
	+\input{session}
	+\end{flushleft}
	+
	+\bibliographystyle{abbrv}
	+\bibliography{root}
	+
	+\end{document}
	+
	diff --git a/web/entries/Akra_Bazzi.html b/web/entries/Akra_Bazzi.html
	--- a/web/entries/Akra_Bazzi.html
	+++ b/web/entries/Akra_Bazzi.html
	@@ -1,218 +1,220 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>The Akra-Bazzi theorem and the Master 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">
	</head>

	<body>

	<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">A</font>kra-Bazzi

	theorem

	and

	the

	<font class="first">M</font>aster

	theorem

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">The Akra-Bazzi theorem and the Master theorem</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	<a href="https://www21.in.tum.de/~eberlm">Manuel Eberl</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2015-07-14</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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).</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Akra_Bazzi-AFP,
	author = {Manuel Eberl},
	title = {The Akra-Bazzi theorem and the Master theorem},
	journal = {Archive of Formal Proofs},
	month = jul,
	year = 2015,
	note = {\url{http://isa-afp.org/entries/Akra_Bazzi.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="Landau_Symbols.html">Landau_Symbols</a> </td></tr>

	-
	+ <tr><td class="datahead">Used by:</td>
	+ <td class="data"><a href="Closest_Pair_Points.html">Closest_Pair_Points</a> </td></tr>
	+


	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Akra_Bazzi/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Akra_Bazzi/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Akra_Bazzi/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Akra_Bazzi-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-Akra_Bazzi-2018-08-16.tar.gz">
	afp-Akra_Bazzi-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Akra_Bazzi-2017-10-10.tar.gz">
	afp-Akra_Bazzi-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Akra_Bazzi-2016-12-17.tar.gz">
	afp-Akra_Bazzi-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Akra_Bazzi-2016-02-22.tar.gz">
	afp-Akra_Bazzi-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Akra_Bazzi-2015-07-24.tar.gz">
	afp-Akra_Bazzi-2015-07-24.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Akra_Bazzi-2015-07-15.tar.gz">
	afp-Akra_Bazzi-2015-07-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/Approximation_Algorithms.html b/web/entries/Approximation_Algorithms.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Approximation_Algorithms.html
	@@ -0,0 +1,174 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Verified Approximation Algorithms - 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>
	+
	+<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">V</font>erified
	+
	+ <font class="first">A</font>pproximation
	+
	+ <font class="first">A</font>lgorithms
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Verified Approximation Algorithms</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Authors:
	+ </td>
	+ <td class="data">
	+ Robin Eßmann (robin /dot/ essmann /at/ tum /dot/ de),
	+ <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a> and
	+ <a href="https://simon-robillard.net/">Simon Robillard</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2020-01-16</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract">
	+We present the first formal verification of approximation algorithms
	+for NP-complete optimization problems: vertex cover, independent set,
	+load balancing, and bin packing. The proofs correct incompletenesses
	+in existing proofs and improve the approximation ratio in one case.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Approximation_Algorithms-AFP,
	+ author = {Robin Eßmann and Tobias Nipkow and Simon Robillard},
	+ title = {Verified Approximation Algorithms},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2020,
	+ note = {\url{http://isa-afp.org/entries/Approximation_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>
	+
	+
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Approximation_Algorithms/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Approximation_Algorithms/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Approximation_Algorithms/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Approximation_Algorithms-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/Arith_Prog_Rel_Primes.html b/web/entries/Arith_Prog_Rel_Primes.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Arith_Prog_Rel_Primes.html
	@@ -0,0 +1,179 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Arithmetic progressions and relative primes - 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>
	+
	+<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>rithmetic
	+
	+ progressions
	+
	+ and
	+
	+ relative
	+
	+ primes
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Arithmetic progressions and relative primes</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ <a href="https://josephcmac.github.io/">José Manuel Rodríguez Caballero</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2020-02-01</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="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?</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Arith_Prog_Rel_Primes-AFP,
	+ author = {José Manuel Rodríguez Caballero},
	+ title = {Arithmetic progressions and relative primes},
	+ journal = {Archive of Formal Proofs},
	+ month = feb,
	+ year = 2020,
	+ note = {\url{http://isa-afp.org/entries/Arith_Prog_Rel_Primes.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/Arith_Prog_Rel_Primes/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Arith_Prog_Rel_Primes/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Arith_Prog_Rel_Primes/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Arith_Prog_Rel_Primes-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/Bicategory.html b/web/entries/Bicategory.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Bicategory.html
	@@ -0,0 +1,181 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Bicategories - 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>
	+
	+<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">B</font>icategories
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Bicategories</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ Eugene W. Stark (stark /at/ cs /dot/ stonybrook /dot/ edu)
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2020-01-06</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="abstract">
	+Taking as a starting point the author's previous work on
	+developing aspects of category theory in Isabelle/HOL, this article
	+gives a compatible formalization of the notion of
	+"bicategory" and develops a framework within which formal
	+proofs of facts about bicategories can be given. The framework
	+includes a number of basic results, including the Coherence Theorem,
	+the Strictness Theorem, pseudofunctors and biequivalence, and facts
	+about internal equivalences and adjunctions in a bicategory. As a
	+driving application and demonstration of the utility of the framework,
	+it is used to give a formal proof of a theorem, due to Carboni,
	+Kasangian, and Street, that characterizes up to biequivalence the
	+bicategories of spans in a category with pullbacks. The formalization
	+effort necessitated the filling-in of many details that were not
	+evident from the brief presentation in the original paper, as well as
	+identifying a few minor corrections along the way.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Bicategory-AFP,
	+ author = {Eugene W. Stark},
	+ title = {Bicategories},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2020,
	+ note = {\url{http://isa-afp.org/entries/Bicategory.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="MonoidalCategory.html">MonoidalCategory</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Bicategory/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Bicategory/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Bicategory/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Bicategory-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/Closest_Pair_Points.html b/web/entries/Closest_Pair_Points.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Closest_Pair_Points.html
	@@ -0,0 +1,181 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Closest Pair of Points Algorithms - 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>
	+
	+<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>losest
	+
	+ <font class="first">P</font>air
	+
	+ of
	+
	+ <font class="first">P</font>oints
	+
	+ <font class="first">A</font>lgorithms
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Closest Pair of Points Algorithms</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Authors:
	+ </td>
	+ <td class="data">
	+ Martin Rau (martin /dot/ rau /at/ tum /dot/ de) and
	+ <a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2020-01-13</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="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.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Closest_Pair_Points-AFP,
	+ author = {Martin Rau and Tobias Nipkow},
	+ title = {Closest Pair of Points Algorithms},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2020,
	+ note = {\url{http://isa-afp.org/entries/Closest_Pair_Points.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="Akra_Bazzi.html">Akra_Bazzi</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Closest_Pair_Points/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Closest_Pair_Points/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Closest_Pair_Points/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Closest_Pair_Points-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/Complex_Geometry.html b/web/entries/Complex_Geometry.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Complex_Geometry.html
	@@ -0,0 +1,176 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Complex Geometry - 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>
	+
	+<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>omplex
	+
	+ <font class="first">G</font>eometry
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Complex Geometry</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Authors:
	+ </td>
	+ <td class="data">
	+ Filip Marić (filip /at/ matf /dot/ bg /dot/ ac /dot/ rs) and
	+ <a href="http://poincare.matf.bg.ac.rs/~danijela">Danijela Simić</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2019-12-16</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="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.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Complex_Geometry-AFP,
	+ author = {Filip Marić and Danijela Simić},
	+ title = {Complex Geometry},
	+ journal = {Archive of Formal Proofs},
	+ month = dec,
	+ year = 2019,
	+ note = {\url{http://isa-afp.org/entries/Complex_Geometry.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="Poincare_Disc.html">Poincare_Disc</a> </td></tr>
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Complex_Geometry/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Complex_Geometry/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Complex_Geometry/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Complex_Geometry-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/Dirichlet_L.html b/web/entries/Dirichlet_L.html
	--- a/web/entries/Dirichlet_L.html
	+++ b/web/entries/Dirichlet_L.html
	@@ -1,193 +1,195 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Dirichlet L-Functions and Dirichlet's 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">
	</head>

	<body>

	<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>irichlet

	<font class="first">L</font>-Functions

	and

	<font class="first">D</font>irichlet's

	<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%">Dirichlet L-Functions and Dirichlet's Theorem</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	<a href="https://www21.in.tum.de/~eberlm">Manuel Eberl</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2017-12-21</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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></td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Dirichlet_L-AFP,
	author = {Manuel Eberl},
	title = {Dirichlet L-Functions and Dirichlet's Theorem},
	journal = {Archive of Formal Proofs},
	month = dec,
	year = 2017,
	note = {\url{http://isa-afp.org/entries/Dirichlet_L.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="Bertrands_Postulate.html">Bertrands_Postulate</a>, <a href="Dirichlet_Series.html">Dirichlet_Series</a>, <a href="Landau_Symbols.html">Landau_Symbols</a>, <a href="Zeta_Function.html">Zeta_Function</a> </td></tr>

	-
	+ <tr><td class="datahead">Used by:</td>
	+ <td class="data"><a href="Gauss_Sums.html">Gauss_Sums</a> </td></tr>
	+


	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Dirichlet_L/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Dirichlet_L/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Dirichlet_L/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Dirichlet_L-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-Dirichlet_L-2018-08-16.tar.gz">
	afp-Dirichlet_L-2018-08-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/Dirichlet_Series.html b/web/entries/Dirichlet_Series.html
	--- a/web/entries/Dirichlet_Series.html
	+++ b/web/entries/Dirichlet_Series.html
	@@ -1,199 +1,199 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Dirichlet 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">
	</head>

	<body>

	<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>irichlet

	<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%">Dirichlet Series</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	<a href="https://www21.in.tum.de/~eberlm">Manuel Eberl</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2017-10-12</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Dirichlet_Series-AFP,
	author = {Manuel Eberl},
	title = {Dirichlet Series},
	journal = {Archive of Formal Proofs},
	month = oct,
	year = 2017,
	note = {\url{http://isa-afp.org/entries/Dirichlet_Series.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="Euler_MacLaurin.html">Euler_MacLaurin</a>, <a href="Landau_Symbols.html">Landau_Symbols</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	- <td class="data"><a href="Dirichlet_L.html">Dirichlet_L</a>, <a href="Zeta_Function.html">Zeta_Function</a> </td></tr>
	+ <td class="data"><a href="Dirichlet_L.html">Dirichlet_L</a>, <a href="Gauss_Sums.html">Gauss_Sums</a>, <a href="Zeta_Function.html">Zeta_Function</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Dirichlet_Series/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Dirichlet_Series/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Dirichlet_Series/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Dirichlet_Series-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-Dirichlet_Series-2018-08-16.tar.gz">
	afp-Dirichlet_Series-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Dirichlet_Series-2017-10-16.tar.gz">
	afp-Dirichlet_Series-2017-10-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/Gauss_Sums.html b/web/entries/Gauss_Sums.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Gauss_Sums.html
	@@ -0,0 +1,187 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Gauss Sums and the Pólya–Vinogradov Inequality - 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>
	+
	+<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>auss
	+
	+ <font class="first">S</font>ums
	+
	+ and
	+
	+ the
	+
	+ <font class="first">P</font>ólya–Vinogradov
	+
	+ <font class="first">I</font>nequality
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Gauss Sums and the Pólya–Vinogradov Inequality</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Authors:
	+ </td>
	+ <td class="data">
	+ <a href="https://people.epfl.ch/rodrigo.raya">Rodrigo Raya</a> and
	+ <a href="https://www21.in.tum.de/~eberlm">Manuel Eberl</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2019-12-10</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="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></td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Gauss_Sums-AFP,
	+ author = {Rodrigo Raya and Manuel Eberl},
	+ title = {Gauss Sums and the Pólya–Vinogradov Inequality},
	+ journal = {Archive of Formal Proofs},
	+ month = dec,
	+ year = 2019,
	+ note = {\url{http://isa-afp.org/entries/Gauss_Sums.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="Dirichlet_L.html">Dirichlet_L</a>, <a href="Dirichlet_Series.html">Dirichlet_Series</a>, <a href="Polynomial_Interpolation.html">Polynomial_Interpolation</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Gauss_Sums/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Gauss_Sums/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Gauss_Sums/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Gauss_Sums-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/KD_Tree.html b/web/entries/KD_Tree.html
	--- a/web/entries/KD_Tree.html
	+++ b/web/entries/KD_Tree.html
	@@ -1,187 +1,187 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Multidimensional Binary Search Trees - 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>

	<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>ultidimensional

	<font class="first">B</font>inary

	<font class="first">S</font>earch

	<font class="first">T</font>rees

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Multidimensional Binary Search Trees</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- Martin Rau
	+ Martin Rau (martin /dot/ rau /at/ tum /dot/ de)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2019-05-30</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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>.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{KD_Tree-AFP,
	author = {Martin Rau},
	title = {Multidimensional Binary Search Trees},
	journal = {Archive of Formal Proofs},
	month = may,
	year = 2019,
	note = {\url{http://isa-afp.org/entries/KD_Tree.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="Median_Of_Medians_Selection.html">Median_Of_Medians_Selection</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/KD_Tree/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/KD_Tree/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/KD_Tree/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-KD_Tree-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-KD_Tree-2019-06-04.tar.gz">
	afp-KD_Tree-2019-06-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/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,213 +1,213 @@
	<!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">
	</head>

	<body>

	<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">
	<a href="http://cl-informatik.uibk.ac.at/users/bottesch/">Ralph Bottesch</a>,
	<a href="http://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	- <a href="https://home.in.tum.de/~haslbecm">Maximilian Haslbeck</a>,
	+ <a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Maximilian Haslbeck</a>,
	<a href="http://sjcjoosten.nl/">Sebastiaan Joosten</a>,
	<a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a> and
	<a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	</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">
	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{http://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> </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 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/Mersenne_Primes.html b/web/entries/Mersenne_Primes.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Mersenne_Primes.html
	@@ -0,0 +1,183 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Mersenne primes and the Lucas–Lehmer test - 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>
	+
	+<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>ersenne
	+
	+ primes
	+
	+ and
	+
	+ the
	+
	+ <font class="first">L</font>ucas–Lehmer
	+
	+ test
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Mersenne primes and the Lucas–Lehmer test</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Author:
	+ </td>
	+ <td class="data">
	+ <a href="https://www21.in.tum.de/~eberlm">Manuel Eberl</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2020-01-17</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="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></td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Mersenne_Primes-AFP,
	+ author = {Manuel Eberl},
	+ title = {Mersenne primes and the Lucas–Lehmer test},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2020,
	+ note = {\url{http://isa-afp.org/entries/Mersenne_Primes.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="Native_Word.html">Native_Word</a>, <a href="Pell.html">Pell</a>, <a href="Probabilistic_Prime_Tests.html">Probabilistic_Prime_Tests</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Mersenne_Primes/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Mersenne_Primes/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Mersenne_Primes/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Mersenne_Primes-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/Monad_Normalisation.html b/web/entries/Monad_Normalisation.html
	--- a/web/entries/Monad_Normalisation.html
	+++ b/web/entries/Monad_Normalisation.html
	@@ -1,194 +1,194 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Monad normalisation - 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>

	<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>onad

	normalisation

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Monad normalisation</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Joshua Schneider (joshua /dot/ schneider /at/ inf /dot/ ethz /dot/ ch),
	<a href="https://www21.in.tum.de/~eberlm">Manuel Eberl</a> and
	<a href="http://www.andreas-lochbihler.de">Andreas Lochbihler</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2017-05-05</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Monad_Normalisation-AFP,
	author = {Joshua Schneider and Manuel Eberl and Andreas Lochbihler},
	title = {Monad normalisation},
	journal = {Archive of Formal Proofs},
	month = may,
	year = 2017,
	note = {\url{http://isa-afp.org/entries/Monad_Normalisation.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="CryptHOL.html">CryptHOL</a>, <a href="Randomised_BSTs.html">Randomised_BSTs</a> </td></tr>
	+ <td class="data"><a href="CryptHOL.html">CryptHOL</a>, <a href="Randomised_BSTs.html">Randomised_BSTs</a>, <a href="Skip_Lists.html">Skip_Lists</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Monad_Normalisation/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Monad_Normalisation/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Monad_Normalisation/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Monad_Normalisation-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-Monad_Normalisation-2018-08-16.tar.gz">
	afp-Monad_Normalisation-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Monad_Normalisation-2017-10-10.tar.gz">
	afp-Monad_Normalisation-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Monad_Normalisation-2017-05-11.tar.gz">
	afp-Monad_Normalisation-2017-05-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/MonoidalCategory.html b/web/entries/MonoidalCategory.html
	--- a/web/entries/MonoidalCategory.html
	+++ b/web/entries/MonoidalCategory.html
	@@ -1,210 +1,212 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Monoidal Categories - 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>

	<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>onoidal

	<font class="first">C</font>ategories

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Monoidal Categories</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	Eugene W. Stark (stark /at/ cs /dot/ stonybrook /dot/ edu)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2017-05-04</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="abstract">
	Building on the formalization of basic category theory set out in the
	author's previous AFP article, the present article formalizes
	some basic aspects of the theory of monoidal categories. Among the
	notions defined here are monoidal category, monoidal functor, and
	equivalence of monoidal categories. The main theorems formalized are
	MacLane's coherence theorem and the constructions of the free
	monoidal category and free strict monoidal category generated by a
	given category. The coherence theorem is proved syntactically, using
	a structurally recursive approach to reduction of terms that might
	have some novel aspects. We also give proofs of some results given by
	Etingof et al, which may prove useful in a formal setting. In
	particular, we show that the left and right unitors need not be taken
	as given data in the definition of monoidal category, nor does the
	definition of monoidal functor need to take as given a specific
	isomorphism expressing the preservation of the unit object. Our
	definitions of monoidal category and monoidal functor are stated so as
	to take advantage of the economy afforded by these facts.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[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></td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{MonoidalCategory-AFP,
	author = {Eugene W. Stark},
	title = {Monoidal Categories},
	journal = {Archive of Formal Proofs},
	month = may,
	year = 2017,
	note = {\url{http://isa-afp.org/entries/MonoidalCategory.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="Category3.html">Category3</a> </td></tr>

	-
	+ <tr><td class="datahead">Used by:</td>
	+ <td class="data"><a href="Bicategory.html">Bicategory</a> </td></tr>
	+


	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/MonoidalCategory/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/MonoidalCategory/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/MonoidalCategory/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-MonoidalCategory-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-MonoidalCategory-2018-08-16.tar.gz">
	afp-MonoidalCategory-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-MonoidalCategory-2017-10-10.tar.gz">
	afp-MonoidalCategory-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-MonoidalCategory-2017-05-05.tar.gz">
	afp-MonoidalCategory-2017-05-05.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/Native_Word.html b/web/entries/Native_Word.html
	--- a/web/entries/Native_Word.html
	+++ b/web/entries/Native_Word.html
	@@ -1,233 +1,233 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Native Word - 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>

	<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">N</font>ative

	<font class="first">W</font>ord

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Native Word</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">
	<a href="http://www21.in.tum.de/~lammich">Peter Lammich</a>
	</td>
	</tr>


	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2013-09-17</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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.</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Change history:</td>
	<td class="abstract">[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></td>
	</tr>

	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Native_Word-AFP,
	author = {Andreas Lochbihler},
	title = {Native Word},
	journal = {Archive of Formal Proofs},
	month = sep,
	year = 2013,
	note = {\url{http://isa-afp.org/entries/Native_Word.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="Collections.html">Collections</a>, <a href="Datatype_Order_Generator.html">Datatype_Order_Generator</a>, <a href="Iptables_Semantics.html">Iptables_Semantics</a>, <a href="JinjaThreads.html">JinjaThreads</a>, <a href="ROBDD.html">ROBDD</a>, <a href="Separation_Logic_Imperative_HOL.html">Separation_Logic_Imperative_HOL</a>, <a href="WebAssembly.html">WebAssembly</a> </td></tr>
	+ <td class="data"><a href="Collections.html">Collections</a>, <a href="Datatype_Order_Generator.html">Datatype_Order_Generator</a>, <a href="Iptables_Semantics.html">Iptables_Semantics</a>, <a href="JinjaThreads.html">JinjaThreads</a>, <a href="Mersenne_Primes.html">Mersenne_Primes</a>, <a href="ROBDD.html">ROBDD</a>, <a href="Separation_Logic_Imperative_HOL.html">Separation_Logic_Imperative_HOL</a>, <a href="WebAssembly.html">WebAssembly</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Native_Word/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Native_Word/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Native_Word/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Native_Word-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-Native_Word-2018-08-16.tar.gz">
	afp-Native_Word-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Native_Word-2017-10-10.tar.gz">
	afp-Native_Word-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Native_Word-2016-12-17.tar.gz">
	afp-Native_Word-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Native_Word-2016-02-22.tar.gz">
	afp-Native_Word-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-Native_Word-2015-05-27.tar.gz">
	afp-Native_Word-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-Native_Word-2014-08-28.tar.gz">
	afp-Native_Word-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-Native_Word-2013-12-11.tar.gz">
	afp-Native_Word-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-Native_Word-2013-11-17.tar.gz">
	afp-Native_Word-2013-11-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/Pell.html b/web/entries/Pell.html
	--- a/web/entries/Pell.html
	+++ b/web/entries/Pell.html
	@@ -1,205 +1,207 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Pell's Equation - 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>

	<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>ell's

	<font class="first">E</font>quation

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Pell's Equation</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	<a href="https://www21.in.tum.de/~eberlm">Manuel Eberl</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2018-06-23</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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></td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Pell-AFP,
	author = {Manuel Eberl},
	title = {Pell's Equation},
	journal = {Archive of Formal Proofs},
	month = jun,
	year = 2018,
	note = {\url{http://isa-afp.org/entries/Pell.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="Mersenne_Primes.html">Mersenne_Primes</a> </td></tr>
	+


	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Pell/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Pell/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Pell/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Pell-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-Pell-2018-08-16.tar.gz">
	afp-Pell-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Pell-2018-06-25.tar.gz">
	afp-Pell-2018-06-25.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/Poincare_Disc.html b/web/entries/Poincare_Disc.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Poincare_Disc.html
	@@ -0,0 +1,182 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Poincaré Disc Model - 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>
	+
	+<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>oincaré
	+
	+ <font class="first">D</font>isc
	+
	+ <font class="first">M</font>odel
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Poincaré Disc Model</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Authors:
	+ </td>
	+ <td class="data">
	+ <a href="http://poincare.matf.bg.ac.rs/~danijela">Danijela Simić</a>,
	+ Filip Marić (filip /at/ matf /dot/ bg /dot/ ac /dot/ rs) and
	+ Pierre Boutry (boutry /at/ unistra /dot/ fr)
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2019-12-16</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="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).</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Poincare_Disc-AFP,
	+ author = {Danijela Simić and Filip Marić and Pierre Boutry},
	+ title = {Poincaré Disc Model},
	+ journal = {Archive of Formal Proofs},
	+ month = dec,
	+ year = 2019,
	+ note = {\url{http://isa-afp.org/entries/Poincare_Disc.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="Complex_Geometry.html">Complex_Geometry</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Poincare_Disc/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Poincare_Disc/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Poincare_Disc/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Poincare_Disc-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/Polynomial_Interpolation.html b/web/entries/Polynomial_Interpolation.html
	--- a/web/entries/Polynomial_Interpolation.html
	+++ b/web/entries/Polynomial_Interpolation.html
	@@ -1,206 +1,206 @@
	<!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">
	</head>

	<body>

	<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/~thiemann/">René Thiemann</a> and
	<a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	</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">
	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{http://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="Deep_Learning.html">Deep_Learning</a>, <a href="Polynomial_Factorization.html">Polynomial_Factorization</a> </td></tr>
	+ <td class="data"><a href="Deep_Learning.html">Deep_Learning</a>, <a href="Gauss_Sums.html">Gauss_Sums</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/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 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/Probabilistic_Prime_Tests.html b/web/entries/Probabilistic_Prime_Tests.html
	--- a/web/entries/Probabilistic_Prime_Tests.html
	+++ b/web/entries/Probabilistic_Prime_Tests.html
	@@ -1,186 +1,188 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Probabilistic Primality Testing - 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>

	<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>robabilistic

	<font class="first">P</font>rimality

	<font class="first">T</font>esting

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Probabilistic Primality Testing</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	Daniel Stüwe and
	<a href="https://www21.in.tum.de/~eberlm">Manuel Eberl</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2019-02-11</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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></td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Probabilistic_Prime_Tests-AFP,
	author = {Daniel Stüwe and Manuel Eberl},
	title = {Probabilistic Primality Testing},
	journal = {Archive of Formal Proofs},
	month = feb,
	year = 2019,
	note = {\url{http://isa-afp.org/entries/Probabilistic_Prime_Tests.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="Mersenne_Primes.html">Mersenne_Primes</a> </td></tr>
	+


	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Probabilistic_Prime_Tests/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Probabilistic_Prime_Tests/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Probabilistic_Prime_Tests/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Probabilistic_Prime_Tests-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-Probabilistic_Prime_Tests-2019-02-15.tar.gz">
	afp-Probabilistic_Prime_Tests-2019-02-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/ROBDD.html b/web/entries/ROBDD.html
	--- a/web/entries/ROBDD.html
	+++ b/web/entries/ROBDD.html
	@@ -1,209 +1,209 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Algorithms for Reduced Ordered Binary Decision Diagrams - 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>

	<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>lgorithms

	for

	<font class="first">R</font>educed

	<font class="first">O</font>rdered

	<font class="first">B</font>inary

	<font class="first">D</font>ecision

	<font class="first">D</font>iagrams

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Algorithms for Reduced Ordered Binary Decision Diagrams</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://liftm.de">Julius Michaelis</a>,
	- <a href="https://home.in.tum.de/~haslbecm">Maximilian Haslbeck</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="datahead">Submission date:</td>
	<td class="data">2016-04-27</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{ROBDD-AFP,
	author = {Julius Michaelis and Maximilian Haslbeck and Peter Lammich and Lars Hupel},
	title = {Algorithms for Reduced Ordered Binary Decision Diagrams},
	journal = {Archive of Formal Proofs},
	month = apr,
	year = 2016,
	note = {\url{http://isa-afp.org/entries/ROBDD.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="Native_Word.html">Native_Word</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/ROBDD/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/ROBDD/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/ROBDD/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-ROBDD-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-ROBDD-2018-08-16.tar.gz">
	afp-ROBDD-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-ROBDD-2017-10-10.tar.gz">
	afp-ROBDD-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-ROBDD-2016-12-17.tar.gz">
	afp-ROBDD-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-ROBDD-2016-04-27.tar.gz">
	afp-ROBDD-2016-04-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/SATSolverVerification.html b/web/entries/SATSolverVerification.html
	--- a/web/entries/SATSolverVerification.html
	+++ b/web/entries/SATSolverVerification.html
	@@ -1,260 +1,260 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Formal Verification of Modern SAT Solvers - 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>

	<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>ormal

	<font class="first">V</font>erification

	of

	<font class="first">M</font>odern

	<font class="first">S</font>AT

	<font class="first">S</font>olvers

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Formal Verification of Modern SAT Solvers</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	- <a href="http://poincare.matf.bg.ac.rs/~filip/">Filip Maric</a>
	+ Filip Marić (filip /at/ matf /dot/ bg /dot/ ac /dot/ rs)
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2008-07-23</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{SATSolverVerification-AFP,
	- author = {Filip Maric},
	+ author = {Filip Marić},
	title = {Formal Verification of Modern SAT Solvers},
	journal = {Archive of Formal Proofs},
	month = jul,
	year = 2008,
	note = {\url{http://isa-afp.org/entries/SATSolverVerification.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/SATSolverVerification/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/SATSolverVerification/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/SATSolverVerification/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-SATSolverVerification-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-SATSolverVerification-2018-08-16.tar.gz">
	afp-SATSolverVerification-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-SATSolverVerification-2017-10-10.tar.gz">
	afp-SATSolverVerification-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-SATSolverVerification-2016-12-17.tar.gz">
	afp-SATSolverVerification-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-SATSolverVerification-2016-02-22.tar.gz">
	afp-SATSolverVerification-2016-02-22.tar.gz
	</a>
	</li>
	<li>Isabelle 2015:
	<a href="../release/afp-SATSolverVerification-2015-05-27.tar.gz">
	afp-SATSolverVerification-2015-05-27.tar.gz
	</a>
	</li>
	<li>Isabelle 2014:
	<a href="../release/afp-SATSolverVerification-2014-08-28.tar.gz">
	afp-SATSolverVerification-2014-08-28.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-2:
	<a href="../release/afp-SATSolverVerification-2013-12-11.tar.gz">
	afp-SATSolverVerification-2013-12-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2013-1:
	<a href="../release/afp-SATSolverVerification-2013-11-17.tar.gz">
	afp-SATSolverVerification-2013-11-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-SATSolverVerification-2013-03-02.tar.gz">
	afp-SATSolverVerification-2013-03-02.tar.gz
	</a>
	</li>
	<li>Isabelle 2013:
	<a href="../release/afp-SATSolverVerification-2013-02-16.tar.gz">
	afp-SATSolverVerification-2013-02-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2012:
	<a href="../release/afp-SATSolverVerification-2012-05-24.tar.gz">
	afp-SATSolverVerification-2012-05-24.tar.gz
	</a>
	</li>
	<li>Isabelle 2011-1:
	<a href="../release/afp-SATSolverVerification-2011-10-11.tar.gz">
	afp-SATSolverVerification-2011-10-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2011:
	<a href="../release/afp-SATSolverVerification-2011-02-11.tar.gz">
	afp-SATSolverVerification-2011-02-11.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-2:
	<a href="../release/afp-SATSolverVerification-2010-07-01.tar.gz">
	afp-SATSolverVerification-2010-07-01.tar.gz
	</a>
	</li>
	<li>Isabelle 2009-1:
	<a href="../release/afp-SATSolverVerification-2009-12-12.tar.gz">
	afp-SATSolverVerification-2009-12-12.tar.gz
	</a>
	</li>
	<li>Isabelle 2009:
	<a href="../release/afp-SATSolverVerification-2009-04-29.tar.gz">
	afp-SATSolverVerification-2009-04-29.tar.gz
	</a>
	</li>
	<li>Isabelle 2008:
	<a href="../release/afp-SATSolverVerification-2008-07-27.tar.gz">
	afp-SATSolverVerification-2008-07-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/Simple_Firewall.html b/web/entries/Simple_Firewall.html
	--- a/web/entries/Simple_Firewall.html
	+++ b/web/entries/Simple_Firewall.html
	@@ -1,208 +1,208 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Simple Firewall - 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>

	<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>imple

	<font class="first">F</font>irewall

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Simple Firewall</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	<a href="http://net.in.tum.de/~diekmann">Cornelius Diekmann</a>,
	<a href="http://liftm.de">Julius Michaelis</a> and
	- <a href="https://home.in.tum.de/~haslbecm">Maximilian Haslbeck</a>
	+ <a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Maximilian Haslbeck</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2016-08-24</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Simple_Firewall-AFP,
	author = {Cornelius Diekmann and Julius Michaelis and Maximilian Haslbeck},
	title = {Simple Firewall},
	journal = {Archive of Formal Proofs},
	month = aug,
	year = 2016,
	note = {\url{http://isa-afp.org/entries/Simple_Firewall.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="IP_Addresses.html">IP_Addresses</a> </td></tr>

	<tr><td class="datahead">Used by:</td>
	<td class="data"><a href="Routing.html">Routing</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Simple_Firewall/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Simple_Firewall/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Simple_Firewall/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Simple_Firewall-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-Simple_Firewall-2018-08-16.tar.gz">
	afp-Simple_Firewall-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Simple_Firewall-2017-10-10.tar.gz">
	afp-Simple_Firewall-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Simple_Firewall-2016-12-17.tar.gz">
	afp-Simple_Firewall-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Simple_Firewall-2016-08-24.tar.gz">
	afp-Simple_Firewall-2016-08-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/Skip_Lists.html b/web/entries/Skip_Lists.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Skip_Lists.html
	@@ -0,0 +1,178 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>Skip Lists - 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>
	+
	+<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>kip
	+
	+ <font class="first">L</font>ists
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">Skip Lists</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Authors:
	+ </td>
	+ <td class="data">
	+ <a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Max W. Haslbeck</a> and
	+ <a href="https://www21.in.tum.de/~eberlm">Manuel Eberl</a>
	+ </td>
	+</tr>
	+
	+
	+
	+<tr>
	+ <td class="datahead">Submission date:</td>
	+ <td class="data">2020-01-09</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="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></td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Skip_Lists-AFP,
	+ author = {Max W. Haslbeck and Manuel Eberl},
	+ title = {Skip Lists},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2020,
	+ note = {\url{http://isa-afp.org/entries/Skip_Lists.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="Monad_Normalisation.html">Monad_Normalisation</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Skip_Lists/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Skip_Lists/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Skip_Lists/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Skip_Lists-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/Stone_Algebras.html b/web/entries/Stone_Algebras.html
	--- a/web/entries/Stone_Algebras.html
	+++ b/web/entries/Stone_Algebras.html
	@@ -1,197 +1,197 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Stone Algebras - 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>

	<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>tone

	<font class="first">A</font>lgebras

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Stone Algebras</td>
	</tr>

	<tr>
	<td class="datahead">
	Author:
	</td>
	<td class="data">
	<a href="http://www.cosc.canterbury.ac.nz/walter.guttmann/">Walter Guttmann</a>
	</td>
	</tr>



	<tr>
	<td class="datahead">Submission date:</td>
	<td class="data">2016-09-06</td>
	</tr>

	<tr>
	<td class="datahead" valign="top">Abstract:</td>
	<td class="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.</td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Stone_Algebras-AFP,
	author = {Walter Guttmann},
	title = {Stone Algebras},
	journal = {Archive of Formal Proofs},
	month = sep,
	year = 2016,
	note = {\url{http://isa-afp.org/entries/Stone_Algebras.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="Stone_Relation_Algebras.html">Stone_Relation_Algebras</a> </td></tr>
	+ <td class="data"><a href="Stone_Relation_Algebras.html">Stone_Relation_Algebras</a>, <a href="Subset_Boolean_Algebras.html">Subset_Boolean_Algebras</a> </td></tr>



	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Stone_Algebras/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Stone_Algebras/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Stone_Algebras/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Stone_Algebras-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-Stone_Algebras-2018-08-16.tar.gz">
	afp-Stone_Algebras-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Stone_Algebras-2017-10-10.tar.gz">
	afp-Stone_Algebras-2017-10-10.tar.gz
	</a>
	</li>
	<li>Isabelle 2016-1:
	<a href="../release/afp-Stone_Algebras-2016-12-17.tar.gz">
	afp-Stone_Algebras-2016-12-17.tar.gz
	</a>
	</li>
	<li>Isabelle 2016:
	<a href="../release/afp-Stone_Algebras-2016-09-06.tar.gz">
	afp-Stone_Algebras-2016-09-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/Subset_Boolean_Algebras.html b/web/entries/Subset_Boolean_Algebras.html
	new file mode 100644
	--- /dev/null
	+++ b/web/entries/Subset_Boolean_Algebras.html
	@@ -0,0 +1,186 @@
	+<!DOCTYPE html>
	+<html lang="en">
	+<head>
	+<meta charset="utf-8">
	+<title>A Hierarchy of Algebras for Boolean Subsets - 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>
	+
	+<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">H</font>ierarchy
	+
	+ of
	+
	+ <font class="first">A</font>lgebras
	+
	+ for
	+
	+ <font class="first">B</font>oolean
	+
	+ <font class="first">S</font>ubsets
	+
	+</h1>
	+ <p> </p>
	+
	+<table width="80%" class="data">
	+<tbody>
	+<tr>
	+ <td class="datahead" width="20%">Title:</td>
	+ <td class="data" width="80%">A Hierarchy of Algebras for Boolean Subsets</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead">
	+ Authors:
	+ </td>
	+ <td class="data">
	+ <a href="http://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="datahead">Submission date:</td>
	+ <td class="data">2020-01-31</td>
	+</tr>
	+
	+<tr>
	+ <td class="datahead" valign="top">Abstract:</td>
	+ <td class="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.</td>
	+</tr>
	+
	+
	+<tr>
	+ <td class="datahead" valign="top">BibTeX:</td>
	+ <td class="formatted">
	+ <pre>@article{Subset_Boolean_Algebras-AFP,
	+ author = {Walter Guttmann and Bernhard Möller},
	+ title = {A Hierarchy of Algebras for Boolean Subsets},
	+ journal = {Archive of Formal Proofs},
	+ month = jan,
	+ year = 2020,
	+ note = {\url{http://isa-afp.org/entries/Subset_Boolean_Algebras.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="Stone_Algebras.html">Stone_Algebras</a> </td></tr>
	+
	+
	+
	+
	+ </tbody>
	+</table>
	+
	+<p></p>
	+
	+<table class="links">
	+ <tbody>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Subset_Boolean_Algebras/outline.pdf">Proof outline</a><br>
	+ <a href="../browser_info/current/AFP/Subset_Boolean_Algebras/document.pdf">Proof document</a>
	+ </td>
	+ </tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../browser_info/current/AFP/Subset_Boolean_Algebras/index.html">Browse theories</a>
	+ </td></tr>
	+ <tr>
	+ <td class="links">
	+ <a href="../release/afp-Subset_Boolean_Algebras-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/Treaps.html b/web/entries/Treaps.html
	--- a/web/entries/Treaps.html
	+++ b/web/entries/Treaps.html
	@@ -1,200 +1,200 @@
	<!DOCTYPE html>
	<html lang="en">
	<head>
	<meta charset="utf-8">
	<title>Treaps - 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>

	<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>reaps

	</h1>
	<p> </p>

	<table width="80%" class="data">
	<tbody>
	<tr>
	<td class="datahead" width="20%">Title:</td>
	<td class="data" width="80%">Treaps</td>
	</tr>

	<tr>
	<td class="datahead">
	Authors:
	</td>
	<td class="data">
	- <a href="https://home.in.tum.de/~haslbecm">Maximilian Haslbeck</a>,
	+ <a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Maximilian Haslbeck</a>,
	<a href="https://www21.in.tum.de/~eberlm">Manuel Eberl</a> and
	<a href="http://www21.in.tum.de/~nipkow">Tobias Nipkow</a>
	</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">
	<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></td>
	</tr>


	<tr>
	<td class="datahead" valign="top">BibTeX:</td>
	<td class="formatted">
	<pre>@article{Treaps-AFP,
	author = {Maximilian Haslbeck and Manuel Eberl and Tobias Nipkow},
	title = {Treaps},
	journal = {Archive of Formal Proofs},
	month = feb,
	year = 2018,
	note = {\url{http://isa-afp.org/entries/Treaps.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="Comparison_Sort_Lower_Bound.html">Comparison_Sort_Lower_Bound</a>, <a href="Random_BSTs.html">Random_BSTs</a> </td></tr>




	</tbody>
	</table>

	<p></p>

	<table class="links">
	<tbody>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Treaps/outline.pdf">Proof outline</a><br>
	<a href="../browser_info/current/AFP/Treaps/document.pdf">Proof document</a>
	</td>
	</tr>
	<tr>
	<td class="links">
	<a href="../browser_info/current/AFP/Treaps/index.html">Browse theories</a>
	</td></tr>
	<tr>
	<td class="links">
	<a href="../release/afp-Treaps-current.tar.gz">Download this entry</a>
	</td>
	</tr>


	<tr><td class="links">Older releases:
	<ul>
	<li>Isabelle 2018:
	<a href="../release/afp-Treaps-2018-08-16.tar.gz">
	afp-Treaps-2018-08-16.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Treaps-2018-02-07.tar.gz">
	afp-Treaps-2018-02-07.tar.gz
	</a>
	</li>
	<li>Isabelle 2017:
	<a href="../release/afp-Treaps-2018-02-06.tar.gz">
	afp-Treaps-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/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,201 +1,202 @@
	<!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">
	</head>

	<body>

	<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">
	<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 to arbitrary sets;
	-Introduction of the coercion ord_of_nat :: "nat => V";
	-Addition of many new lemmas. (revision 85592c2f97b1)</td>
	+[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{http://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>






	</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:
	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/index.html b/web/index.html
	--- a/web/index.html
	+++ b/web/index.html
	@@ -1,4673 +1,4771 @@
	<!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>

	<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">2020</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="http://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://www21.in.tum.de/~eberlm">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>
	+ and <a href="https://simon-robillard.net/">Simon Robillard</a>
	+ </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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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="http://www.student.dtu.dk/~s144442/">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://www21.in.tum.de/~eberlm">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>
	</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://www21.in.tum.de/~eberlm">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">Szpilrajn Extension Theorem</a>
	<br>
	Author:
	Peter Zeller
	</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="http://www.student.dtu.dk/~s144442/">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="http://people.inf.ethz.ch/trayteld/">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:
	<a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	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:
	<a href="http://cl-informatik.uibk.ac.at/users/bottesch/">Ralph Bottesch</a>,
	Alban Reynaud
	and <a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	</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:
	<a href="http://www.cs.cmu.edu/~aplatzer/">André Platzer</a>
	</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="http://people.inf.ethz.ch/trayteld/">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 Andrei Popescu
	</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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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:
	<a href="http://cl-informatik.uibk.ac.at/users/bottesch/">Ralph Bottesch</a>,
	<a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Max W. Haslbeck</a>
	and <a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	</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:
	Anders Schlichtkrull,
	Jasmin Christian Blanchette
	and <a href="http://people.inf.ethz.ch/trayteld/">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</a>
	<br>
	Author:
	<a href="http://www.student.dtu.dk/~s144442/">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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="http://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/~thiemann/">René Thiemann</a>
	</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:
	<a href="http://lig-membres.imag.fr/mechenim/">Mnacho Echenim</a>
	</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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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="https://home.in.tum.de/~haslbecm">Maximilian Haslbeck</a>,
	+ <a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Maximilian Haslbeck</a>,
	<a href="https://www21.in.tum.de/~eberlm">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="http://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	<a href="http://sjcjoosten.nl/">Sebastiaan Joosten</a>,
	<a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	and <a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-02-06: <a href="entries/First_Order_Terms.html">First-Order Terms</a>
	<br>
	Authors:
	Christian Sternagel
	and <a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2018-02-06: <a href="entries/Error_Function.html">The Error Function</a>
	<br>
	Author:
	<a href="https://www21.in.tum.de/~eberlm">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:
	<a href="http://cl-informatik.uibk.ac.at/users/bottesch/">Ralph Bottesch</a>,
	<a href="http://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	- <a href="https://home.in.tum.de/~haslbecm">Maximilian Haslbeck</a>,
	+ <a href="http://cl-informatik.uibk.ac.at/users/mhaslbeck/">Maximilian Haslbeck</a>,
	<a href="http://sjcjoosten.nl/">Sebastiaan Joosten</a>,
	<a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	and <a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	</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:
	Anders Schlichtkrull,
	Jasmin Christian Blanchette,
	<a href="http://people.inf.ethz.ch/trayteld/">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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,
	Andrei Popescu
	and <a href="http://people.inf.ethz.ch/trayteld/">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/~thiemann/">René Thiemann</a>
	</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 Christian Sternagel
	</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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://philpapers.org/profile/805">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 Christian Sternagel
	</td>
	</tr>
	<tr>
	<td class="entry">
	2017-07-13: <a href="entries/Minkowskis_Theorem.html">Minkowski's Theorem</a>
	<br>
	Author:
	<a href="https://www21.in.tum.de/~eberlm">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="http://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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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="http://sjcjoosten.nl/">Sebastiaan Joosten</a>,
	<a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	and <a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	</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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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,
	Andrei Popescu
	and <a href="http://people.inf.ethz.ch/trayteld/">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="http://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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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>,
	Anders Schlichtkrull
	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:
	Anders Schlichtkrull
	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,
	Mathias Fleury
	and <a href="http://people.inf.ethz.ch/trayteld/">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="http://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>,
	<a href="http://sjcjoosten.nl/">Sebastiaan Joosten</a>,
	<a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	and <a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	</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://www21.in.tum.de/~eberlm">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="http://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://www21.in.tum.de/~eberlm">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="https://home.in.tum.de/~haslbecm">Maximilian Haslbeck</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 Christian Sternagel
	</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:
	Anders Schlichtkrull
	</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="http://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="http://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://www21.in.tum.de/~eberlm">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="http://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/~thiemann/">René Thiemann</a>
	and <a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	</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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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="https://home.in.tum.de/~haslbecm">Maximilian Haslbeck</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="http://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/~thiemann/">René Thiemann</a>
	and <a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	</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/~thiemann/">René Thiemann</a>
	and <a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	</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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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/~thiemann/">René Thiemann</a>,
	<a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	and <a href="http://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/~thiemann/">René Thiemann</a>
	and <a href="http://group-mmm.org/~ayamada/">Akihisa Yamada</a>
	</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://www21.in.tum.de/~eberlm">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://www21.in.tum.de/~eberlm">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="http://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	and <a href="http://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="http://people.inf.ethz.ch/trayteld/">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="http://people.inf.ethz.ch/trayteld/">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:
	Christian Sternagel
	and <a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	</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="http://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	and <a href="http://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="http://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	and <a href="http://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/~thiemann/">René Thiemann</a>
	</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://www21.in.tum.de/~eberlm">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:
	Christian Sternagel
	and <a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-10-03: <a href="entries/Certification_Monads.html">Certification Monads</a>
	<br>
	Authors:
	Christian Sternagel
	and <a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-09-25: <a href="entries/Imperative_Insertion_Sort.html">Imperative Insertion Sort</a>
	<br>
	Author:
	Christian Sternagel
	</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="http://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	and <a href="http://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:
	Christian Sternagel
	and <a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	</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="http://people.inf.ethz.ch/trayteld/">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:
	Andrei Popescu
	and Peter Lammich
	</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 Andrei Popescu
	</td>
	</tr>
	<tr>
	<td class="entry">
	2014-04-16: <a href="entries/Abstract_Completeness.html">Abstract Completeness</a>
	<br>
	Authors:
	Jasmin Christian Blanchette,
	Andrei Popescu
	and <a href="http://people.inf.ethz.ch/trayteld/">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:
	Andrei Popescu
	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/~thiemann/">René Thiemann</a>
	</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/~thiemann/">René Thiemann</a>
	</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="http://people.inf.ethz.ch/trayteld/">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://www21.in.tum.de/~eberlm">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="http://people.inf.ethz.ch/trayteld/">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 Andrei Popescu
	</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="http://www.unirioja.es/cu/jodivaso/">Jose Divasón</a>
	and <a href="http://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/~thiemann/">René Thiemann</a>
	</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 Christian Sternagel
	</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:
	Andrei Popescu
	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/~thiemann/">René Thiemann</a>
	</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:
	Christian Sternagel
	</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/~thiemann/">René Thiemann</a>
	</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:
	Christian Sternagel
	</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:
	Christian Sternagel
	and <a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	</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:
	Christian Sternagel,
	<a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>,
	<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:
	Christian Sternagel
	and <a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	</td>
	</tr>
	<tr>
	<td class="entry">
	2010-06-14: <a href="entries/Abstract-Rewriting.html">Abstract Rewriting</a>
	<br>
	Authors:
	Christian Sternagel
	and <a href="http://cl-informatik.uibk.ac.at/~thiemann/">René Thiemann</a>
	</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:
	Andrei Popescu
	</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:
	- <a href="http://poincare.matf.bg.ac.rs/~filip/">Filip Maric</a>
	+ 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
	</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,582 +1,567 @@
	<?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>27 Dec 2019 00:00:00 +0000</pubDate>
	+ <pubDate>01 Feb 2020 00:00:00 +0000</pubDate>
	+ <item>
	+ <title>Arithmetic progressions and relative primes</title>
	+ <link>https://www.isa-afp.org/entries/Arith_Prog_Rel_Primes.html</link>
	+ <guid>https://www.isa-afp.org/entries/Arith_Prog_Rel_Primes.html</guid>
	+ <dc:creator> José Manuel Rodríguez Caballero </dc:creator>
	+ <pubDate>01 Feb 2020 00:00:00 +0000</pubDate>
	+ <description>
	+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?</description>
	+ </item>
	+ <item>
	+ <title>A Hierarchy of Algebras for Boolean Subsets</title>
	+ <link>https://www.isa-afp.org/entries/Subset_Boolean_Algebras.html</link>
	+ <guid>https://www.isa-afp.org/entries/Subset_Boolean_Algebras.html</guid>
	+ <dc:creator> Walter Guttmann, Bernhard Möller </dc:creator>
	+ <pubDate>31 Jan 2020 00:00:00 +0000</pubDate>
	+ <description>
	+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.</description>
	+ </item>
	+ <item>
	+ <title>Mersenne primes and the Lucas–Lehmer test</title>
	+ <link>https://www.isa-afp.org/entries/Mersenne_Primes.html</link>
	+ <guid>https://www.isa-afp.org/entries/Mersenne_Primes.html</guid>
	+ <dc:creator> Manuel Eberl </dc:creator>
	+ <pubDate>17 Jan 2020 00:00:00 +0000</pubDate>
	+ <description>
	+<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&ndash;Lehmer test is
	+developed. This test decides primality for Mersenne numbers in time
	+polynomial in <em>n</em>.</p></description>
	+ </item>
	+ <item>
	+ <title>Verified Approximation Algorithms</title>
	+ <link>https://www.isa-afp.org/entries/Approximation_Algorithms.html</link>
	+ <guid>https://www.isa-afp.org/entries/Approximation_Algorithms.html</guid>
	+ <dc:creator> Robin Eßmann, Tobias Nipkow, Simon Robillard </dc:creator>
	+ <pubDate>16 Jan 2020 00:00:00 +0000</pubDate>
	+ <description>
	+We present the first formal verification of approximation algorithms
	+for NP-complete optimization problems: vertex cover, independent set,
	+load balancing, and bin packing. The proofs correct incompletenesses
	+in existing proofs and improve the approximation ratio in one case.</description>
	+ </item>
	+ <item>
	+ <title>Closest Pair of Points Algorithms</title>
	+ <link>https://www.isa-afp.org/entries/Closest_Pair_Points.html</link>
	+ <guid>https://www.isa-afp.org/entries/Closest_Pair_Points.html</guid>
	+ <dc:creator> Martin Rau, Tobias Nipkow </dc:creator>
	+ <pubDate>13 Jan 2020 00:00:00 +0000</pubDate>
	+ <description>
	+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.</description>
	+ </item>
	+ <item>
	+ <title>Skip Lists</title>
	+ <link>https://www.isa-afp.org/entries/Skip_Lists.html</link>
	+ <guid>https://www.isa-afp.org/entries/Skip_Lists.html</guid>
	+ <dc:creator> Max W. Haslbeck, Manuel Eberl </dc:creator>
	+ <pubDate>09 Jan 2020 00:00:00 +0000</pubDate>
	+ <description>
	+<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></description>
	+ </item>
	+ <item>
	+ <title>Bicategories</title>
	+ <link>https://www.isa-afp.org/entries/Bicategory.html</link>
	+ <guid>https://www.isa-afp.org/entries/Bicategory.html</guid>
	+ <dc:creator> Eugene W. Stark </dc:creator>
	+ <pubDate>06 Jan 2020 00:00:00 +0000</pubDate>
	+ <description>
	+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.</description>
	+ </item>
	<item>
	<title>The Irrationality of ζ(3)</title>
	<link>https://www.isa-afp.org/entries/Zeta_3_Irrational.html</link>
	<guid>https://www.isa-afp.org/entries/Zeta_3_Irrational.html</guid>
	<dc:creator> Manuel Eberl </dc:creator>
	<pubDate>27 Dec 2019 00:00:00 +0000</pubDate>
	<description>
	<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></description>
	</item>
	<item>
	<title>Formalizing a Seligman-Style Tableau System for Hybrid Logic</title>
	<link>https://www.isa-afp.org/entries/Hybrid_Logic.html</link>
	<guid>https://www.isa-afp.org/entries/Hybrid_Logic.html</guid>
	<dc:creator> Asta Halkjær From </dc:creator>
	<pubDate>20 Dec 2019 00:00:00 +0000</pubDate>
	<description>
	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 the cited 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 derivable 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 derivable. Similarly, I start from simpler
	versions of the @-rules and derive the general ones. These
	restrictions are imposed to rule out some means of nontermination.</description>
	</item>
	<item>
	<title>The Poincaré-Bendixson Theorem</title>
	<link>https://www.isa-afp.org/entries/Poincare_Bendixson.html</link>
	<guid>https://www.isa-afp.org/entries/Poincare_Bendixson.html</guid>
	<dc:creator> Fabian Immler, Yong Kiam Tan </dc:creator>
	<pubDate>18 Dec 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	+ <title>Poincaré Disc Model</title>
	+ <link>https://www.isa-afp.org/entries/Poincare_Disc.html</link>
	+ <guid>https://www.isa-afp.org/entries/Poincare_Disc.html</guid>
	+ <dc:creator> Danijela Simić, Filip Marić, Pierre Boutry </dc:creator>
	+ <pubDate>16 Dec 2019 00:00:00 +0000</pubDate>
	+ <description>
	+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 &#8450;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).</description>
	+ </item>
	+ <item>
	+ <title>Complex Geometry</title>
	+ <link>https://www.isa-afp.org/entries/Complex_Geometry.html</link>
	+ <guid>https://www.isa-afp.org/entries/Complex_Geometry.html</guid>
	+ <dc:creator> Filip Marić, Danijela Simić </dc:creator>
	+ <pubDate>16 Dec 2019 00:00:00 +0000</pubDate>
	+ <description>
	+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.</description>
	+ </item>
	+ <item>
	+ <title>Gauss Sums and the Pólya–Vinogradov Inequality</title>
	+ <link>https://www.isa-afp.org/entries/Gauss_Sums.html</link>
	+ <guid>https://www.isa-afp.org/entries/Gauss_Sums.html</guid>
	+ <dc:creator> Rodrigo Raya, Manuel Eberl </dc:creator>
	+ <pubDate>10 Dec 2019 00:00:00 +0000</pubDate>
	+ <description>
	+<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&mdash;Vinogradov inequality</li> </ul></description>
	+ </item>
	+ <item>
	<title>An Efficient Generalization of Counting Sort for Large, possibly Infinite Key Ranges</title>
	<link>https://www.isa-afp.org/entries/Generalized_Counting_Sort.html</link>
	<guid>https://www.isa-afp.org/entries/Generalized_Counting_Sort.html</guid>
	<dc:creator> Pasquale Noce </dc:creator>
	<pubDate>04 Dec 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Interval Arithmetic on 32-bit Words</title>
	<link>https://www.isa-afp.org/entries/Interval_Arithmetic_Word32.html</link>
	<guid>https://www.isa-afp.org/entries/Interval_Arithmetic_Word32.html</guid>
	<dc:creator> Brandon Bohrer </dc:creator>
	<pubDate>27 Nov 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Zermelo Fraenkel Set Theory in Higher-Order Logic</title>
	<link>https://www.isa-afp.org/entries/ZFC_in_HOL.html</link>
	<guid>https://www.isa-afp.org/entries/ZFC_in_HOL.html</guid>
	<dc:creator> Lawrence C. Paulson </dc:creator>
	<pubDate>24 Oct 2019 00:00:00 +0000</pubDate>
	<description>
	<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 =&gt; 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 to arbitrary sets;
	-Introduction of the coercion ord_of_nat :: "nat => V";
	-Addition of many new lemmas. (revision 85592c2f97b1)</description>
	+[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)</description>
	</item>
	<item>
	<title>Isabelle/C</title>
	<link>https://www.isa-afp.org/entries/Isabelle_C.html</link>
	<guid>https://www.isa-afp.org/entries/Isabelle_C.html</guid>
	<dc:creator> Frédéric Tuong, Burkhart Wolff </dc:creator>
	<pubDate>22 Oct 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>VerifyThis 2019 -- Polished Isabelle Solutions</title>
	<link>https://www.isa-afp.org/entries/VerifyThis2019.html</link>
	<guid>https://www.isa-afp.org/entries/VerifyThis2019.html</guid>
	<dc:creator> Peter Lammich, Simon Wimmer </dc:creator>
	<pubDate>16 Oct 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Aristotle's Assertoric Syllogistic</title>
	<link>https://www.isa-afp.org/entries/Aristotles_Assertoric_Syllogistic.html</link>
	<guid>https://www.isa-afp.org/entries/Aristotles_Assertoric_Syllogistic.html</guid>
	<dc:creator> Angeliki Koutsoukou-Argyraki </dc:creator>
	<pubDate>08 Oct 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Sigma Protocols and Commitment Schemes</title>
	<link>https://www.isa-afp.org/entries/Sigma_Commit_Crypto.html</link>
	<guid>https://www.isa-afp.org/entries/Sigma_Commit_Crypto.html</guid>
	<dc:creator> David Butler, Andreas Lochbihler </dc:creator>
	<pubDate>07 Oct 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Clean - An Abstract Imperative Programming Language and its Theory</title>
	<link>https://www.isa-afp.org/entries/Clean.html</link>
	<guid>https://www.isa-afp.org/entries/Clean.html</guid>
	<dc:creator> Frédéric Tuong, Burkhart Wolff </dc:creator>
	<pubDate>04 Oct 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Formalization of Multiway-Join Algorithms</title>
	<link>https://www.isa-afp.org/entries/Generic_Join.html</link>
	<guid>https://www.isa-afp.org/entries/Generic_Join.html</guid>
	<dc:creator> Thibault Dardinier </dc:creator>
	<pubDate>16 Sep 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Verification Components for Hybrid Systems</title>
	<link>https://www.isa-afp.org/entries/Hybrid_Systems_VCs.html</link>
	<guid>https://www.isa-afp.org/entries/Hybrid_Systems_VCs.html</guid>
	<dc:creator> Jonathan Julian Huerta y Munive </dc:creator>
	<pubDate>10 Sep 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Fourier Series</title>
	<link>https://www.isa-afp.org/entries/Fourier.html</link>
	<guid>https://www.isa-afp.org/entries/Fourier.html</guid>
	<dc:creator> Lawrence C Paulson </dc:creator>
	<pubDate>06 Sep 2019 00:00:00 +0000</pubDate>
	<description>
	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</description>
	</item>
	<item>
	<title>A Case Study in Basic Algebra</title>
	<link>https://www.isa-afp.org/entries/Jacobson_Basic_Algebra.html</link>
	<guid>https://www.isa-afp.org/entries/Jacobson_Basic_Algebra.html</guid>
	<dc:creator> Clemens Ballarin </dc:creator>
	<pubDate>30 Aug 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Formalisation of an Adaptive State Counting Algorithm</title>
	<link>https://www.isa-afp.org/entries/Adaptive_State_Counting.html</link>
	<guid>https://www.isa-afp.org/entries/Adaptive_State_Counting.html</guid>
	<dc:creator> Robert Sachtleben </dc:creator>
	<pubDate>16 Aug 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Laplace Transform</title>
	<link>https://www.isa-afp.org/entries/Laplace_Transform.html</link>
	<guid>https://www.isa-afp.org/entries/Laplace_Transform.html</guid>
	<dc:creator> Fabian Immler </dc:creator>
	<pubDate>14 Aug 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Linear Programming</title>
	<link>https://www.isa-afp.org/entries/Linear_Programming.html</link>
	<guid>https://www.isa-afp.org/entries/Linear_Programming.html</guid>
	<dc:creator> Julian Parsert, Cezary Kaliszyk </dc:creator>
	<pubDate>06 Aug 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Communicating Concurrent Kleene Algebra for Distributed Systems Specification</title>
	<link>https://www.isa-afp.org/entries/C2KA_DistributedSystems.html</link>
	<guid>https://www.isa-afp.org/entries/C2KA_DistributedSystems.html</guid>
	<dc:creator> Maxime Buyse, Jason Jaskolka </dc:creator>
	<pubDate>06 Aug 2019 00:00:00 +0000</pubDate>
	<description>
	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.</description>
	</item>
	<item>
	<title>Selected Problems from the International Mathematical Olympiad 2019</title>
	<link>https://www.isa-afp.org/entries/IMO2019.html</link>
	<guid>https://www.isa-afp.org/entries/IMO2019.html</guid>
	<dc:creator> Manuel Eberl </dc:creator>
	<pubDate>05 Aug 2019 00:00:00 +0000</pubDate>
	<description>
	<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></description>
	</item>
	- <item>
	- <title>Stellar Quorum Systems</title>
	- <link>https://www.isa-afp.org/entries/Stellar_Quorums.html</link>
	- <guid>https://www.isa-afp.org/entries/Stellar_Quorums.html</guid>
	- <dc:creator> Giuliano Losa </dc:creator>
	- <pubDate>01 Aug 2019 00:00:00 +0000</pubDate>
	- <description>
	-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).</description>
	- </item>
	- <item>
	- <title>A Formal Development of a Polychronous Polytimed Coordination Language</title>
	- <link>https://www.isa-afp.org/entries/TESL_Language.html</link>
	- <guid>https://www.isa-afp.org/entries/TESL_Language.html</guid>
	- <dc:creator> Hai Nguyen Van, Frédéric Boulanger, Burkhart Wolff </dc:creator>
	- <pubDate>30 Jul 2019 00:00:00 +0000</pubDate>
	- <description>
	-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.</description>
	- </item>
	- <item>
	- <title>Szpilrajn Extension Theorem</title>
	- <link>https://www.isa-afp.org/entries/Szpilrajn.html</link>
	- <guid>https://www.isa-afp.org/entries/Szpilrajn.html</guid>
	- <dc:creator> Peter Zeller </dc:creator>
	- <pubDate>27 Jul 2019 00:00:00 +0000</pubDate>
	- <description>
	-We formalize the Szpilrajn extension theorem, also known as
	-order-extension principal: Every strict partial order can be extended
	-to a strict linear order.</description>
	- </item>
	- <item>
	- <title>A Sequent Calculus for First-Order Logic</title>
	- <link>https://www.isa-afp.org/entries/FOL_Seq_Calc1.html</link>
	- <guid>https://www.isa-afp.org/entries/FOL_Seq_Calc1.html</guid>
	- <dc:creator> Asta Halkjær From </dc:creator>
	- <pubDate>18 Jul 2019 00:00:00 +0000</pubDate>
	- <description>
	-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.</description>
	- </item>
	- <item>
	- <title>A Verified Code Generator from Isabelle/HOL to CakeML</title>
	- <link>https://www.isa-afp.org/entries/CakeML_Codegen.html</link>
	- <guid>https://www.isa-afp.org/entries/CakeML_Codegen.html</guid>
	- <dc:creator> Lars Hupel </dc:creator>
	- <pubDate>08 Jul 2019 00:00:00 +0000</pubDate>
	- <description>
	-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.</description>
	- </item>
	- <item>
	- <title>Formalization of a Monitoring Algorithm for Metric First-Order Temporal Logic</title>
	- <link>https://www.isa-afp.org/entries/MFOTL_Monitor.html</link>
	- <guid>https://www.isa-afp.org/entries/MFOTL_Monitor.html</guid>
	- <dc:creator> Joshua Schneider, Dmitriy Traytel </dc:creator>
	- <pubDate>04 Jul 2019 00:00:00 +0000</pubDate>
	- <description>
	-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 forthcoming <a
	-href="http://people.inf.ethz.ch/trayteld/papers/rv19-verimon/verimon.pdf">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.</description>
	- </item>
	- <item>
	- <title>Complete Non-Orders and Fixed Points</title>
	- <link>https://www.isa-afp.org/entries/Complete_Non_Orders.html</link>
	- <guid>https://www.isa-afp.org/entries/Complete_Non_Orders.html</guid>
	- <dc:creator> Akihisa Yamada, Jérémy Dubut </dc:creator>
	- <pubDate>27 Jun 2019 00:00:00 +0000</pubDate>
	- <description>
	-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.</description>
	- </item>
	- <item>
	- <title>Priority Search Trees</title>
	- <link>https://www.isa-afp.org/entries/Priority_Search_Trees.html</link>
	- <guid>https://www.isa-afp.org/entries/Priority_Search_Trees.html</guid>
	- <dc:creator> Peter Lammich, Tobias Nipkow </dc:creator>
	- <pubDate>25 Jun 2019 00:00:00 +0000</pubDate>
	- <description>
	-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>.</description>
	- </item>
	- <item>
	- <title>Purely Functional, Simple, and Efficient Implementation of Prim and Dijkstra</title>
	- <link>https://www.isa-afp.org/entries/Prim_Dijkstra_Simple.html</link>
	- <guid>https://www.isa-afp.org/entries/Prim_Dijkstra_Simple.html</guid>
	- <dc:creator> Peter Lammich, Tobias Nipkow </dc:creator>
	- <pubDate>25 Jun 2019 00:00:00 +0000</pubDate>
	- <description>
	-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>.</description>
	- </item>
	- <item>
	- <title>Linear Inequalities</title>
	- <link>https://www.isa-afp.org/entries/Linear_Inequalities.html</link>
	- <guid>https://www.isa-afp.org/entries/Linear_Inequalities.html</guid>
	- <dc:creator> Ralph Bottesch, Alban Reynaud, René Thiemann </dc:creator>
	- <pubDate>21 Jun 2019 00:00:00 +0000</pubDate>
	- <description>
	-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.</description>
	- </item>
	</channel>
	</rss>
	diff --git a/web/statistics.html b/web/statistics.html
	--- a/web/statistics.html
	+++ b/web/statistics.html
	@@ -1,304 +1,303 @@
	<!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>

	<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">508</td></tr>
	-<tr><td>Number of Authors:</td><td class="statsnumber">335</td></tr>
	-<tr><td>Number of lemmas:</td><td class="statsnumber">~139,300</td></tr>
	-<tr><td>Lines of Code:</td><td class="statsnumber">~2,362,700</td></tr>
	+<tr><td>Number of Articles:</td><td class="statsnumber">518</td></tr>
	+<tr><td>Number of Authors:</td><td class="statsnumber">341</td></tr>
	+<tr><td>Number of lemmas:</td><td class="statsnumber">~141,600</td></tr>
	+<tr><td>Lines of Code:</td><td class="statsnumber">~2,462,100</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>14</td>
	</tr>
	<tr><td>2.</td>

	<td><a href="entries/Coinductive.html">Coinductive</a></td>
	<td>12</td>
	</tr>
	<td></td>
	<td><a href="entries/Collections.html">Collections</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>3.</td>

	<td><a href="entries/Landau_Symbols.html">Landau_Symbols</a></td>
	<td>11</td>
	</tr>
	<tr><td>4.</td>

	<td><a href="entries/Show.html">Show</a></td>
	<td>10</td>
	</tr>
	<tr><td>5.</td>

	<td><a href="entries/Abstract-Rewriting.html">Abstract-Rewriting</a></td>
	<td>9</td>
	</tr>
	<td></td>
	<td><a href="entries/Automatic_Refinement.html">Automatic_Refinement</a></td>
	<td>9</td>
	</tr>
	<td></td>
	<td><a href="entries/Deriving.html">Deriving</a></td>
	<td>9</td>
	</tr>
	<tr><td>6.</td>

	<td><a href="entries/Jordan_Normal_Form.html">Jordan_Normal_Form</a></td>
	<td>8</td>
	</tr>
	- <tr><td>7.</td>
	-
	+ <td></td>
	<td><a href="entries/Native_Word.html">Native_Word</a></td>
	- <td>7</td>
	+ <td>8</td>
	</tr>

	</table>
	<script>
	// DATA
	-var years = [2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019];
	-var no_articles = [14, 22, 29, 37, 52, 64, 86, 103, 128, 151, 208, 253, 326, 396, 455, 508];
	-var no_loc = [61000.0, 96800.0, 131400.0, 238900.0, 353800.0, 435900.0, 517100.0, 568100.0, 740400.0, 828100.0, 1038200.0, 1216500.0, 1580600.0, 1829200.0, 2100900.0, 2362700.0 ];
	-var no_authors = [14, 11, 6, 6, 10, 6, 24, 11, 17, 16, 36, 20, 63, 31, 29, 35];
	-var no_authors_series = [14, 25, 31, 37, 47, 53, 77, 88, 105, 121, 157, 177, 240, 271, 300, 335];
	-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","Poincare_Bendixson","Hybrid_Logic","Zeta_3_Irrational"];
	-var years_loc_articles = [ 2004 , , , , , , , , , , , , , ,2005 , , , , , , , ,2006 , , , , , , ,2007 , , , , , , , ,2008 , , , , , , , , , , , , , , ,2009 , , , , , , , , , , , ,2010 , , , , , , , , , , , , , , , , , , , , , ,2011 , , , , , , , , , , , , , , , , ,2012 , , , , , , , , , , , , , , , , , , , , , , , , ,2013 , , , , , , , , , , , , , , , , , , , , , , ,2014 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2015 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2016 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2017 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2018 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2019 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,];
	-var loc_articles = [ "1825","839","1544","1096","1058","2419","44269","205","142","1994","209","1109","3792","506","1141","3769","17203","3119","6430","1145","447","2537","1275","1583","1838","12833","13114","2685","1228","3556","4269","9649","970","2847","1741","79734","4738","3396","2186","31192","10664","6723","30332","180","794","1047","14411","2080","254","2221","5958","3462","799","1540","684","6654","8","2627","27490","330","32412","5025","4380","210","9533","447","2380","3399","611","6311","2042","840","713","1024","5632","1427","4078","2230","6061","22617","1602","1587","3370","2449","2592","260","1620","16","2930","7805","6557","6381","992","125","10136","332","235","1828","1039","1784","4425","303","4461","11857","2834","8583","1043","408","2940","2613","38065","3243","1480","2611","3153","27588","2580","25275","2266","4107","7701","1245","260","5309","73","9729","719","6673","1511","4354","1248","1908","6215","4974","10067","7894","538","3830","4595","202","848","1781","5209","10327","1524","150","5292","706","10774","2248","1458","1958","3067","11485","1860","1190","1219","2175","1144","14861","2215","1964","166","10685","6420","572","590","1698","465","883","4133","2138","1403","2280","1959","2467","220","5432","4431","9390","3999","4463","406","5930","1829","12832","2973","9486","4560","931","645","104","2338","1653","9143","752","2113","875","1727","627","931","1201","1296","7880","1922","90","28055","2879","2796","1116","4863","5259","8842","1169","6178","527","1601","6194","1782","5327","1085","4103","952","2446","1089","1060","2362","468","2074","3761","2148","710","16080","8267","908","1063","21109","9679","8635","3142","9161","690","435","13711","478","898","2716","10063","1162","401","498","495","741","843","3622","4616","6228","4123","8166","12108","2798","518","17583","2876","2411","5496","2453","886","1162","17386","509","702","5036","9700","4287","5331","3813","656","329","1057","8370","3257","2593","553","8478","206","18865","8773","3315","398","2960","12833","9483","373","173","384","18976","2545","6119","3777","1017","1889","4338","9356","20034","4067","3420","319","3204","169","19540","541","14618","2648","7033","7590","3898","3244","4493","855","2289","5004","1349","276","4339","1475","3482","7115","9662","601","1722","852","2194","12220","4035","590","13558","1695","4484","1640","835","694","737","3346","105","68","10492","1127","8000","4135","4711","1200","378","9435","2078","14059","639","1674","3930","4869","398","1531","5554","5553","1991","4205","478","4121","3146","3471","88","480","1261","1877","2193","250","10669","854","7461","5301","3079","2808","8849","5261","2253","5657","945","6519","992","489","809","8891","3133","338","854","493","4585","9457","15962","6058","10249","1818","2288","785","3260","8438","3278","12949","592","841","3383","3642","11559","13548","3734","5742","530","1044","7674","1042","1259","5297","2754","1390","1622","2173","13358","805","10027","2667","541","1271","3955","5318","9770","2765","934","11924","1743","2355","7917","1490","449","685","1811","1132","3248","3578","1644","2983","2218","7221","4968","2767","15247","34365","3259","6022","1900","372","10335","16867","3018","3300","5302","4576","10486","1000","15843","4437","9487","5543","3300","1518","2973","805","10253","2606","5193","472","3365","1869","2599","13350","945","192","4455","527","713","782","2335","2134","9934","2089","3736","3015","2350","3195","3812","176","1726","8509","3414","4830","5723","6402","4407","1907"];
	+var years = [2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020];
	+var no_articles = [14, 22, 29, 37, 52, 64, 86, 103, 128, 151, 208, 253, 326, 396, 455, 511, 518];
	+var no_loc = [61000.0, 96800.0, 131600.0, 239100.0, 354000.0, 436100.0, 517300.0, 568300.0, 740600.0, 828300.0, 1039800.0, 1218000.0, 1582200.0, 1831000.0, 2102800.0, 2395200.0, 2462100.0 ];
	+var no_authors = [14, 11, 6, 6, 10, 6, 24, 11, 17, 16, 36, 20, 63, 31, 28, 38, 4];
	+var no_authors_series = [14, 25, 31, 37, 47, 53, 77, 88, 105, 121, 157, 177, 240, 271, 299, 337, 341];
	+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","Poincare_Disc","Complex_Geometry","Poincare_Bendixson","Hybrid_Logic","Zeta_3_Irrational","Bicategory","Skip_Lists","Closest_Pair_Points","Approximation_Algorithms","Mersenne_Primes","Subset_Boolean_Algebras","Arith_Prog_Rel_Primes"];
	+var years_loc_articles = [ 2004 , , , , , , , , , , , , , ,2005 , , , , , , , ,2006 , , , , , , ,2007 , , , , , , , ,2008 , , , , , , , , , , , , , , ,2009 , , , , , , , , , , , ,2010 , , , , , , , , , , , , , , , , , , , , , ,2011 , , , , , , , , , , , , , , , , ,2012 , , , , , , , , , , , , , , , , , , , , , , , , ,2013 , , , , , , , , , , , , , , , , , , , , , , ,2014 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2015 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2016 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2017 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2018 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2019 , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ,2020 , , , , , ,];
	+var loc_articles = [ "1825","839","1544","1096","1058","2419","44269","205","142","1994","209","1109","3792","506","1141","3769","17203","3119","6430","1145","447","2537","1275","1583","1838","12833","13313","2685","1228","3556","4269","9649","970","2847","1741","79734","4738","3396","2186","31192","10664","6723","30332","180","794","1047","14411","2080","254","2221","5958","3462","799","1540","684","6654","8","2627","27490","330","32412","5025","4380","210","9533","447","2380","3399","611","6311","2042","840","713","1024","5632","1427","4078","2230","6061","22617","1602","1587","3370","2449","2592","260","1620","16","2930","7805","6557","6381","992","125","10136","332","235","1828","1039","1784","4425","303","4461","11857","2834","8583","1043","408","2940","2613","38065","3243","1480","2611","3153","27588","2580","25275","2266","4107","7701","1245","260","5309","73","9729","719","6673","1511","4354","1248","1908","6215","4974","10067","7894","538","3830","4595","202","848","1781","5209","10327","1524","150","5292","706","10774","2248","1458","1958","3067","11485","1860","1190","1219","2175","1144","14861","2215","1964","166","10685","6420","572","590","1698","465","883","4133","2138","1403","2280","1959","2467","220","5432","4431","9390","3999","4463","406","5930","1829","12832","4337","9486","4560","931","645","104","2338","1653","9143","752","2113","875","1727","627","931","1201","1296","7880","1922","90","28055","2879","2796","1116","4863","5259","8842","1169","6178","527","1601","6194","1782","5327","1085","4103","952","2446","1089","1060","2362","468","2074","3761","2177","710","16080","8267","908","1063","21109","9679","8635","3142","9161","690","435","13711","478","898","2716","10063","1162","401","498","495","741","843","3622","4616","6228","4123","8166","12108","2798","518","17583","2876","2411","5496","2453","886","1162","17386","509","702","5036","9700","4287","5331","3813","656","329","1057","8370","3257","2593","553","8478","206","18865","8773","3315","398","2960","12833","9483","373","173","384","18976","2545","6119","3777","1017","1889","4338","9356","20034","4053","3420","319","3204","169","19540","541","14618","2648","7033","7590","3898","3244","4507","855","2289","5004","1349","276","4339","1475","3482","7115","9662","601","1722","852","2194","12220","4035","590","13558","1695","4484","1640","835","694","737","3346","105","68","10492","1127","8000","4135","4711","1200","378","9435","2078","14059","639","1674","3930","4869","398","1531","5554","5553","1991","4205","478","4121","3146","3471","88","480","1261","1877","2193","250","10669","854","7461","5301","3079","2808","8849","5261","2249","5889","945","6519","992","489","809","8891","3133","338","854","493","4585","9457","15962","6058","10249","1818","2288","785","3260","8438","3278","12949","592","841","3383","3642","11559","13548","3734","5742","530","1044","7674","1042","1259","5297","2754","1390","1622","2173","13358","805","10027","2667","541","1271","3955","5318","9770","2765","934","11924","1743","2355","7917","1490","449","685","1811","1132","3248","3578","1644","2983","2218","7221","4968","2767","15247","34365","3259","6022","1900","372","10335","16867","3018","3300","5302","4576","10486","1000","15843","4437","9487","5543","3300","1518","2973","805","10253","2606","5193","472","3365","1869","2599","13350","945","192","4455","527","713","782","2335","2134","9934","2089","3736","3004","2350","3195","3812","176","1726","8509","4743","4830","5723","4561","10314","14529","6402","4407","1907","51955","2667","3689","2758","1699","3154","944"];

	</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,828 +1,838 @@
	<!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>

	<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>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>
	</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/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/IMAP-CRDT.html">IMAP-CRDT</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>
	<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>
	<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/OpSets.html">OpSets</a>
	<a href="entries/Stellar_Quorums.html">Stellar_Quorums</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>
	<strong>Optimization:</strong>
	<a href="entries/Simplex.html">Simplex</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>
	</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/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>
	</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>
	</div>
	<h3>Hardware</h3>
	<div class="list">
	<a href="entries/SPARCv8.html">SPARCv8</a>
	</div>
	<h3>Machine Learning</h3>
	<div class="list">
	<a href="entries/Deep_Learning.html">Deep_Learning</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>
	<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>
	<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/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>
	<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>
	<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>
	<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>
	</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/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/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/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>
	<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>
	</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>
	</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">
	<a href="entries/Propositional_Proof_Systems.html">Propositional_Proof_Systems</a>
	<a href="entries/MSO_Regex_Equivalence.html">MSO_Regex_Equivalence</a>
	<a href="entries/Formula_Derivatives.html">Formula_Derivatives</a>
	<a href="entries/Universal_Turing_Machine.html">Universal_Turing_Machine</a>
	<a href="entries/Boolean_Expression_Checkers.html">Boolean_Expression_Checkers</a>
	<a href="entries/Presburger-Automata.html">Presburger-Automata</a>
	<a href="entries/Verified-Prover.html">Verified-Prover</a>
	<a href="entries/Completeness.html">Completeness</a>
	<a href="entries/Ordinal.html">Ordinal</a>
	<a href="entries/Ordinals_and_Cardinals.html">Ordinals_and_Cardinals</a>
	<a href="entries/FOL-Fitting.html">FOL-Fitting</a>
	<a href="entries/Epistemic_Logic.html">Epistemic_Logic</a>
	<a href="entries/SequentInvertibility.html">SequentInvertibility</a>
	<a href="entries/LinearQuantifierElim.html">LinearQuantifierElim</a>
	<a href="entries/Nat-Interval-Logic.html">Nat-Interval-Logic</a>
	<a href="entries/Recursion-Theory-I.html">Recursion-Theory-I</a>
	<a href="entries/Free-Boolean-Algebra.html">Free-Boolean-Algebra</a>
	<a href="entries/Sort_Encodings.html">Sort_Encodings</a>
	<a href="entries/LTL.html">LTL</a>
	<a href="entries/HereditarilyFinite.html">HereditarilyFinite</a>
	<a href="entries/Incompleteness.html">Incompleteness</a>
	<a href="entries/HyperCTL.html">HyperCTL</a>
	<a href="entries/Abstract_Completeness.html">Abstract_Completeness</a>
	<a href="entries/PropResPI.html">PropResPI</a>
	<a href="entries/SuperCalc.html">SuperCalc</a>
	<a href="entries/Incredible_Proof_Machine.html">Incredible_Proof_Machine</a>
	<a href="entries/Resolution_FOL.html">Resolution_FOL</a>
	<a href="entries/Surprise_Paradox.html">Surprise_Paradox</a>
	<a href="entries/Allen_Calculus.html">Allen_Calculus</a>
	<a href="entries/Modal_Logics_for_NTS.html">Modal_Logics_for_NTS</a>
	<a href="entries/Paraconsistency.html">Paraconsistency</a>
	<a href="entries/FOL_Harrison.html">FOL_Harrison</a>
	<a href="entries/Abstract_Soundness.html">Abstract_Soundness</a>
	<a href="entries/Differential_Dynamic_Logic.html">Differential_Dynamic_Logic</a>
	<a href="entries/LambdaMu.html">LambdaMu</a>
	<a href="entries/Hybrid_Multi_Lane_Spatial_Logic.html">Hybrid_Multi_Lane_Spatial_Logic</a>
	<a href="entries/Ordered_Resolution_Prover.html">Ordered_Resolution_Prover</a>
	<a href="entries/Minsky_Machines.html">Minsky_Machines</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/MFOTL_Monitor.html">MFOTL_Monitor</a>
	<a href="entries/FOL_Seq_Calc1.html">FOL_Seq_Calc1</a>
	<a href="entries/Hybrid_Logic.html">Hybrid_Logic</a>
	</div>
	<h3>Philosophy</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>
	</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>
	</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/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>
	</div>
	<h3>Analysis</h3>
	<div class="list">
	<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/Cartan_FP.html">Cartan_FP</a>
	<a href="entries/Deep_Learning.html">Deep_Learning</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>
	</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/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>
	</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/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>
	</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/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>
	</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/General-Triangle.html">General-Triangle</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>
	</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>
	</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>
	</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/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>
	</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>
	</div>
	<h3>Physics</h3>
	<div class="list">
	<a href="entries/No_FTL_observers.html">No_FTL_observers</a>
	</div>
	<h3>Set Theory</h3>
	<div class="list">
	<a href="entries/ZFC_in_HOL.html">ZFC_in_HOL</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>
	</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: Thu, May 9, 5:39 AM (1 d, 23 h)
Storage Engine: chunks
Storage Format: Chunks
Storage Handle: Kcus6L2M2Rdk
Default Alt Text: (6 MB)

Offset	End	Complete
0	4194304	Yes
4194304	7249480	Yes

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions