theory v4_isar_T
  imports Main  "../../QML"
begin

text \<open>
@{text "Compossibility\<^sub>4'"}: If a table @{term x} is originally made from matter @{term y} and it
is possible for a table to be the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z} according to plan @{term p},
then it is also possible for table @{term x} to be originally made from matter @{term y} and in
addition some table or other @{term x'} to be the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p}.

@{text "Origin Uniqueness\<^sub>4'"}: It is impossible that a single table @{term x} is originally made from
matter @{term y} and in addition is originally made from matter @{term z}.

@{text "Sufficiency\<^sub>4'"}: If it is possible that a table @{term x'} is the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p}, then necessarily any table that is the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p} is the very table @{term x'} and no other.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>4'"}: If a given table is originally made from certain matter, then it is necessary
that the given table is not (the @{text "n\<^sup>t\<^sup>h"} table for any @{term n}) originally made from any non-overlapping
matter according to any plan.
\<close>

consts kTable :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu> \<Rightarrow> nat \<Rightarrow> \<sigma>" ("N")
(* (N x y p k) \<equiv> x is the kth table made from y according to p *)

axiomatization where refl :"(\<forall>x. x r x)"

lemma
assumes compossibilty4: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k))))\<rfloor>"
assumes origin_uniqueness4: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))))\<rfloor>"
assumes sufficiency4: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx)))\<rfloor>"
shows origin_essentialism4: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k')))\<rfloor>"

proof (rule allI)
  fix w
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
  proof (rule allI)
    fix x
    show "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
    proof (rule allI)
      fix y
      show "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
      proof (rule allI)
        fix z
        show "(\<^bold>\<forall>p. \<^bold>\<forall>k. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
        proof (rule allI)
          fix p
          show "(\<^bold>\<forall>k. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
          proof (rule allI)
            fix k
            show "((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k. N x z p' k))) w"
            proof (rule impI)
              assume antecedent: "((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k))) w"
              show "(\<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
              proof (rule notI)
                assume n_consequent: "(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k')) w"
                from antecedent have "(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (N x y p k)) w" by simp
                then have table_x_from_y: "(N x y p k) w" by (rule conjE)
                have non_overlapping: "(\<^bold>\<not>(y \<^bold>=\<^sup>L z)) w" using antecedent by auto
                then have compossibilty4_ante: "((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) w"
                  using table_x_from_y and non_overlapping and n_consequent by auto
                from compossibilty4 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w"..
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(((N x y p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" using compossibilty4_ante by (rule mp)
                then obtain u where u: "w r u \<and> ((((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) u)" by (rule exE)
                then have "(\<^bold>\<exists>x'. (N x' z p k)) u" by auto
                then obtain x' where x': "N x' z p k u" by (rule exE)

                have "w r u"
                  using `w r u \<and> ((((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) u)` by (rule conjE)

                from n_consequent obtain v where v: " w r v \<and> ((\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k') v)" by (rule exE)
                then have sufficiency4_ante:  "(\<^bold>\<diamond>(N x z p k)) w" by auto

                from sufficiency4 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w"..
                then have  "(\<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have  "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have  "(\<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have  "(\<^bold>\<diamond>(N x z p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have  "(\<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" using sufficiency4_ante by (rule mp)
                then have " w r u \<longrightarrow> (((\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) u)" by (rule allE)
                then have "(((\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) u)" using `w r u` by (rule mp)

                then have "(((N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) u" by (rule allE)
                then have "(x'\<^bold>=\<^sup>Lx) u" using `N x' z p k u` by (rule mp)

                then have "(N x z p k) u" using `(N x' z p k) u` by auto
                moreover from u have "(N x y p k) u" by simp
                then have "(N x y p k) u \<and> (N x z p k) u" using `(N x z p k) u` by (rule conjI)
                then have conj_existence: "(N x y p k \<^bold>\<and> N x z p k) u" by simp
                then have impossible_arg: "(N x y p k u) \<and> (N x z p k u) \<and> \<not>((y \<^bold>=\<^sup>L z) u)"
                  using non_overlapping by auto

                from origin_uniqueness4 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u"..
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
                then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
                then have "(\<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
                then have "(\<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
                then have "\<^bold>\<box>(\<^bold>\<not>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by auto
                then have "(\<^bold>\<not>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" using refl by blast
                then show "False" using impossible_arg by (rule notE)
              qed
            qed
          qed
        qed
      qed
    qed
  qed
qed

end


(*
 * Rational Preference Relations (RPRs).
 * (C)opyright Peter Gammie, peteg42 at gmail.com, commenced July 2006.
 * License: BSD
 *)

(*<*)
theory RPRs

imports FSext

begin
(*>*)

(* **************************************** *)

section\<open>Preliminaries\<close>

text\<open>

The auxiliary concepts defined here are standard \<^cite>\<open>"Routley:79" and "Sen:70a" and "Taylor:2005"\<close>. Throughout we make use of a fixed set @{term "A"} of
alternatives, drawn from some arbitrary type @{typ "'a"} of suitable
size. Taylor \<^cite>\<open>"Taylor:2005"\<close> terms this set an \emph{agenda}. Similarly
we have a type @{typ "'i"} of individuals and a population @{term "Is"}.

\<close>

(* **************************************** *)

subsection\<open>Rational Preference Relations (RPRs)\<close>

text\<open>

Definitions for rational preference relations (RPRs), which represent
indifference or strict preference amongst some set of alternatives.  These
are also called \emph{weak orders} or (ambiguously) \emph{ballots}.

Unfortunately Isabelle's standard ordering operators and lemmas are
typeclass-based, and as introducing new types is painful and we need several
orders per type, we need to repeat some things.

\<close>

type_synonym 'a RPR = "('a * 'a) set"

abbreviation rpr_eq_syntax :: "'a \<Rightarrow> 'a RPR \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<^bsub>_\<^esub>\<preceq> _" [50, 1000, 51] 50) where
  "x \<^bsub>r\<^esub>\<preceq> y == (x, y) \<in> r"

definition indifferent_pref :: "'a \<Rightarrow> 'a RPR \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<^bsub>_\<^esub>\<approx> _" [50, 1000, 51] 50) where
  "x \<^bsub>r\<^esub>\<approx> y \<equiv> (x \<^bsub>r\<^esub>\<preceq> y \<and> y \<^bsub>r\<^esub>\<preceq> x)"

lemma indifferent_prefI[intro]: "\<lbrakk> x \<^bsub>r\<^esub>\<preceq> y; y \<^bsub>r\<^esub>\<preceq> x \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<approx> y"
  unfolding indifferent_pref_def by simp

definition strict_pref :: "'a \<Rightarrow> 'a RPR \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<^bsub>_\<^esub>\<prec> _" [50, 1000, 51] 50) where
  "x \<^bsub>r\<^esub>\<prec> y \<equiv> (x \<^bsub>r\<^esub>\<preceq> y \<and> \<not>(y \<^bsub>r\<^esub>\<preceq> x))"

lemma strict_pref_def_irrefl[simp]: "\<not> (x \<^bsub>r\<^esub>\<prec> x)" unfolding strict_pref_def by blast

lemma strict_prefI[intro]: "\<lbrakk> x \<^bsub>r\<^esub>\<preceq> y; \<not>(y \<^bsub>r\<^esub>\<preceq> x) \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> y"
  unfolding strict_pref_def by simp

text\<open>

Traditionally, @{term "x \<^bsub>r\<^esub>\<preceq> y"} would be written $x\ R\ y$,
@{term "x \<^bsub>r\<^esub>\<approx> y"} as $x\ I\ y$ and @{term "x
\<^bsub>r\<^esub>\<prec> y"} as $x\ P\ y$, where the relation $r$ is implicit, and
profiles are indexed by subscripting.

\<close>

text\<open>

\emph{Complete} means that every pair of distinct alternatives is
ranked. The "distinct" part is a matter of taste, as it makes sense to
regard an alternative as as good as itself. Here I take reflexivity
separately.

\<close>

definition complete :: "'a set \<Rightarrow> 'a RPR \<Rightarrow> bool" where
  "complete A r \<equiv> (\<forall>x \<in> A. \<forall>y \<in> A - {x}. x \<^bsub>r\<^esub>\<preceq> y \<or> y \<^bsub>r\<^esub>\<preceq> x)"

lemma completeI[intro]:
  "(\<And>x y. \<lbrakk> x \<in> A; y \<in> A; x \<noteq> y \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y \<or> y \<^bsub>r\<^esub>\<preceq> x) \<Longrightarrow> complete A r"
  unfolding complete_def by auto

lemma completeD[dest]:
  "\<lbrakk> complete A r; x \<in> A; y \<in> A; x \<noteq> y \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y \<or> y \<^bsub>r\<^esub>\<preceq> x"
  unfolding complete_def by auto

lemma complete_less_not: "\<lbrakk> complete A r; hasw [x,y] A; \<not> x \<^bsub>r\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> y \<^bsub>r\<^esub>\<preceq> x"
  unfolding complete_def strict_pref_def by auto

lemma complete_indiff_not: "\<lbrakk> complete A r; hasw [x,y] A; \<not> x \<^bsub>r\<^esub>\<approx> y \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> y \<or> y \<^bsub>r\<^esub>\<prec> x"
  unfolding complete_def indifferent_pref_def strict_pref_def by auto

lemma complete_exh:
  assumes "complete A r"
      and "hasw [x,y] A"
  obtains (xPy) "x \<^bsub>r\<^esub>\<prec> y"
    | (yPx) "y \<^bsub>r\<^esub>\<prec> x"
    | (xIy) "x \<^bsub>r\<^esub>\<approx> y"
  using assms unfolding complete_def strict_pref_def indifferent_pref_def by auto

text\<open>

Use the standard @{term "refl"}. Also define \emph{irreflexivity}
analogously to how @{term "refl"} is defined in the standard library.

\<close>

declare refl_onI[intro] refl_onD[dest]

lemma complete_refl_on:
  "\<lbrakk> complete A r; refl_on A r; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y \<or> y \<^bsub>r\<^esub>\<preceq> x"
  unfolding complete_def by auto

definition irrefl :: "'a set \<Rightarrow> 'a RPR \<Rightarrow> bool" where
  "irrefl A r \<equiv> r \<subseteq> A \<times> A \<and> (\<forall>x \<in> A. \<not> x \<^bsub>r\<^esub>\<preceq> x)"

lemma irreflI[intro]: "\<lbrakk> r \<subseteq> A \<times> A; \<And>x. x \<in> A \<Longrightarrow> \<not> x \<^bsub>r\<^esub>\<preceq> x \<rbrakk> \<Longrightarrow> irrefl A r"
  unfolding irrefl_def by simp

lemma irreflD[dest]: "\<lbrakk> irrefl A r; (x, y) \<in> r \<rbrakk> \<Longrightarrow> hasw [x,y] A"
  unfolding irrefl_def by auto

lemma irreflD'[dest]:
  "\<lbrakk> irrefl A r; r \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>x y. hasw [x,y] A \<and> (x, y) \<in> r"
  unfolding irrefl_def by auto

text\<open>Rational preference relations, also known as weak orders and (I
guess) complete pre-orders.\<close>

definition rpr :: "'a set \<Rightarrow> 'a RPR \<Rightarrow> bool" where
  "rpr A r \<equiv> complete A r \<and> refl_on A r \<and> trans r"

lemma rprI[intro]: "\<lbrakk> complete A r; refl_on A r; trans r \<rbrakk> \<Longrightarrow> rpr A r"
  unfolding rpr_def by simp

lemma rprD: "rpr A r \<Longrightarrow> complete A r \<and> refl_on A r \<and> trans r"
  unfolding rpr_def by simp

lemma rpr_in_set[dest]: "\<lbrakk> rpr A r; x \<^bsub>r\<^esub>\<preceq> y \<rbrakk> \<Longrightarrow> {x,y} \<subseteq> A"
  unfolding rpr_def refl_on_def by auto

lemma rpr_refl[dest]: "\<lbrakk> rpr A r; x \<in> A \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> x"
  unfolding rpr_def by blast

lemma rpr_less_not: "\<lbrakk> rpr A r; hasw [x,y] A; \<not> x \<^bsub>r\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> y \<^bsub>r\<^esub>\<preceq> x"
  unfolding rpr_def by (auto simp add: complete_less_not)

lemma rpr_less_imp_le[simp]: "\<lbrakk> x \<^bsub>r\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y"
  unfolding strict_pref_def by simp

lemma rpr_less_imp_neq[simp]: "\<lbrakk> x \<^bsub>r\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> x \<noteq> y"
  unfolding strict_pref_def by blast

lemma rpr_less_trans[trans]: "\<lbrakk> x \<^bsub>r\<^esub>\<prec> y; y \<^bsub>r\<^esub>\<prec> z; rpr A r \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> z"
  unfolding rpr_def strict_pref_def trans_def by blast

lemma rpr_le_trans[trans]: "\<lbrakk> x \<^bsub>r\<^esub>\<preceq> y; y \<^bsub>r\<^esub>\<preceq> z; rpr A r \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> z"
  unfolding rpr_def trans_def by blast

lemma rpr_le_less_trans[trans]: "\<lbrakk> x \<^bsub>r\<^esub>\<preceq> y; y \<^bsub>r\<^esub>\<prec> z; rpr A r \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> z"
  unfolding rpr_def strict_pref_def trans_def by blast

lemma rpr_less_le_trans[trans]: "\<lbrakk> x \<^bsub>r\<^esub>\<prec> y; y \<^bsub>r\<^esub>\<preceq> z; rpr A r \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> z"
  unfolding rpr_def strict_pref_def trans_def by blast

lemma rpr_complete: "\<lbrakk> rpr A r; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y \<or> y \<^bsub>r\<^esub>\<preceq> x"
  unfolding rpr_def by (blast dest: complete_refl_on)

(* **************************************** *)

subsection\<open>Profiles\<close>

text \<open>A \emph{profile} (also termed a collection of \emph{ballots}) maps
each individual to an RPR for that individual.\<close>

type_synonym ('a, 'i) Profile = "'i \<Rightarrow> 'a RPR"

definition profile :: "'a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> bool" where
  "profile A Is P \<equiv> Is \<noteq> {} \<and> (\<forall>i \<in> Is. rpr A (P i))"

lemma profileI[intro]: "\<lbrakk> \<And>i. i \<in> Is \<Longrightarrow> rpr A (P i); Is \<noteq> {} \<rbrakk> \<Longrightarrow> profile A Is P"
  unfolding profile_def by simp

lemma profile_rprD[dest]: "\<lbrakk> profile A Is P; i \<in> Is \<rbrakk> \<Longrightarrow> rpr A (P i)"
  unfolding profile_def by simp

lemma profile_non_empty: "profile A Is P \<Longrightarrow> Is \<noteq> {}"
  unfolding profile_def by simp

(*<*)
end
(*>*)


theory LeibnizAlternative
imports Main
begin
typedecl μ --"things in the world"
consts moving :: "μ⇒bool"
consts moves :: "μ⇒μ⇒bool"(infix "moves"52)

consts isMoved ::"μ⇒bool"
consts body :: "μ⇒bool"

consts isPartOf :: "μ⇒μ⇒bool"(infix "isPartOf"52)
consts hasInfiniteParts :: "μ⇒bool"

abbreviation movesTheInfinite :: "μ⇒bool" where
"movesTheInfinite x ≡ ∀y.(hasInfiniteParts y ∧ x moves y)"

text "Leibniz writes: **Infinite power is an original capacity [potentia] to move the infinite. For
 power is the same as original capacity; hence we say that secondary causes operate by virtue[virtus]
 of the primary**"

text "comment: From this definition of infinite power we can infer infinite power is the capacity to
 move the infinite which belongs to some incorporeal "

abbreviation infinitePower :: "μ⇒bool" where
"infinitePower x ≡ movesTheInfinite x"

abbreviation substance :: "μ⇒bool" where
"substance x ≡ moving x ∨ isMoved x"

abbreviation incorporeal :: "μ⇒bool" where
"incorporeal x ≡ ¬body x"

abbreviation God :: "μ⇒bool" where
"God x ≡ incorporeal x ∧ substance x ∧ infinitePower x"

text "comment: The following axiom seems to be a reasonable interpretation of Leibniz´s notion of infinity."

axiomatization where Inf: "hasInfiniteParts y ⟹ x moves y ⟹ movesTheInfinite x"

text "Leibniz's Postulate: **Any number of things whatever maybe taken simultaneously and yet be
 treated as one whole. If anyone makes bold to deny this, I will prove it. The concept of parts is
 this: Given a plurality of beings all of which are understood to have something in common; then,
 since it is inconvenient or impossible to enumerate all of them every time, one name is thought of
 which takes the place of all the parts in our reasoning, to make the expression shorter. This is
 called the whole. But in any number of given things whatever, even infinite, we can understand what
 is true of all, since we can enumerate them all individually, at least in an infinite time. It is
 therefore permissible to use one name in our reasoning in place of all, and that will itself be a whole.**"

axiomatization where Postulate_a: "∃P. ∀x.∀y. (P x ∧ P y)⟹∃w.∀x.∀y.(x isPartOf w ∧ y isPartOf w)"

text "Leibniz Axioms are interpreted in a straight forward manner"

axiomatization where Axiom1: "isMoved x ⟷ (∃y.(y moves x))"
axiomatization where Axiom2: "∀x.(moving x ∧ body x)⟶ isMoved x"
axiomatization where Axiom3: "∀y.(∀x.(x isPartOf y)∧(isMoved x)⟶ isMoved y)"
axiomatization where Axiom4: "∀x.((body x) ⟶ (hasInfiniteParts x))"
axiomatization where Observation: "∃x.(body x ∧ moving x)"

lemma "∃x. God x" nitpick[user_axioms,verbose] text"(Nitpick found a counterexample)"
  oops

text "However, These are not enough to get to the conclusion Leibniz wants"

text "comment: To model Leibniz's argument as closely as possible (and to make the argument sound)
 a couple of new axioms are introduced that are plausible in the context of Leibniz argument."

text "comment: First it can be understood easily, if something has infinite parts and yet is a part of
 something else, then it has infinite parts too"

axiomatization where InfinitePartsPart:"∀x.∀y.(((x isPartOf y)∧ hasInfiniteParts x)⟶ hasInfiniteParts y)"

text "comment: It is also indeed an axiom where body is the part of whole and the whole is moved,
 Leibniz clearly stated if the whole is moved we have definitely reached at some incorporeal so this
 can be stated"
axiomatization where NoPartMoves : "body x ∧ x isPartOf y ∧ isMoved y ⟷ ¬(x moves y)"

text"Leibniz writes: **I call substance whatever moves or is moved.** comment: Now finally, we have
 to prove that God is a substance. In this alternative of Leibniz's cosmological proof, we interpreted
 substance as either moving, or is moved. But we can not say God is moved because if that was the case,
 then who moves the God?, Since God has the infinite Power to move the infinite we can infer God can
 move itself or God is moving."

axiomatization where InfiniteMoves: "infinitePower x ⟶ moving x"

lemma God:"∃x. God x"
proof-
  from Observation have "∃A. (body A ∧ moving A)" by simp
  then obtain A where obtA: "(body A ∧ moving A)" by auto
  hence "∃y. y moves A" using Axiom1 Axiom2 by auto
  from this have "hasInfiniteParts A" using Axiom4 obtA by auto
  from this have "isMoved A" using ‹∃y. y moves A› using Axiom1 by blast
  hence "∃y. infinitePower y" using ‹∃y. y moves A› ‹hasInfiniteParts A› Inf by blast
  from this have "∃y. infinitePower y ∧ moving y" using InfiniteMoves by blast
  then obtain y where obty:"infinitePower y ∧ moving y" by auto
  from this have "substance y ∧ infinitePower y" by auto
  then have "incorporeal y ∨ body y" by auto
  {
  assume "incorporeal y"
  hence "God y" by (simp add: ‹substance y ∧ infinitePower y›)
  hence "∃x. God x" by auto}

  moreover {
    assume B: "body y"
    have "moving y" using obty by (rule conjunct2)
    hence "isMoved y" using  Axiom2 ‹body y› by auto
    have "isMoved A" using Axiom1 ‹∃y. y moves A› by auto
    hence "isMoved A ∧ isMoved y" using ‹isMoved y› by (rule conjI)
    {
      assume "¬(∃x. God x)"
        from obty B have "isMoved A ∧ isMoved y" using ‹isMoved A ∧ isMoved y› by auto
        from this have "∃C.(isMoved A ∧isMoved y)⟷(A isPartOf C ∧ y isPartOf C)" using Postulate_a by auto
        then obtain C where obtC1: "(isMoved A ∧isMoved y)⟷(A isPartOf C ∧ y isPartOf C)" by auto
        hence "(A isPartOf C ∧ y isPartOf C)"using ‹isMoved A ∧ isMoved y› by auto note this
        from this have "A isPartOf C ∧ y isPartOf C" using ‹isMoved A ∧ isMoved y› obtC1 by auto
        from this have "(A isPartOf C ∧ y isPartOf C)∧(isMoved A ∧ isMoved y) " using ‹isMoved A ∧ isMoved y› by (rule conjI)
        from this have "A isPartOf C" by auto
        have "isMoved A" using ‹isMoved A ∧ isMoved y› by (rule conjunct1)
        have "A isPartOf C ∧ isMoved A" using ‹A isPartOf C› ‹isMoved A› by (rule conjI)
        from this have " isMoved C" using Axiom3 by auto
        from this have " ∃G. G moves C" using Axiom1 by simp
        from this obtain G where " G moves C " by auto
        have "body y" using ‹body y› by auto
        have "y isPartOf C" using ‹A isPartOf C ∧ y isPartOf C› by (rule conjunct2)
        have "hasInfiniteParts y" using ‹body y› Axiom4 by blast
        from this have "hasInfiniteParts C" using ‹y isPartOf C› InfinitePartsPart by auto
        from this have "infinitePower G" using ‹G moves C› Inf by blast
        from this have "substance G" using InfiniteMoves by auto
        have "incorporeal G" using B ‹(A isPartOf C ∧ y isPartOf C) ∧ isMoved A ∧ isMoved y› ‹isMoved C› NoPartMoves obty by blast
        hence "God G" using ‹substance G› ‹infinitePower G› by blast
        hence "False" using ‹¬(∃x. God x)› by blast
      }
      hence "∃x.(God x)" by blast}
    ultimately show "∃x. (God x)" by auto
  qed

end


(*  Title:      HOL/Algebra/FiniteProduct.thy
    Author:     Clemens Ballarin, started 19 November 2002

This file is largely based on HOL/Finite_Set.thy.
*)

theory FiniteProduct
imports Group
begin

subsection \<open>Product Operator for Commutative Monoids\<close>

subsubsection \<open>Inductive Definition of a Relation for Products over Sets\<close>

text \<open>Instantiation of locale \<open>LC\<close> of theory \<open>Finite_Set\<close> is not
  possible, because here we have explicit typing rules like
  \<open>x \<in> carrier G\<close>.  We introduce an explicit argument for the domain
  \<open>D\<close>.\<close>

inductive_set
  foldSetD :: "['a set, 'b => 'a => 'a, 'a] => ('b set * 'a) set"
  for D :: "'a set" and f :: "'b => 'a => 'a" and e :: 'a
  where
    emptyI [intro]: "e \<in> D ==> ({}, e) \<in> foldSetD D f e"
  | insertI [intro]: "[| x ~: A; f x y \<in> D; (A, y) \<in> foldSetD D f e |] ==>
                      (insert x A, f x y) \<in> foldSetD D f e"

inductive_cases empty_foldSetDE [elim!]: "({}, x) \<in> foldSetD D f e"

definition
  foldD :: "['a set, 'b => 'a => 'a, 'a, 'b set] => 'a"
  where "foldD D f e A = (THE x. (A, x) \<in> foldSetD D f e)"

lemma foldSetD_closed:
  "[| (A, z) \<in> foldSetD D f e ; e \<in> D; !!x y. [| x \<in> A; y \<in> D |] ==> f x y \<in> D
      |] ==> z \<in> D"
  by (erule foldSetD.cases) auto

lemma Diff1_foldSetD:
  "[| (A - {x}, y) \<in> foldSetD D f e; x \<in> A; f x y \<in> D |] ==>
   (A, f x y) \<in> foldSetD D f e"
  apply (erule insert_Diff [THEN subst], rule foldSetD.intros)
    apply auto
  done

lemma foldSetD_imp_finite [simp]: "(A, x) \<in> foldSetD D f e ==> finite A"
  by (induct set: foldSetD) auto

lemma finite_imp_foldSetD:
  "[| finite A; e \<in> D; !!x y. [| x \<in> A; y \<in> D |] ==> f x y \<in> D |] ==>
   EX x. (A, x) \<in> foldSetD D f e"
proof (induct set: finite)
  case empty then show ?case by auto
next
  case (insert x F)
  then obtain y where y: "(F, y) \<in> foldSetD D f e" by auto
  with insert have "y \<in> D" by (auto dest: foldSetD_closed)
  with y and insert have "(insert x F, f x y) \<in> foldSetD D f e"
    by (intro foldSetD.intros) auto
  then show ?case ..
qed

text \<open>Left-Commutative Operations\<close>

locale LCD =
  fixes B :: "'b set"
  and D :: "'a set"
  and f :: "'b => 'a => 'a"    (infixl "\<cdot>" 70)
  assumes left_commute:
    "[| x \<in> B; y \<in> B; z \<in> D |] ==> x \<cdot> (y \<cdot> z) = y \<cdot> (x \<cdot> z)"
  and f_closed [simp, intro!]: "!!x y. [| x \<in> B; y \<in> D |] ==> f x y \<in> D"

lemma (in LCD) foldSetD_closed [dest]:
  "(A, z) \<in> foldSetD D f e ==> z \<in> D"
  by (erule foldSetD.cases) auto

lemma (in LCD) Diff1_foldSetD:
  "[| (A - {x}, y) \<in> foldSetD D f e; x \<in> A; A \<subseteq> B |] ==>
  (A, f x y) \<in> foldSetD D f e"
  apply (subgoal_tac "x \<in> B")
   prefer 2 apply fast
  apply (erule insert_Diff [THEN subst], rule foldSetD.intros)
    apply auto
  done

lemma (in LCD) foldSetD_imp_finite [simp]:
  "(A, x) \<in> foldSetD D f e ==> finite A"
  by (induct set: foldSetD) auto

lemma (in LCD) finite_imp_foldSetD:
  "[| finite A; A \<subseteq> B; e \<in> D |] ==> EX x. (A, x) \<in> foldSetD D f e"
proof (induct set: finite)
  case empty then show ?case by auto
next
  case (insert x F)
  then obtain y where y: "(F, y) \<in> foldSetD D f e" by auto
  with insert have "y \<in> D" by auto
  with y and insert have "(insert x F, f x y) \<in> foldSetD D f e"
    by (intro foldSetD.intros) auto
  then show ?case ..
qed

lemma (in LCD) foldSetD_determ_aux:
  "e \<in> D ==> \<forall>A x. A \<subseteq> B & card A < n --> (A, x) \<in> foldSetD D f e -->
    (\<forall>y. (A, y) \<in> foldSetD D f e --> y = x)"
  apply (induct n)
   apply (auto simp add: less_Suc_eq) (* slow *)
  apply (erule foldSetD.cases)
   apply blast
  apply (erule foldSetD.cases)
   apply blast
  apply clarify
  txt \<open>force simplification of \<open>card A < card (insert ...)\<close>.\<close>
  apply (erule rev_mp)
  apply (simp add: less_Suc_eq_le)
  apply (rule impI)
  apply (rename_tac xa Aa ya xb Ab yb, case_tac "xa = xb")
   apply (subgoal_tac "Aa = Ab")
    prefer 2 apply (blast elim!: equalityE)
   apply blast
  txt \<open>case @{prop "xa \<notin> xb"}.\<close>
  apply (subgoal_tac "Aa - {xb} = Ab - {xa} & xb \<in> Aa & xa \<in> Ab")
   prefer 2 apply (blast elim!: equalityE)
  apply clarify
  apply (subgoal_tac "Aa = insert xb Ab - {xa}")
   prefer 2 apply blast
  apply (subgoal_tac "card Aa \<le> card Ab")
   prefer 2
   apply (rule Suc_le_mono [THEN subst])
   apply (simp add: card_Suc_Diff1)
  apply (rule_tac A1 = "Aa - {xb}" in finite_imp_foldSetD [THEN exE])
     apply (blast intro: foldSetD_imp_finite)
    apply best
   apply assumption
  apply (frule (1) Diff1_foldSetD)
   apply best
  apply (subgoal_tac "ya = f xb x")
   prefer 2
   apply (subgoal_tac "Aa \<subseteq> B")
    prefer 2 apply best (* slow *)
   apply (blast del: equalityCE)
  apply (subgoal_tac "(Ab - {xa}, x) \<in> foldSetD D f e")
   prefer 2 apply simp
  apply (subgoal_tac "yb = f xa x")
   prefer 2
   apply (blast del: equalityCE dest: Diff1_foldSetD)
  apply (simp (no_asm_simp))
  apply (rule left_commute)
    apply assumption
   apply best (* slow *)
  apply best
  done

lemma (in LCD) foldSetD_determ:
  "[| (A, x) \<in> foldSetD D f e; (A, y) \<in> foldSetD D f e; e \<in> D; A \<subseteq> B |]
  ==> y = x"
  by (blast intro: foldSetD_determ_aux [rule_format])

lemma (in LCD) foldD_equality:
  "[| (A, y) \<in> foldSetD D f e; e \<in> D; A \<subseteq> B |] ==> foldD D f e A = y"
  by (unfold foldD_def) (blast intro: foldSetD_determ)

lemma foldD_empty [simp]:
  "e \<in> D ==> foldD D f e {} = e"
  by (unfold foldD_def) blast

lemma (in LCD) foldD_insert_aux:
  "[| x ~: A; x \<in> B; e \<in> D; A \<subseteq> B |] ==>
    ((insert x A, v) \<in> foldSetD D f e) =
    (EX y. (A, y) \<in> foldSetD D f e & v = f x y)"
  apply auto
  apply (rule_tac A1 = A in finite_imp_foldSetD [THEN exE])
     apply (fastforce dest: foldSetD_imp_finite)
    apply assumption
   apply assumption
  apply (blast intro: foldSetD_determ)
  done

lemma (in LCD) foldD_insert:
    "[| finite A; x ~: A; x \<in> B; e \<in> D; A \<subseteq> B |] ==>
     foldD D f e (insert x A) = f x (foldD D f e A)"
  apply (unfold foldD_def)
  apply (simp add: foldD_insert_aux)
  apply (rule the_equality)
   apply (auto intro: finite_imp_foldSetD
     cong add: conj_cong simp add: foldD_def [symmetric] foldD_equality)
  done

lemma (in LCD) foldD_closed [simp]:
  "[| finite A; e \<in> D; A \<subseteq> B |] ==> foldD D f e A \<in> D"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case insert then show ?case by (simp add: foldD_insert)
qed

lemma (in LCD) foldD_commute:
  "[| finite A; x \<in> B; e \<in> D; A \<subseteq> B |] ==>
   f x (foldD D f e A) = foldD D f (f x e) A"
  apply (induct set: finite)
   apply simp
  apply (auto simp add: left_commute foldD_insert)
  done

lemma Int_mono2:
  "[| A \<subseteq> C; B \<subseteq> C |] ==> A Int B \<subseteq> C"
  by blast

lemma (in LCD) foldD_nest_Un_Int:
  "[| finite A; finite C; e \<in> D; A \<subseteq> B; C \<subseteq> B |] ==>
   foldD D f (foldD D f e C) A = foldD D f (foldD D f e (A Int C)) (A Un C)"
  apply (induct set: finite)
   apply simp
  apply (simp add: foldD_insert foldD_commute Int_insert_left insert_absorb
    Int_mono2)
  done

lemma (in LCD) foldD_nest_Un_disjoint:
  "[| finite A; finite B; A Int B = {}; e \<in> D; A \<subseteq> B; C \<subseteq> B |]
    ==> foldD D f e (A Un B) = foldD D f (foldD D f e B) A"
  by (simp add: foldD_nest_Un_Int)

\<comment> \<open>Delete rules to do with \<open>foldSetD\<close> relation.\<close>

declare foldSetD_imp_finite [simp del]
  empty_foldSetDE [rule del]
  foldSetD.intros [rule del]
declare (in LCD)
  foldSetD_closed [rule del]

text \<open>Commutative Monoids\<close>

text \<open>
  We enter a more restrictive context, with \<open>f :: 'a => 'a => 'a\<close>
  instead of \<open>'b => 'a => 'a\<close>.
\<close>

locale ACeD =
  fixes D :: "'a set"
    and f :: "'a => 'a => 'a"    (infixl "\<cdot>" 70)
    and e :: 'a
  assumes ident [simp]: "x \<in> D ==> x \<cdot> e = x"
    and commute: "[| x \<in> D; y \<in> D |] ==> x \<cdot> y = y \<cdot> x"
    and assoc: "[| x \<in> D; y \<in> D; z \<in> D |] ==> (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
    and e_closed [simp]: "e \<in> D"
    and f_closed [simp]: "[| x \<in> D; y \<in> D |] ==> x \<cdot> y \<in> D"

lemma (in ACeD) left_commute:
  "[| x \<in> D; y \<in> D; z \<in> D |] ==> x \<cdot> (y \<cdot> z) = y \<cdot> (x \<cdot> z)"
proof -
  assume D: "x \<in> D" "y \<in> D" "z \<in> D"
  then have "x \<cdot> (y \<cdot> z) = (y \<cdot> z) \<cdot> x" by (simp add: commute)
  also from D have "... = y \<cdot> (z \<cdot> x)" by (simp add: assoc)
  also from D have "z \<cdot> x = x \<cdot> z" by (simp add: commute)
  finally show ?thesis .
qed

lemmas (in ACeD) AC = assoc commute left_commute

lemma (in ACeD) left_ident [simp]: "x \<in> D ==> e \<cdot> x = x"
proof -
  assume "x \<in> D"
  then have "x \<cdot> e = x" by (rule ident)
  with \<open>x \<in> D\<close> show ?thesis by (simp add: commute)
qed

lemma (in ACeD) foldD_Un_Int:
  "[| finite A; finite B; A \<subseteq> D; B \<subseteq> D |] ==>
    foldD D f e A \<cdot> foldD D f e B =
    foldD D f e (A Un B) \<cdot> foldD D f e (A Int B)"
  apply (induct set: finite)
   apply (simp add: left_commute LCD.foldD_closed [OF LCD.intro [of D]])
  apply (simp add: AC insert_absorb Int_insert_left
    LCD.foldD_insert [OF LCD.intro [of D]]
    LCD.foldD_closed [OF LCD.intro [of D]]
    Int_mono2)
  done

lemma (in ACeD) foldD_Un_disjoint:
  "[| finite A; finite B; A Int B = {}; A \<subseteq> D; B \<subseteq> D |] ==>
    foldD D f e (A Un B) = foldD D f e A \<cdot> foldD D f e B"
  by (simp add: foldD_Un_Int
    left_commute LCD.foldD_closed [OF LCD.intro [of D]])

subsubsection \<open>Products over Finite Sets\<close>

definition
  finprod :: "[('b, 'm) monoid_scheme, 'a => 'b, 'a set] => 'b"
  where "finprod G f A =
   (if finite A
    then foldD (carrier G) (mult G o f) \<one>\<^bsub>G\<^esub> A
    else \<one>\<^bsub>G\<^esub>)"

syntax
  "_finprod" :: "index => idt => 'a set => 'b => 'b"
      ("(3\<Otimes>__\<in>_. _)" [1000, 0, 51, 10] 10)
translations
  "\<Otimes>\<^bsub>G\<^esub>i\<in>A. b" \<rightleftharpoons> "CONST finprod G (%i. b) A"
  \<comment> \<open>Beware of argument permutation!\<close>

lemma (in comm_monoid) finprod_empty [simp]:
  "finprod G f {} = \<one>"
  by (simp add: finprod_def)

lemma (in comm_monoid) finprod_infinite[simp]:
  "\<not> finite A \<Longrightarrow> finprod G f A = \<one>"
  by (simp add: finprod_def)

declare funcsetI [intro]
  funcset_mem [dest]

context comm_monoid begin

lemma finprod_insert [simp]:
  "[| finite F; a \<notin> F; f \<in> F \<rightarrow> carrier G; f a \<in> carrier G |] ==>
   finprod G f (insert a F) = f a \<otimes> finprod G f F"
  apply (rule trans)
   apply (simp add: finprod_def)
  apply (rule trans)
   apply (rule LCD.foldD_insert [OF LCD.intro [of "insert a F"]])
         apply simp
         apply (rule m_lcomm)
           apply fast
          apply fast
         apply assumption
        apply fastforce
       apply simp+
   apply fast
  apply (auto simp add: finprod_def)
  done

lemma finprod_one [simp]: "(\<Otimes>i\<in>A. \<one>) = \<one>"
proof (induct A rule: infinite_finite_induct)
  case empty show ?case by simp
next
  case (insert a A)
  have "(%i. \<one>) \<in> A \<rightarrow> carrier G" by auto
  with insert show ?case by simp
qed simp

lemma finprod_closed [simp]:
  fixes A
  assumes f: "f \<in> A \<rightarrow> carrier G"
  shows "finprod G f A \<in> carrier G"
using f
proof (induct A rule: infinite_finite_induct)
  case empty show ?case by simp
next
  case (insert a A)
  then have a: "f a \<in> carrier G" by fast
  from insert have A: "f \<in> A \<rightarrow> carrier G" by fast
  from insert A a show ?case by simp
qed simp

lemma funcset_Int_left [simp, intro]:
  "[| f \<in> A \<rightarrow> C; f \<in> B \<rightarrow> C |] ==> f \<in> A Int B \<rightarrow> C"
  by fast

lemma funcset_Un_left [iff]:
  "(f \<in> A Un B \<rightarrow> C) = (f \<in> A \<rightarrow> C & f \<in> B \<rightarrow> C)"
  by fast

lemma finprod_Un_Int:
  "[| finite A; finite B; g \<in> A \<rightarrow> carrier G; g \<in> B \<rightarrow> carrier G |] ==>
     finprod G g (A Un B) \<otimes> finprod G g (A Int B) =
     finprod G g A \<otimes> finprod G g B"
\<comment> \<open>The reversed orientation looks more natural, but LOOPS as a simprule!\<close>
proof (induct set: finite)
  case empty then show ?case by simp
next
  case (insert a A)
  then have a: "g a \<in> carrier G" by fast
  from insert have A: "g \<in> A \<rightarrow> carrier G" by fast
  from insert A a show ?case
    by (simp add: m_ac Int_insert_left insert_absorb Int_mono2)
qed

lemma finprod_Un_disjoint:
  "[| finite A; finite B; A Int B = {};
      g \<in> A \<rightarrow> carrier G; g \<in> B \<rightarrow> carrier G |]
   ==> finprod G g (A Un B) = finprod G g A \<otimes> finprod G g B"
  apply (subst finprod_Un_Int [symmetric])
      apply auto
  done

lemma finprod_multf:
  "[| f \<in> A \<rightarrow> carrier G; g \<in> A \<rightarrow> carrier G |] ==>
   finprod G (%x. f x \<otimes> g x) A = (finprod G f A \<otimes> finprod G g A)"
proof (induct A rule: infinite_finite_induct)
  case empty show ?case by simp
next
  case (insert a A) then
  have fA: "f \<in> A \<rightarrow> carrier G" by fast
  from insert have fa: "f a \<in> carrier G" by fast
  from insert have gA: "g \<in> A \<rightarrow> carrier G" by fast
  from insert have ga: "g a \<in> carrier G" by fast
  from insert have fgA: "(%x. f x \<otimes> g x) \<in> A \<rightarrow> carrier G"
    by (simp add: Pi_def)
  show ?case
    by (simp add: insert fA fa gA ga fgA m_ac)
qed simp

lemma finprod_cong':
  "[| A = B; g \<in> B \<rightarrow> carrier G;
      !!i. i \<in> B ==> f i = g i |] ==> finprod G f A = finprod G g B"
proof -
  assume prems: "A = B" "g \<in> B \<rightarrow> carrier G"
    "!!i. i \<in> B ==> f i = g i"
  show ?thesis
  proof (cases "finite B")
    case True
    then have "!!A. [| A = B; g \<in> B \<rightarrow> carrier G;
      !!i. i \<in> B ==> f i = g i |] ==> finprod G f A = finprod G g B"
    proof induct
      case empty thus ?case by simp
    next
      case (insert x B)
      then have "finprod G f A = finprod G f (insert x B)" by simp
      also from insert have "... = f x \<otimes> finprod G f B"
      proof (intro finprod_insert)
        show "finite B" by fact
      next
        show "x ~: B" by fact
      next
        assume "x ~: B" "!!i. i \<in> insert x B \<Longrightarrow> f i = g i"
          "g \<in> insert x B \<rightarrow> carrier G"
        thus "f \<in> B \<rightarrow> carrier G" by fastforce
      next
        assume "x ~: B" "!!i. i \<in> insert x B \<Longrightarrow> f i = g i"
          "g \<in> insert x B \<rightarrow> carrier G"
        thus "f x \<in> carrier G" by fastforce
      qed
      also from insert have "... = g x \<otimes> finprod G g B" by fastforce
      also from insert have "... = finprod G g (insert x B)"
      by (intro finprod_insert [THEN sym]) auto
      finally show ?case .
    qed
    with prems show ?thesis by simp
  next
    case False with prems show ?thesis by simp
  qed
qed

lemma finprod_cong:
  "[| A = B; f \<in> B \<rightarrow> carrier G = True;
      !!i. i \<in> B =simp=> f i = g i |] ==> finprod G f A = finprod G g B"
  (* This order of prems is slightly faster (3%) than the last two swapped. *)
  by (rule finprod_cong') (auto simp add: simp_implies_def)

text \<open>Usually, if this rule causes a failed congruence proof error,
  the reason is that the premise \<open>g \<in> B \<rightarrow> carrier G\<close> cannot be shown.
  Adding @{thm [source] Pi_def} to the simpset is often useful.
  For this reason, @{thm [source] finprod_cong}
  is not added to the simpset by default.
\<close>

end

declare funcsetI [rule del]
  funcset_mem [rule del]

context comm_monoid begin

lemma finprod_0 [simp]:
  "f \<in> {0::nat} \<rightarrow> carrier G ==> finprod G f {..0} = f 0"
by (simp add: Pi_def)

lemma finprod_Suc [simp]:
  "f \<in> {..Suc n} \<rightarrow> carrier G ==>
   finprod G f {..Suc n} = (f (Suc n) \<otimes> finprod G f {..n})"
by (simp add: Pi_def atMost_Suc)

lemma finprod_Suc2:
  "f \<in> {..Suc n} \<rightarrow> carrier G ==>
   finprod G f {..Suc n} = (finprod G (%i. f (Suc i)) {..n} \<otimes> f 0)"
proof (induct n)
  case 0 thus ?case by (simp add: Pi_def)
next
  case Suc thus ?case by (simp add: m_assoc Pi_def)
qed

lemma finprod_mult [simp]:
  "[| f \<in> {..n} \<rightarrow> carrier G; g \<in> {..n} \<rightarrow> carrier G |] ==>
     finprod G (%i. f i \<otimes> g i) {..n::nat} =
     finprod G f {..n} \<otimes> finprod G g {..n}"
  by (induct n) (simp_all add: m_ac Pi_def)

(* The following two were contributed by Jeremy Avigad. *)

lemma finprod_reindex:
  "f : (h ` A) \<rightarrow> carrier G \<Longrightarrow>
        inj_on h A ==> finprod G f (h ` A) = finprod G (%x. f (h x)) A"
proof (induct A rule: infinite_finite_induct)
  case (infinite A)
  hence "\<not> finite (h ` A)"
    using finite_imageD by blast
  with \<open>\<not> finite A\<close> show ?case by simp
qed (auto simp add: Pi_def)

lemma finprod_const:
  assumes a [simp]: "a : carrier G"
    shows "finprod G (%x. a) A = a (^) card A"
proof (induct A rule: infinite_finite_induct)
  case (insert b A)
  show ?case
  proof (subst finprod_insert[OF insert(1-2)])
    show "a \<otimes> (\<Otimes>x\<in>A. a) = a (^) card (insert b A)"
      by (insert insert, auto, subst m_comm, auto)
  qed auto
qed auto

(* The following lemma was contributed by Jesus Aransay. *)

lemma finprod_singleton:
  assumes i_in_A: "i \<in> A" and fin_A: "finite A" and f_Pi: "f \<in> A \<rightarrow> carrier G"
  shows "(\<Otimes>j\<in>A. if i = j then f j else \<one>) = f i"
  using i_in_A finprod_insert [of "A - {i}" i "(\<lambda>j. if i = j then f j else \<one>)"]
    fin_A f_Pi finprod_one [of "A - {i}"]
    finprod_cong [of "A - {i}" "A - {i}" "(\<lambda>j. if i = j then f j else \<one>)" "(\<lambda>i. \<one>)"]
  unfolding Pi_def simp_implies_def by (force simp add: insert_absorb)

end

end


(* Formalisation of weakening using locally nameless    *)
(* terms; the nominal infrastructure can also derive    *)
(* strong induction principles for such representations *)
(*                                                      *)
(* Authors: Christian Urban and Randy Pollack           *)
theory LocalWeakening
  imports "HOL-Nominal.Nominal"
begin

atom_decl name

text \<open>
  Curry-style lambda terms in locally nameless
  representation without any binders
\<close>
nominal_datatype llam =
    lPar "name"
  | lVar "nat"
  | lApp "llam" "llam"
  | lLam "llam"

text \<open>definition of vsub - at the moment a bit cumbersome\<close>

lemma llam_cases:
  "(\<exists>a. t = lPar a) \<or> (\<exists>n. t = lVar n) \<or> (\<exists>t1 t2. t = lApp t1 t2) \<or>
   (\<exists>t1. t = lLam t1)"
by (induct t rule: llam.induct)
   (auto simp add: llam.inject)

nominal_primrec
  llam_size :: "llam \<Rightarrow> nat"
where
  "llam_size (lPar a) = 1"
| "llam_size (lVar n) = 1"
| "llam_size (lApp t1 t2) = 1 + (llam_size t1) + (llam_size t2)"
| "llam_size (lLam t) = 1 + (llam_size t)"
by (rule TrueI)+

function
  vsub :: "llam \<Rightarrow> nat \<Rightarrow> llam \<Rightarrow> llam"
where
   vsub_lPar: "vsub (lPar p) x s = lPar p"
 | vsub_lVar: "vsub (lVar n) x s = (if n < x then (lVar n)
                      else (if n = x then s else (lVar (n - 1))))"
 | vsub_lApp: "vsub (lApp t u) x s = (lApp (vsub t x s) (vsub u x s))"
 | vsub_lLam: "vsub (lLam t) x s = (lLam (vsub t (x + 1) s))"
using llam_cases
apply(auto simp add: llam.inject)
apply(rotate_tac 4)
apply(drule_tac x="a" in meta_spec)
apply(blast)
done
termination by (relation "measure (llam_size \<circ> fst)") auto

lemma vsub_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(vsub t n s) = vsub (pi\<bullet>t) (pi\<bullet>n) (pi\<bullet>s)"
by (induct t arbitrary: n rule: llam.induct)
   (simp_all add: perm_nat_def)

definition freshen :: "llam \<Rightarrow> name \<Rightarrow> llam" where
  "freshen t p \<equiv> vsub t 0 (lPar p)"

lemma freshen_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(freshen t p) = freshen (pi\<bullet>t) (pi\<bullet>p)"
by (simp add: vsub_eqvt freshen_def perm_nat_def)

text \<open>types\<close>

nominal_datatype ty =
    TVar "nat"
  | TArr "ty" "ty" (infix "\<rightarrow>" 200)

lemma ty_fresh[simp]:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (induct T rule: ty.induct)
   (simp_all add: fresh_nat)

text \<open>valid contexts\<close>

type_synonym cxt = "(name\<times>ty) list"

inductive
  valid :: "cxt \<Rightarrow> bool"
where
  v1[intro]: "valid []"
| v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,T)#\<Gamma>)"

equivariance valid

lemma v2_elim:
  assumes a: "valid ((a,T)#\<Gamma>)"
  shows   "a\<sharp>\<Gamma> \<and> valid \<Gamma>"
using a by (cases) (auto)

text \<open>"weak" typing relation\<close>

inductive
  typing :: "cxt\<Rightarrow>llam\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [60,60,60] 60)
where
  t_lPar[intro]: "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> lPar x : T"
| t_lApp[intro]: "\<lbrakk>\<Gamma> \<turnstile> t1 : T1\<rightarrow>T2; \<Gamma> \<turnstile> t2 : T1\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> lApp t1 t2 : T2"
| t_lLam[intro]: "\<lbrakk>x\<sharp>t; (x,T1)#\<Gamma> \<turnstile> freshen t x : T2\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> lLam t : T1\<rightarrow>T2"

equivariance typing

lemma typing_implies_valid:
  assumes a: "\<Gamma> \<turnstile> t : T"
  shows "valid \<Gamma>"
using a by (induct) (auto dest: v2_elim)

text \<open>
  we have to explicitly state that nominal_inductive should strengthen
  over the variable x (since x is not a binder)
\<close>
nominal_inductive typing
  avoids t_lLam: x
  by (auto simp add: fresh_prod dest: v2_elim typing_implies_valid)

text \<open>strong induction principle for typing\<close>
thm typing.strong_induct

text \<open>sub-contexts\<close>

abbreviation
  "sub_context" :: "cxt \<Rightarrow> cxt \<Rightarrow> bool" ("_ \<subseteq> _" [60,60] 60)
where
  "\<Gamma>1 \<subseteq> \<Gamma>2 \<equiv> \<forall>x T. (x,T)\<in>set \<Gamma>1 \<longrightarrow> (x,T)\<in>set \<Gamma>2"

lemma weakening_almost_automatic:
  fixes \<Gamma>1 \<Gamma>2 :: cxt
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "\<Gamma>1 \<subseteq> \<Gamma>2"
  and     c: "valid \<Gamma>2"
shows "\<Gamma>2 \<turnstile> t : T"
using a b c
apply(nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
apply(auto)
apply(drule_tac x="(x,T1)#\<Gamma>2" in meta_spec)
apply(auto intro!: t_lLam)
done

lemma weakening_in_more_detail:
  fixes \<Gamma>1 \<Gamma>2 :: cxt
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "\<Gamma>1 \<subseteq> \<Gamma>2"
  and     c: "valid \<Gamma>2"
shows "\<Gamma>2 \<turnstile> t : T"
using a b c
proof(nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
  case (t_lPar \<Gamma>1 x T \<Gamma>2)  (* variable case *)
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  moreover
  have "valid \<Gamma>2" by fact
  moreover
  have "(x,T)\<in> set \<Gamma>1" by fact
  ultimately show "\<Gamma>2 \<turnstile> lPar x : T" by auto
next
  case (t_lLam x t T1 \<Gamma>1 T2 \<Gamma>2) (* lambda case *)
  have vc: "x\<sharp>\<Gamma>2" "x\<sharp>t" by fact+  (* variable convention *)
  have ih: "\<lbrakk>(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#\<Gamma>2; valid ((x,T1)#\<Gamma>2)\<rbrakk> \<Longrightarrow> (x,T1)#\<Gamma>2 \<turnstile> freshen t x : T2" by fact
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  then have "(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#\<Gamma>2" by simp
  moreover
  have "valid \<Gamma>2" by fact
  then have "valid ((x,T1)#\<Gamma>2)" using vc by (simp add: v2)
  ultimately have "(x,T1)#\<Gamma>2 \<turnstile> freshen t x : T2" using ih by simp
  with vc show "\<Gamma>2 \<turnstile> lLam t : T1\<rightarrow>T2" by auto
next
  case (t_lApp \<Gamma>1 t1 T1 T2 t2 \<Gamma>2)
  then show "\<Gamma>2 \<turnstile> lApp t1 t2 : T2" by auto
qed

end


(*  Title:      HOL/Library/Quotient_Product.thy
    Author:     Cezary Kaliszyk and Christian Urban
*)

section \<open>Quotient infrastructure for the product type\<close>

theory Quotient_Product
imports Quotient_Syntax
begin

subsection \<open>Rules for the Quotient package\<close>

lemma map_prod_id [id_simps]:
  shows "map_prod id id = id"
  by (simp add: fun_eq_iff)

lemma rel_prod_eq [id_simps]:
  shows "rel_prod (=) (=) = (=)"
  by (simp add: fun_eq_iff)

lemma prod_equivp [quot_equiv]:
  assumes "equivp R1"
  assumes "equivp R2"
  shows "equivp (rel_prod R1 R2)"
  using assms by (auto intro!: equivpI reflpI sympI transpI elim!: equivpE elim: reflpE sympE transpE)

lemma prod_quotient [quot_thm]:
  assumes "Quotient3 R1 Abs1 Rep1"
  assumes "Quotient3 R2 Abs2 Rep2"
  shows "Quotient3 (rel_prod R1 R2) (map_prod Abs1 Abs2) (map_prod Rep1 Rep2)"
  apply (rule Quotient3I)
  apply (simp add: map_prod.compositionality comp_def map_prod.identity
     Quotient3_abs_rep [OF assms(1)] Quotient3_abs_rep [OF assms(2)])
  apply (simp add: split_paired_all Quotient3_rel_rep [OF assms(1)] Quotient3_rel_rep [OF assms(2)])
  using Quotient3_rel [OF assms(1)] Quotient3_rel [OF assms(2)]
  apply (auto simp add: split_paired_all)
  done

declare [[mapQ3 prod = (rel_prod, prod_quotient)]]

lemma Pair_rsp [quot_respect]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(R1 ===> R2 ===> rel_prod R1 R2) Pair Pair"
  by (rule Pair_transfer)

lemma Pair_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(Rep1 ---> Rep2 ---> (map_prod Abs1 Abs2)) Pair = Pair"
  apply(simp add: fun_eq_iff)
  apply(simp add: Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])
  done

lemma fst_rsp [quot_respect]:
  assumes "Quotient3 R1 Abs1 Rep1"
  assumes "Quotient3 R2 Abs2 Rep2"
  shows "(rel_prod R1 R2 ===> R1) fst fst"
  by auto

lemma fst_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(map_prod Rep1 Rep2 ---> Abs1) fst = fst"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1])

lemma snd_rsp [quot_respect]:
  assumes "Quotient3 R1 Abs1 Rep1"
  assumes "Quotient3 R2 Abs2 Rep2"
  shows "(rel_prod R1 R2 ===> R2) snd snd"
  by auto

lemma snd_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(map_prod Rep1 Rep2 ---> Abs2) snd = snd"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q2])

lemma case_prod_rsp [quot_respect]:
  shows "((R1 ===> R2 ===> (=)) ===> (rel_prod R1 R2) ===> (=)) case_prod case_prod"
  by (rule case_prod_transfer)

lemma split_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "(((Abs1 ---> Abs2 ---> id) ---> map_prod Rep1 Rep2 ---> id) case_prod) = case_prod"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])

lemma [quot_respect]:
  shows "((R2 ===> R2 ===> (=)) ===> (R1 ===> R1 ===> (=)) ===>
  rel_prod R2 R1 ===> rel_prod R2 R1 ===> (=)) rel_prod rel_prod"
  by (rule prod.rel_transfer)

lemma [quot_preserve]:
  assumes q1: "Quotient3 R1 abs1 rep1"
  and     q2: "Quotient3 R2 abs2 rep2"
  shows "((abs1 ---> abs1 ---> id) ---> (abs2 ---> abs2 ---> id) --->
  map_prod rep1 rep2 ---> map_prod rep1 rep2 ---> id) rel_prod = rel_prod"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])

lemma [quot_preserve]:
  shows"(rel_prod ((rep1 ---> rep1 ---> id) R1) ((rep2 ---> rep2 ---> id) R2)
  (l1, l2) (r1, r2)) = (R1 (rep1 l1) (rep1 r1) \<and> R2 (rep2 l2) (rep2 r2))"
  by simp

declare prod.inject[quot_preserve]

end


(*  Title:       variants/a_norreqid/Seq_Invariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
*)

section "Invariant proofs on individual processes"

theory A_Seq_Invariants
imports AWN.Invariants A_Aodv A_Aodv_Data A_Aodv_Predicates A_Fresher

begin

text \<open>
  The proposition numbers are taken from the December 2013 version of
  the Fehnker et al technical report.
\<close>

text \<open>Proposition 7.2\<close>

lemma sequence_number_increases:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), _, (\<xi>', _)). sn \<xi> \<le> sn \<xi>')"
  by inv_cterms

lemma sequence_number_one_or_bigger:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _). 1 \<le> sn \<xi>)"
  by (rule onll_step_to_invariantI [OF sequence_number_increases])
     (auto simp: \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def)

text \<open>We can get rid of the onl/onll if desired...\<close>

lemma sequence_number_increases':
  "paodv i \<TTurnstile>\<^sub>A (\<lambda>((\<xi>, _), _, (\<xi>', _)). sn \<xi> \<le> sn \<xi>')"
  by (rule step_invariant_weakenE [OF sequence_number_increases]) (auto dest!: onllD)

lemma sequence_number_one_or_bigger':
  "paodv i \<TTurnstile> (\<lambda>(\<xi>, _). 1 \<le> sn \<xi>)"
  by (rule invariant_weakenE [OF sequence_number_one_or_bigger]) auto

lemma sip_in_kD:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). l \<in> ({PAodv-:7} \<union> {PAodv-:5} \<union> {PRrep-:0..PRrep-:1}
                                     \<union> {PRreq-:0..PRreq-:3}) \<longrightarrow> sip \<xi> \<in> kD (rt \<xi>))"
  by inv_cterms

lemma rrep_1_update_changes:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l = PRrep-:1 \<longrightarrow>
                        rt \<xi> \<noteq> update (rt \<xi>) (dip \<xi>) (dsn \<xi>, kno, val, hops \<xi> + 1, sip \<xi>, {})))"
  by inv_cterms

lemma addpreRT_partly_welldefined:
  "paodv i \<TTurnstile>
     onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l \<in> {PRreq-:16..PRreq-:18} \<union> {PRrep-:2..PRrep-:6} \<longrightarrow> dip \<xi> \<in> kD (rt \<xi>))
                      \<and> (l \<in> {PRreq-:3..PRreq-:17} \<longrightarrow> oip \<xi> \<in> kD (rt \<xi>)))"
  by inv_cterms

text \<open>Proposition 7.38\<close>

lemma includes_nhip:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). \<forall>dip\<in>kD(rt \<xi>). the (nhop (rt \<xi>) dip)\<in>kD(rt \<xi>))"
  proof -
    { fix ip and \<xi> \<xi>' :: state
      assume "\<forall>dip\<in>kD (rt \<xi>). the (nhop (rt \<xi>) dip) \<in> kD (rt \<xi>)"
         and "\<xi>' = \<xi>\<lparr>rt := update (rt \<xi>) ip (0, unk, val, Suc 0, ip, {})\<rparr>"
      hence "\<forall>dip\<in>kD (rt \<xi>).
               the (nhop (update (rt \<xi>) ip (0, unk, val, Suc 0, ip, {})) dip) = ip
             \<or> the (nhop (update (rt \<xi>) ip (0, unk, val, Suc 0, ip, {})) dip) \<in> kD (rt \<xi>)"
        by clarsimp (metis nhop_update_unk_val update_another)
    } note one_hop = this
    {  fix ip sip sn hops and \<xi> \<xi>' :: state
       assume "\<forall>dip\<in>kD (rt \<xi>). the (nhop (rt \<xi>) dip) \<in> kD (rt \<xi>)"
          and "\<xi>' = \<xi>\<lparr>rt := update (rt \<xi>) ip (sn, kno, val, Suc hops, sip, {})\<rparr>"
          and "sip \<in> kD (rt \<xi>)"
       hence "(the (nhop (update (rt \<xi>) ip (sn, kno, val, Suc hops, sip, {})) ip) = ip
                 \<or> the (nhop (update (rt \<xi>) ip (sn, kno, val, Suc hops, sip, {})) ip) \<in> kD (rt \<xi>))
               \<and> (\<forall>dip\<in>kD (rt \<xi>).
                    the (nhop (update (rt \<xi>) ip (sn, kno, val, Suc hops, sip, {})) dip) = ip
                    \<or> the (nhop (update (rt \<xi>) ip (sn, kno, val, Suc hops, sip, {})) dip) \<in> kD (rt \<xi>))"
         by (metis kD_update_unchanged nhop_update_changed update_another)
    } note nhip_is_sip = this
    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf sip_in_kD]
                              onl_invariant_sterms [OF aodv_wf addpreRT_partly_welldefined]
                       solve: one_hop nhip_is_sip)
  qed

text \<open>Proposition 7.22: needed in Proposition 7.4\<close>

lemma addpreRT_welldefined:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l \<in> {PRreq-:16..PRreq-:18} \<longrightarrow> dip \<xi> \<in> kD (rt \<xi>)) \<and>
                               (l = PRreq-:17 \<longrightarrow> oip \<xi> \<in> kD (rt \<xi>)) \<and>
                               (l = PRrep-:5  \<longrightarrow> dip \<xi> \<in> kD (rt \<xi>)) \<and>
                               (l = PRrep-:6  \<longrightarrow> (the (nhop (rt \<xi>) (dip \<xi>))) \<in> kD (rt \<xi>)))"
  (is "_ \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V ?P")
  unfolding invariant_def
  proof
    fix s
    assume "s \<in> reachable (paodv i) TT"
    then obtain \<xi> p where "s = (\<xi>, p)"
                      and "(\<xi>, p) \<in> reachable (paodv i) TT"
      by (metis prod.exhaust)
    have "onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V ?P (\<xi>, p)"
    proof (rule onlI)
      fix l
      assume "l \<in> labels \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V p"
      with \<open>(\<xi>, p) \<in> reachable (paodv i) TT\<close>
        have I1: "l \<in> {PRreq-:16..PRreq-:18} \<longrightarrow> dip \<xi> \<in> kD(rt \<xi>)"
         and I2: "l = PRreq-:17 \<longrightarrow> oip \<xi> \<in> kD(rt \<xi>)"
         and I3: "l \<in> {PRrep-:2..PRrep-:6}  \<longrightarrow> dip \<xi> \<in> kD(rt \<xi>)"
         by (auto dest!: invariantD [OF addpreRT_partly_welldefined])
      moreover from \<open>(\<xi>, p) \<in> reachable (paodv i) TT\<close> \<open>l \<in> labels \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V p\<close> and I3
        have "l = PRrep-:6  \<longrightarrow> (the (nhop (rt \<xi>) (dip \<xi>))) \<in> kD(rt \<xi>)"
          by (auto dest!: invariantD [OF includes_nhip])
      ultimately show "?P (\<xi>, l)"
        by simp
    qed
    with \<open>s = (\<xi>, p)\<close> show "onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V ?P s"
      by simp
  qed

text \<open>Proposition 7.4\<close>

lemma known_destinations_increase:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), _, (\<xi>', _)). kD (rt \<xi>) \<subseteq> kD (rt \<xi>'))"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf addpreRT_welldefined]
                 simp add: subset_insertI)

text \<open>Proposition 7.5\<close>

lemma rreqs_increase:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), _, (\<xi>', _)). rreqs \<xi> \<subseteq> rreqs \<xi>')"
  by (inv_cterms simp add: subset_insertI)

lemma dests_bigger_than_sqn:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). l \<in> {PAodv-:15..PAodv-:19}
                                 \<union> {PPkt-:7..PPkt-:11}
                                 \<union> {PRreq-:9..PRreq-:13}
                                 \<union> {PRreq-:21..PRreq-:25}
                                 \<union> {PRrep-:10..PRrep-:14}
                                 \<union> {PRerr-:1..PRerr-:5}
                         \<longrightarrow> (\<forall>ip\<in>dom(dests \<xi>). ip\<in>kD(rt \<xi>) \<and> sqn (rt \<xi>) ip \<le> the (dests \<xi> ip)))"
  proof -
    have sqninv:
      "\<And>dests rt rsn ip.
       \<lbrakk> \<forall>ip\<in>dom(dests). ip\<in>kD(rt) \<and> sqn rt ip \<le> the (dests ip); dests ip = Some rsn \<rbrakk>
        \<Longrightarrow> sqn (invalidate rt dests) ip \<le> rsn"
        by (rule sqn_invalidate_in_dests [THEN eq_imp_le], assumption) auto
    have indests:
      "\<And>dests rt rsn ip.
       \<lbrakk> \<forall>ip\<in>dom(dests). ip\<in>kD(rt) \<and> sqn rt ip \<le> the (dests ip); dests ip = Some rsn \<rbrakk>
        \<Longrightarrow> ip\<in>kD(rt) \<and> sqn rt ip \<le> rsn"
        by (metis domI option.sel)
    show ?thesis
      by inv_cterms
         (clarsimp split: if_split_asm option.split_asm
                   elim!: sqninv indests)+
  qed

text \<open>Proposition 7.6\<close>

lemma sqns_increase:
   "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), _, (\<xi>', _)). \<forall>ip. sqn (rt \<xi>) ip \<le> sqn (rt \<xi>') ip)"
  proof -
    { fix \<xi> :: state
      assume *: "\<forall>ip\<in>dom(dests \<xi>). ip \<in> kD (rt \<xi>) \<and> sqn (rt \<xi>) ip \<le> the (dests \<xi> ip)"
      have "\<forall>ip. sqn (rt \<xi>) ip \<le> sqn (invalidate (rt \<xi>) (dests \<xi>)) ip"
      proof
        fix ip
        from * have "ip\<notin>dom(dests \<xi>) \<or> sqn (rt \<xi>) ip \<le> the (dests \<xi> ip)" by simp
        thus "sqn (rt \<xi>) ip \<le> sqn (invalidate (rt \<xi>) (dests \<xi>)) ip"
          by (metis domI invalidate_sqn option.sel)
      qed
    } note solve_invalidate = this
    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf addpreRT_welldefined]
                              onl_invariant_sterms [OF aodv_wf dests_bigger_than_sqn]
                    simp add: solve_invalidate)
  qed

text \<open>Proposition 7.7\<close>

lemma ip_constant:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _). ip \<xi> = i)"
  by (inv_cterms simp add: \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def)

text \<open>Proposition 7.8\<close>

lemma sender_ip_valid':
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), a, _). anycast (\<lambda>m. not_Pkt m \<longrightarrow> msg_sender m = ip \<xi>) a)"
  by inv_cterms

lemma sender_ip_valid:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), a, _). anycast (\<lambda>m. not_Pkt m \<longrightarrow> msg_sender m = i) a)"
  by (rule step_invariant_weaken_with_invariantE [OF ip_constant sender_ip_valid'])
     (auto dest!: onlD onllD)

lemma received_msg_inv:
  "paodv i \<TTurnstile> (recvmsg P \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). l \<in> {PAodv-:1} \<longrightarrow> P (msg \<xi>))"
  by inv_cterms

text \<open>Proposition 7.9\<close>

lemma sip_not_ip':
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. not_Pkt m \<longrightarrow> msg_sender m \<noteq> i) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _). sip \<xi> \<noteq> ip \<xi>)"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]
                          onl_invariant_sterms [OF aodv_wf ip_constant [THEN invariant_restrict_inD]]
                simp add: clear_locals_sip_not_ip') clarsimp+

lemma sip_not_ip:
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. not_Pkt m \<longrightarrow> msg_sender m \<noteq> i) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _). sip \<xi> \<noteq> i)"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]
                          onl_invariant_sterms [OF aodv_wf ip_constant [THEN invariant_restrict_inD]]
                simp add: clear_locals_sip_not_ip') clarsimp+

text \<open>Neither \<open>sip_not_ip'\<close> nor \<open>sip_not_ip\<close> is needed to show loop freedom.\<close>

text \<open>Proposition 7.10\<close>

lemma hop_count_positive:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _). \<forall>ip\<in>kD (rt \<xi>). the (dhops (rt \<xi>) ip) \<ge> 1)"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf addpreRT_welldefined]) auto

lemma rreq_dip_in_vD_dip_eq_ip:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l \<in> {PRreq-:16..PRreq-:18} \<longrightarrow> dip \<xi> \<in> vD(rt \<xi>))
                            \<and> (l \<in> {PRreq-:5, PRreq-:6} \<longrightarrow> dip \<xi> = ip \<xi>)
                            \<and> (l \<in> {PRreq-:15..PRreq-:18} \<longrightarrow> dip \<xi> \<noteq> ip \<xi>))"
  proof (inv_cterms, elim conjE)
    fix l \<xi> pp p'
    assume "(\<xi>, pp) \<in> reachable (paodv i) TT"
       and "{PRreq-:17}\<lbrakk>\<lambda>\<xi>. \<xi>\<lparr>rt := the (addpreRT (rt \<xi>) (oip \<xi>) {the (nhop (rt \<xi>) (dip \<xi>))})\<rparr>\<rbrakk> p'
              \<in> sterms \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V pp"
       and "l = PRreq-:17"
       and "dip \<xi> \<in> vD (rt \<xi>)"
    from this(1-3) have "oip \<xi> \<in> kD (rt \<xi>)"
      by (auto dest: onl_invariant_sterms [OF aodv_wf addpreRT_welldefined, where l="PRreq-:17"])
    with \<open>dip \<xi> \<in> vD (rt \<xi>)\<close>
      show "dip \<xi> \<in> vD (the (addpreRT (rt \<xi>) (oip \<xi>) {the (nhop (rt \<xi>) (dip \<xi>))}))" by simp
  qed

text \<open>Proposition 7.11\<close>

lemma anycast_msg_zhops:
  "\<And>rreqid dip dsn dsk oip osn sip.
      paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(_, a, _). anycast msg_zhops a)"
  proof (inv_cterms inv add:
           onl_invariant_sterms [OF aodv_wf rreq_dip_in_vD_dip_eq_ip [THEN invariant_restrict_inD]]
           onl_invariant_sterms [OF aodv_wf hop_count_positive [THEN invariant_restrict_inD]],
         elim conjE)
    fix l \<xi> a pp p' pp'
    assume "(\<xi>, pp) \<in> reachable (paodv i) TT"
       and "{PRreq-:18}unicast(\<lambda>\<xi>. the (nhop (rt \<xi>) (oip \<xi>)),
               \<lambda>\<xi>. Rrep (the (dhops (rt \<xi>) (dip \<xi>))) (dip \<xi>) (sqn (rt \<xi>) (dip \<xi>)) (oip \<xi>) (ip \<xi>)).
                     p' \<triangleright> pp' \<in> sterms \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V pp"
       and "l = PRreq-:18"
       and "a = unicast (the (nhop (rt \<xi>) (oip \<xi>)))
                 (Rrep (the (dhops (rt \<xi>) (dip \<xi>))) (dip \<xi>) (sqn (rt \<xi>) (dip \<xi>)) (oip \<xi>) (ip \<xi>))"
       and *: "\<forall>ip\<in>kD (rt \<xi>). Suc 0 \<le> the (dhops (rt \<xi>) ip)"
       and "dip \<xi> \<in> vD (rt \<xi>)"
    from \<open>dip \<xi> \<in> vD (rt \<xi>)\<close> have "dip \<xi> \<in> kD (rt \<xi>)"
      by (rule vD_iD_gives_kD(1))
    with * have "Suc 0 \<le> the (dhops (rt \<xi>) (dip \<xi>))" ..
    thus "0 < the (dhops (rt \<xi>) (dip \<xi>))" by simp
  qed

lemma hop_count_zero_oip_dip_sip:
  "paodv i \<TTurnstile> (recvmsg msg_zhops \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                 (l\<in>{PAodv-:4..PAodv-:5} \<union> {PRreq-:n|n. True} \<longrightarrow>
                          (hops \<xi> = 0 \<longrightarrow> oip \<xi> = sip \<xi>))
                 \<and>
                 ((l\<in>{PAodv-:6..PAodv-:7} \<union> {PRrep-:n|n. True} \<longrightarrow>
                          (hops \<xi> = 0 \<longrightarrow> dip \<xi> = sip \<xi>))))"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]) auto

lemma osn_rreq:
  "paodv i \<TTurnstile> (recvmsg rreq_rrep_sn \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                    l \<in> {PAodv-:4, PAodv-:5} \<union> {PRreq-:n|n. True} \<longrightarrow> 1 \<le> osn \<xi>)"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]) clarsimp

lemma osn_rreq':
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                    l \<in> {PAodv-:4, PAodv-:5} \<union> {PRreq-:n|n. True} \<longrightarrow> 1 \<le> osn \<xi>)"
  proof (rule invariant_weakenE [OF osn_rreq])
    fix a
    assume "recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) a"
    thus "recvmsg rreq_rrep_sn a"
      by (cases a) simp_all
  qed

lemma dsn_rrep:
  "paodv i \<TTurnstile> (recvmsg rreq_rrep_sn \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                    l \<in> {PAodv-:6, PAodv-:7} \<union> {PRrep-:n|n. True} \<longrightarrow> 1 \<le> dsn \<xi>)"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]) clarsimp

lemma dsn_rrep':
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) \<rightarrow>)  onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                    l \<in> {PAodv-:6, PAodv-:7} \<union> {PRrep-:n|n. True} \<longrightarrow> 1 \<le> dsn \<xi>)"
  proof (rule invariant_weakenE [OF dsn_rrep])
    fix a
    assume "recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) a"
    thus "recvmsg rreq_rrep_sn a"
      by (cases a) simp_all
  qed

lemma hop_count_zero_oip_dip_sip':
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                 (l\<in>{PAodv-:4..PAodv-:5} \<union> {PRreq-:n|n. True} \<longrightarrow>
                          (hops \<xi> = 0 \<longrightarrow> oip \<xi> = sip \<xi>))
                 \<and>
                 ((l\<in>{PAodv-:6..PAodv-:7} \<union> {PRrep-:n|n. True} \<longrightarrow>
                          (hops \<xi> = 0 \<longrightarrow> dip \<xi> = sip \<xi>))))"
  proof (rule invariant_weakenE [OF hop_count_zero_oip_dip_sip])
    fix a
    assume "recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) a"
    thus "recvmsg msg_zhops a"
      by (cases a) simp_all
  qed

text \<open>Proposition 7.12\<close>

lemma zero_seq_unk_hops_one':
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _).
                 \<forall>dip\<in>kD(rt \<xi>). (sqn (rt \<xi>) dip = 0 \<longrightarrow> sqnf (rt \<xi>) dip = unk)
                              \<and> (sqnf (rt \<xi>) dip = unk \<longrightarrow> the (dhops (rt \<xi>) dip) = 1)
                              \<and> (the (dhops (rt \<xi>) dip) = 1 \<longrightarrow> the (nhop (rt \<xi>) dip) = dip))"
  proof -
  { fix dip and \<xi> :: state and P
    assume "sqn (invalidate (rt \<xi>) (dests \<xi>)) dip = 0"
       and all: "\<forall>ip. sqn (rt \<xi>) ip \<le> sqn (invalidate (rt \<xi>) (dests \<xi>)) ip"
       and *: "sqn (rt \<xi>) dip = 0 \<Longrightarrow> P \<xi> dip"
    have "P \<xi> dip"
    proof -
      from all have "sqn (rt \<xi>) dip \<le> sqn (invalidate (rt \<xi>) (dests \<xi>)) dip" ..
      with \<open>sqn (invalidate (rt \<xi>) (dests \<xi>)) dip = 0\<close> have "sqn (rt \<xi>) dip = 0" by simp
      thus "P \<xi> dip" by (rule *)
    qed
  } note sqn_invalidate_zero [elim!] = this

  { fix dsn hops :: nat and sip oip rt and ip dip :: ip
    assume "\<forall>dip\<in>kD(rt).
                (sqn rt dip = 0 \<longrightarrow> \<pi>\<^sub>3(the (rt dip)) = unk) \<and>
                (\<pi>\<^sub>3(the (rt dip)) = unk \<longrightarrow> the (dhops rt dip) = Suc 0) \<and>
                (the (dhops rt dip) = Suc 0 \<longrightarrow> the (nhop rt dip) = dip)"
       and "hops = 0 \<longrightarrow> sip = dip"
       and "Suc 0 \<le> dsn"
       and "ip \<noteq> dip \<longrightarrow> ip\<in>kD(rt)"
    hence "the (dhops (update rt dip (dsn, kno, val, Suc hops, sip, {})) ip) = Suc 0 \<longrightarrow>
           the (nhop (update rt dip (dsn, kno, val, Suc hops, sip, {})) ip) = ip"
      by - (rule update_cases, auto simp add: sqn_def dest!: bspec)
  } note prreq_ok1 [simp] = this

  { fix ip dsn hops sip oip rt dip
    assume "\<forall>dip\<in>kD(rt).
                (sqn rt dip = 0 \<longrightarrow> \<pi>\<^sub>3(the (rt dip)) = unk) \<and>
                (\<pi>\<^sub>3(the (rt dip)) = unk \<longrightarrow> the (dhops rt dip) = Suc 0) \<and>
                (the (dhops rt dip) = Suc 0 \<longrightarrow> the (nhop rt dip) = dip)"
       and "Suc 0 \<le> dsn"
       and "ip \<noteq> dip \<longrightarrow> ip\<in>kD(rt)"
    hence "\<pi>\<^sub>3(the (update rt dip (dsn, kno, val, Suc hops, sip, {}) ip)) = unk \<longrightarrow>
           the (dhops (update rt dip (dsn, kno, val, Suc hops, sip, {})) ip) = Suc 0"
      by - (rule update_cases, auto simp add: sqn_def sqnf_def dest!: bspec)
  } note prreq_ok2 [simp] = this

  { fix ip dsn hops sip oip rt dip
    assume "\<forall>dip\<in>kD(rt).
                (sqn rt dip = 0 \<longrightarrow> \<pi>\<^sub>3(the (rt dip)) = unk) \<and>
                (\<pi>\<^sub>3(the (rt dip)) = unk \<longrightarrow> the (dhops rt dip) = Suc 0) \<and>
                (the (dhops rt dip) = Suc 0 \<longrightarrow> the (nhop rt dip) = dip)"
       and "Suc 0 \<le> dsn"
       and "ip \<noteq> dip \<longrightarrow> ip\<in>kD(rt)"
    hence "sqn (update rt dip (dsn, kno, val, Suc hops, sip, {})) ip = 0 \<longrightarrow>
           \<pi>\<^sub>3 (the (update rt dip (dsn, kno, val, Suc hops, sip, {}) ip)) = unk"
      by - (rule update_cases, auto simp add: sqn_def dest!: bspec)
  } note prreq_ok3 [simp] = this

  { fix rt sip
    assume "\<forall>dip\<in>kD rt.
              (sqn rt dip = 0 \<longrightarrow> \<pi>\<^sub>3(the (rt dip)) = unk) \<and>
              (\<pi>\<^sub>3(the (rt dip)) = unk \<longrightarrow> the (dhops rt dip) = Suc 0) \<and>
              (the (dhops rt dip) = Suc 0 \<longrightarrow> the (nhop rt dip) = dip)"
    hence "\<forall>dip\<in>kD rt.
          (sqn (update rt sip (0, unk, val, Suc 0, sip, {})) dip = 0 \<longrightarrow>
           \<pi>\<^sub>3(the (update rt sip (0, unk, val, Suc 0, sip, {}) dip)) = unk)
        \<and> (\<pi>\<^sub>3(the (update rt sip (0, unk, val, Suc 0, sip, {}) dip)) = unk \<longrightarrow>
           the (dhops (update rt sip (0, unk, val, Suc 0, sip, {})) dip) = Suc 0)
        \<and> (the (dhops (update rt sip (0, unk, val, Suc 0, sip, {})) dip) = Suc 0 \<longrightarrow>
           the (nhop (update rt sip (0, unk, val, Suc 0, sip, {})) dip) = dip)"
    by - (rule update_cases, simp_all add: sqnf_def sqn_def)
  } note prreq_ok4 [simp] = this

  have prreq_ok5 [simp]: "\<And>sip rt.
    \<pi>\<^sub>3(the (update rt sip (0, unk, val, Suc 0, sip, {}) sip)) = unk \<longrightarrow>
    the (dhops (update rt sip (0, unk, val, Suc 0, sip, {})) sip) = Suc 0"
    by (rule update_cases) simp_all

  have prreq_ok6 [simp]: "\<And>sip rt.
    sqn (update rt sip (0, unk, val, Suc 0, sip, {})) sip = 0 \<longrightarrow>
    \<pi>\<^sub>3 (the (update rt sip (0, unk, val, Suc 0, sip, {}) sip)) = unk"
    by (rule update_cases) simp_all

  show ?thesis
    by (inv_cterms inv add: onl_invariant_sterms_TT [OF aodv_wf addpreRT_welldefined]
                            onl_invariant_sterms [OF aodv_wf hop_count_zero_oip_dip_sip']
                            seq_step_invariant_sterms_TT [OF sqns_increase aodv_wf aodv_trans]
                            onl_invariant_sterms [OF aodv_wf osn_rreq']
                            onl_invariant_sterms [OF aodv_wf dsn_rrep']) clarsimp+
  qed

lemma zero_seq_unk_hops_one:
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _).
                 \<forall>dip\<in>kD(rt \<xi>). (sqn (rt \<xi>) dip = 0 \<longrightarrow> (sqnf (rt \<xi>) dip = unk
                                                         \<and> the (dhops (rt \<xi>) dip) = 1
                                                         \<and> the (nhop (rt \<xi>) dip) = dip)))"
  by (rule invariant_weakenE [OF zero_seq_unk_hops_one']) auto

lemma kD_unk_or_atleast_one:
  "paodv i \<TTurnstile> (recvmsg rreq_rrep_sn \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                               \<forall>dip\<in>kD(rt \<xi>). \<pi>\<^sub>3(the (rt \<xi> dip)) = unk \<or> 1 \<le> \<pi>\<^sub>2(the (rt \<xi> dip)))"
  proof -
    { fix sip rt dsn1 dsn2 dsk1 dsk2 flag1 flag2 hops1 hops2 nhip1 nhip2 pre1 pre2
      assume "dsk1 = unk \<or> Suc 0 \<le> dsn2"
      hence "\<pi>\<^sub>3(the (update rt sip (dsn1, dsk1, flag1, hops1, nhip1, pre1) sip)) = unk
            \<or> Suc 0 \<le> sqn (update rt sip (dsn2, dsk2, flag2, hops2, nhip2, pre2)) sip"
        unfolding update_def by (cases "dsk1 =unk") (clarsimp split: option.split)+
    } note fromsip [simp] = this

    { fix dip sip rt dsn1 dsn2 dsk1 dsk2 flag1 flag2 hops1 hops2 nhip1 nhip2 pre1 pre2
      assume allkd: "\<forall>dip\<in>kD(rt). \<pi>\<^sub>3(the (rt dip)) = unk \<or> Suc 0 \<le> sqn rt dip"
         and    **: "dsk1 = unk \<or> Suc 0 \<le> dsn2"
      have "\<forall>dip\<in>kD(rt). \<pi>\<^sub>3(the (update rt sip (dsn1, dsk1, flag1, hops1, nhip1, pre1) dip)) = unk
            \<or> Suc 0 \<le> sqn (update rt sip (dsn2, dsk2, flag2, hops2, nhip2, pre2)) dip"
        (is "\<forall>dip\<in>kD(rt). ?prop dip")
      proof
        fix dip
        assume "dip\<in>kD(rt)"
        thus "?prop dip"
        proof (cases "dip = sip")
          assume "dip = sip"
          with ** show ?thesis
            by simp
        next
          assume "dip \<noteq> sip"
          with \<open>dip\<in>kD(rt)\<close> allkd show ?thesis
            by simp
        qed
      qed
    } note solve_update [simp] = this

    { fix dip rt dests
      assume  *: "\<forall>ip\<in>dom(dests). ip\<in>kD(rt) \<and> sqn rt ip \<le> the (dests ip)"
         and **: "\<forall>ip\<in>kD(rt). \<pi>\<^sub>3(the (rt ip)) = unk \<or> Suc 0 \<le> sqn rt ip"
      have "\<forall>dip\<in>kD(rt). \<pi>\<^sub>3(the (rt dip)) = unk \<or> Suc 0 \<le> sqn (invalidate rt dests) dip"
      proof
        fix dip
        assume "dip\<in>kD(rt)"
        with ** have "\<pi>\<^sub>3(the (rt dip)) = unk \<or> Suc 0 \<le> sqn rt dip" ..
        thus "\<pi>\<^sub>3 (the (rt dip)) = unk \<or> Suc 0 \<le> sqn (invalidate rt dests) dip"
        proof
          assume "\<pi>\<^sub>3(the (rt dip)) = unk" thus ?thesis ..
        next
          assume "Suc 0 \<le> sqn rt dip"
          have "Suc 0 \<le> sqn (invalidate rt dests) dip"
          proof (cases "dip\<in>dom(dests)")
            assume "dip\<in>dom(dests)"
            with * have "sqn rt dip \<le> the (dests dip)" by simp
            with \<open>Suc 0 \<le> sqn rt dip\<close> have "Suc 0 \<le> the (dests dip)" by simp
            with \<open>dip\<in>dom(dests)\<close> \<open>dip\<in>kD(rt)\<close> [THEN kD_Some] show ?thesis
              unfolding invalidate_def sqn_def by auto
          next
            assume "dip\<notin>dom(dests)"
            with \<open>Suc 0 \<le> sqn rt dip\<close> \<open>dip\<in>kD(rt)\<close> [THEN kD_Some] show ?thesis
              unfolding invalidate_def sqn_def by auto
          qed
        thus ?thesis by (rule disjI2)
        qed
      qed
    } note solve_invalidate [simp] = this

    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms_TT [OF aodv_wf addpreRT_welldefined]
                              onl_invariant_sterms [OF aodv_wf dests_bigger_than_sqn
                                                               [THEN invariant_restrict_inD]]
                              onl_invariant_sterms [OF aodv_wf osn_rreq]
                              onl_invariant_sterms [OF aodv_wf dsn_rrep]
                    simp add: proj3_inv proj2_eq_sqn)
  qed

text \<open>Proposition 7.13\<close>

lemma rreq_rrep_sn_any_step_invariant:
  "paodv i \<TTurnstile>\<^sub>A (recvmsg rreq_rrep_sn \<rightarrow>) onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(_, a, _). anycast rreq_rrep_sn a)"
  proof -
    have sqnf_kno: "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                      (l \<in> {PRreq-:16..PRreq-:18} \<longrightarrow> sqnf (rt \<xi>) (dip \<xi>) = kno))"
      by (inv_cterms inv add: onl_invariant_sterms_TT [OF aodv_wf addpreRT_welldefined])
    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms_TT [OF aodv_wf addpreRT_welldefined]
                              onl_invariant_sterms [OF aodv_wf sequence_number_one_or_bigger
                                                               [THEN invariant_restrict_inD]]
                              onl_invariant_sterms [OF aodv_wf kD_unk_or_atleast_one]
                              onl_invariant_sterms_TT [OF aodv_wf sqnf_kno]
                              onl_invariant_sterms [OF aodv_wf osn_rreq]
                              onl_invariant_sterms [OF aodv_wf dsn_rrep])
         (auto simp: proj2_eq_sqn)
  qed

text \<open>Proposition 7.14\<close>

lemma rreq_rrep_fresh_any_step_invariant:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), a, _). anycast (rreq_rrep_fresh (rt \<xi>)) a)"
  proof -
    have rreq_oip: "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                       (l \<in> {PRreq-:3, PRreq-:4, PRreq-:15, PRreq-:27}
                               \<longrightarrow> oip \<xi> \<in> kD(rt \<xi>)
                                 \<and> (sqn (rt \<xi>) (oip \<xi>) > (osn \<xi>)
                                     \<or> (sqn (rt \<xi>) (oip \<xi>) = (osn \<xi>)
                                        \<and> the (dhops (rt \<xi>) (oip \<xi>)) \<le> Suc (hops \<xi>)
                                        \<and> the (flag (rt \<xi>) (oip \<xi>)) = val))))"
      proof inv_cterms
        fix l \<xi> l' pp p'
        assume "(\<xi>, pp) \<in> reachable (paodv i) TT"
           and "{PRreq-:2}\<lbrakk>\<lambda>\<xi>. \<xi>\<lparr>rt :=
                update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})\<rparr>\<rbrakk> p' \<in> sterms \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V pp"
           and "l' = PRreq-:3"
        show "osn \<xi> < sqn (update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})) (oip \<xi>)
           \<or> (sqn (update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})) (oip \<xi>) = osn \<xi>
             \<and> the (dhops (update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})) (oip \<xi>))
                                                                            \<le> Suc (hops \<xi>)
             \<and> the (flag (update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})) (oip \<xi>))
                                                                            = val)"
          unfolding update_def by (clarsimp split: option.split)
                                  (metis linorder_neqE_nat not_less)
      qed

    have rrep_prrep: "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
          (l \<in> {PRrep-:2..PRrep-:7} \<longrightarrow> (dip \<xi> \<in> kD(rt \<xi>)
                                        \<and> sqn (rt \<xi>) (dip \<xi>) = dsn \<xi>
                                        \<and> the (dhops (rt \<xi>) (dip \<xi>)) = Suc (hops \<xi>)
                                        \<and> the (flag (rt \<xi>) (dip \<xi>)) = val
                                        \<and> the (nhop (rt \<xi>) (dip \<xi>)) \<in> kD (rt \<xi>))))"
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf rrep_1_update_changes]
                              onl_invariant_sterms [OF aodv_wf sip_in_kD])

    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf rreq_oip]
                              onl_invariant_sterms [OF aodv_wf rreq_dip_in_vD_dip_eq_ip]
                              onl_invariant_sterms [OF aodv_wf rrep_prrep])
  qed

text \<open>Proposition 7.15\<close>

lemma rerr_invalid_any_step_invariant:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), a, _). anycast (rerr_invalid (rt \<xi>)) a)"
  proof -
    have dests_inv: "paodv i \<TTurnstile>
                      onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l \<in> {PAodv-:15, PPkt-:7, PRreq-:9,
                                            PRreq-:21, PRrep-:10, PRerr-:1}
                          \<longrightarrow> (\<forall>ip\<in>dom(dests \<xi>). ip\<in>vD(rt \<xi>)))
                         \<and> (l \<in> {PAodv-:16..PAodv-:19}
                              \<union> {PPkt-:8..PPkt-:11}
                              \<union> {PRreq-:10..PRreq-:13}
                              \<union> {PRreq-:22..PRreq-:25}
                              \<union> {PRrep-:11..PRrep-:14}
                              \<union> {PRerr-:2..PRerr-:5} \<longrightarrow> (\<forall>ip\<in>dom(dests \<xi>). ip\<in>iD(rt \<xi>)
                                                          \<and> the (dests \<xi> ip) = sqn (rt \<xi>) ip))
                         \<and> (l = PPkt-:14 \<longrightarrow> dip \<xi>\<in>iD(rt \<xi>)))"
      by inv_cterms (clarsimp split: if_split_asm option.split_asm simp: domIff)+
    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf dests_inv])
  qed

text \<open>Proposition 7.16\<close>

text \<open>
  Some well-definedness obligations are irrelevant for the Isabelle development:

  \begin{enumerate}
  \item In each routing table there is at most one entry for each destination: guaranteed by type.

  \item In each store of queued data packets there is at most one data queue for
        each destination: guaranteed by structure.

  \item Whenever a set of pairs @{term "(rip, rsn)"} is assigned to the variable
        @{term "dests"} of type @{typ "ip \<rightharpoonup> sqn"}, or to the first argument of
        the function @{term "rerr"}, this set is a partial function, i.e., there
        is at most one entry @{term "(rip, rsn)"} for each destination
        @{term "rip"}: guaranteed by type.
  \end{enumerate}
\<close>

lemma dests_vD_inc_sqn:
  "paodv i \<TTurnstile>
        onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l \<in> {PAodv-:15, PPkt-:7, PRreq-:9, PRreq-:21, PRrep-:10}
             \<longrightarrow> (\<forall>ip\<in>dom(dests \<xi>). ip\<in>vD(rt \<xi>) \<and> the (dests \<xi> ip) = inc (sqn (rt \<xi>) ip)))
           \<and> (l = PRerr-:1
             \<longrightarrow> (\<forall>ip\<in>dom(dests \<xi>). ip\<in>vD(rt \<xi>) \<and> the (dests \<xi> ip) > sqn (rt \<xi>) ip)))"
  by inv_cterms (clarsimp split: if_split_asm option.split_asm)+

text \<open>Proposition 7.27\<close>

lemma route_tables_fresher:
  "paodv i \<TTurnstile>\<^sub>A (recvmsg rreq_rrep_sn \<rightarrow>) onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), _, (\<xi>', _)).
                                                                \<forall>dip\<in>kD(rt \<xi>). rt \<xi> \<sqsubseteq>\<^bsub>dip\<^esub> rt \<xi>')"
  proof (inv_cterms inv add:
           onl_invariant_sterms [OF aodv_wf dests_vD_inc_sqn [THEN invariant_restrict_inD]]
           onl_invariant_sterms [OF aodv_wf hop_count_positive [THEN invariant_restrict_inD]]
           onl_invariant_sterms [OF aodv_wf osn_rreq]
           onl_invariant_sterms [OF aodv_wf dsn_rrep]
           onl_invariant_sterms [OF aodv_wf addpreRT_welldefined [THEN invariant_restrict_inD]])
    fix \<xi> pp p'
    assume "(\<xi>, pp) \<in> reachable (paodv i) (recvmsg rreq_rrep_sn)"
       and "{PRreq-:2}\<lbrakk>\<lambda>\<xi>. \<xi>\<lparr>rt := update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})\<rparr>\<rbrakk>
               p' \<in> sterms \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V pp"
       and "Suc 0 \<le> osn \<xi>"
       and *: "\<forall>ip\<in>kD (rt \<xi>). Suc 0 \<le> the (dhops (rt \<xi>) ip)"
    show "\<forall>ip\<in>kD (rt \<xi>). rt \<xi> \<sqsubseteq>\<^bsub>ip\<^esub> update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})"
    proof
      fix ip
      assume "ip\<in>kD (rt \<xi>)"
      moreover with * have "1 \<le> the (dhops (rt \<xi>) ip)" by simp
      moreover from \<open>Suc 0 \<le> osn \<xi>\<close>
        have "update_arg_wf (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})" ..
      ultimately show "rt \<xi> \<sqsubseteq>\<^bsub>ip\<^esub> update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})"
        by (rule rt_fresher_update)
    qed
  next
    fix \<xi> pp p'
    assume "(\<xi>, pp) \<in> reachable (paodv i) (recvmsg rreq_rrep_sn)"
       and "{PRrep-:1}\<lbrakk>\<lambda>\<xi>. \<xi>\<lparr>rt := update (rt \<xi>) (dip \<xi>) (dsn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})\<rparr>\<rbrakk>
            p' \<in> sterms \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V pp"
       and "Suc 0 \<le> dsn \<xi>"
       and *: "\<forall>ip\<in>kD (rt \<xi>). Suc 0 \<le> the (dhops (rt \<xi>) ip)"
    show "\<forall>ip\<in>kD (rt \<xi>). rt \<xi> \<sqsubseteq>\<^bsub>ip\<^esub> update (rt \<xi>) (dip \<xi>) (dsn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})"
    proof
      fix ip
      assume "ip\<in>kD (rt \<xi>)"
      moreover with * have "1 \<le> the (dhops (rt \<xi>) ip)" by simp
      moreover from \<open>Suc 0 \<le> dsn \<xi>\<close>
        have "update_arg_wf (dsn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})" ..
      ultimately show "rt \<xi> \<sqsubseteq>\<^bsub>ip\<^esub> update (rt \<xi>) (dip \<xi>) (dsn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>, {})"
        by (rule rt_fresher_update)
    qed
  qed

end


theory Dom_Prio
  imports "../Dominant" "../../Lifter/Lifter_Instances"
begin

(*
 * Idea:
 *)

(* We could also (perhaps) prove that if we know dominance on the inner data,
 * then we are dominant over priority liftings with equal data.
 * This probably isn't necessary given the way we use prio, however.
 *)

locale dominant2_prio_sig =
  fixes f0_1 :: "'a1 \<Rightarrow> nat"
  fixes f1_1 :: "'a1 \<Rightarrow> nat \<Rightarrow> nat"
  fixes f0_2 :: "'a2 \<Rightarrow> nat"
  fixes f1_2 :: "'a2 \<Rightarrow> nat \<Rightarrow> nat"

locale dominant2_prio = dominant2_sig +
  dominant2_prio_sig +
  assumes dominant_f1 : "\<And> x n . x \<in> X \<Longrightarrow> f1_2 (t2 x) n < f1_1 (t1 x) n"

sublocale dominant2_prio \<subseteq> out : dominant2 "prio_l f0_1 f1_1 l1" t1 "prio_l f0_2 f1_2 l2" t2 X
proof
  fix a1 a2
  fix b :: "'c md_prio"
  fix x
  assume Xin : "x \<in> X"

    obtain pb' b' where B' : "b = mdp pb' b'"
    by(cases b; auto simp add: prio_l_S_def)

  then show "LUpd (prio_l f0_2 f1_2 l2) (t2 x) a2 b <[
       LUpd (prio_l f0_1 f1_1 l1) (t1 x) a1 b"
    using dominant_f1[OF Xin, of pb']
    by(auto simp add: prio_l_def prio_pleq)
qed

lemma (in dominant2_prio) ax :
  shows "dominant2 (prio_l f0_1 f1_1 l1) t1 (prio_l f0_2 f1_2 l2) t2 X"
  using out.dominant2_axioms
  by auto

end