(*<*)
theory Example_Verification
imports "../Examples/Gcd/Greatest_Common_Divisor" Simple_Greatest_Common_Divisor
begin
(*>*)

chapter {* Verifying an Example Program *}

text {*
\label{sec:example-verification}
\begin{figure}
\lstinputlisting{Gcd.ads}
\lstinputlisting{Gcd.adb}
\caption{\SPARK{} program for computing the greatest common divisor}
\label{fig:gcd-prog}
\end{figure}

\begin{figure}
\input{Greatest_Common_Divisor}
\caption{Correctness proof for the greatest common divisor program}
\label{fig:gcd-proof}
\end{figure}
We will now explain the usage of the \SPARK{} verification environment by proving
the correctness of an example program. As an example, we use a program for computing
the \emph{greatest common divisor} of two natural numbers shown in \figref{fig:gcd-prog},
which has been taken from the book about \SPARK{} by Barnes @{cite \<open>\S 11.6\<close> Barnes}.
*}

section {* Importing \SPARK{} VCs into Isabelle *}

text {*
In order to specify that the \SPARK{} procedure \texttt{G\_C\_D} behaves like its
mathematical counterpart, Barnes introduces a \emph{proof function} \texttt{Gcd}
in the package specification. Invoking the \SPARK{} Examiner and Simplifier on
this program yields a file \texttt{g\_c\_d.siv} containing the simplified VCs,
as well as files \texttt{g\_c\_d.fdl} and \texttt{g\_c\_d.rls}, containing FDL
declarations and rules, respectively. The files generated by \SPARK{} are assumed to reside in the
subdirectory \texttt{greatest\_common\_divisor}. For \texttt{G\_C\_D} the
Examiner generates ten VCs, eight of which are proved automatically by
the Simplifier. We now show how to prove the remaining two VCs
interactively using HOL-\SPARK{}. For this purpose, we create a \emph{theory}
\texttt{Greatest\_Common\_Divisor}, which is shown in \figref{fig:gcd-proof}.
A theory file always starts with the keyword \isa{\isacommand{theory}} followed
by the name of the theory, which must be the same as the file name. The theory
name is followed by the keyword \isa{\isacommand{imports}} and a list of theories
imported by the current theory. All theories using the HOL-\SPARK{} verification
environment must import the theory \texttt{SPARK}. In addition, we also include
the \texttt{GCD} theory. The list of imported theories is followed by the
\isa{\isacommand{begin}} keyword. In order to interactively process the theory
shown in \figref{fig:gcd-proof}, we start Isabelle with the command
\begin{verbatim}
  isabelle emacs -l HOL-SPARK Greatest_Common_Divisor.thy
\end{verbatim}
The option ``\texttt{-l HOL-SPARK}'' instructs Isabelle to load the right
object logic image containing the verification environment. Each proof function
occurring in the specification of a \SPARK{} program must be linked with a
corresponding Isabelle function. This is accomplished by the command
\isa{\isacommand{spark\_proof\_functions}}, which expects a list of equations
of the form \emph{name}\texttt{\ =\ }\emph{term}, where \emph{name} is the
name of the proof function and \emph{term} is the corresponding Isabelle term.
In the case of \texttt{gcd}, both the \SPARK{} proof function and its Isabelle
counterpart happen to have the same name. Isabelle checks that the type of the
term linked with a proof function agrees with the type of the function declared
in the \texttt{*.fdl} file.
It is worth noting that the
\isa{\isacommand{spark\_proof\_functions}} command can be invoked both outside,
i.e.\ before \isa{\isacommand{spark\_open}}, and inside the environment, i.e.\ after
\isa{\isacommand{spark\_open}}, but before any \isa{\isacommand{spark\_vc}} command. The
former variant is useful when having to declare proof functions that are shared by several
procedures, whereas the latter has the advantage that the type of the proof function
can be checked immediately, since the VCs, and hence also the declarations of proof
functions in the \texttt{*.fdl} file have already been loaded.
\begin{figure}
\begin{flushleft}
\tt
Context: \\
\ \\
\begin{tabular}{ll}
fixes & @{text "m ::"}\ "@{text int}" \\
and   & @{text "n ::"}\ "@{text int}" \\
and   & @{text "c ::"}\ "@{text int}" \\
and   & @{text "d ::"}\ "@{text int}" \\
assumes & @{text "g_c_d_rules1:"}\ "@{text "0 \<le> integer__size"}" \\
and     & @{text "g_c_d_rules6:"}\ "@{text "0 \<le> natural__size"}" \\
\multicolumn{2}{l}{notes definition} \\
\multicolumn{2}{l}{\hspace{2ex}@{text "defns ="}\ `@{text "integer__first = - 2147483648"}`} \\
\multicolumn{2}{l}{\hspace{4ex}`@{text "integer__last = 2147483647"}`} \\
\multicolumn{2}{l}{\hspace{4ex}\dots}
\end{tabular}\ \\[1.5ex]
\ \\
Definitions: \\
\ \\
\begin{tabular}{ll}
@{text "g_c_d_rules2:"} & @{text "integer__first = - 2147483648"} \\
@{text "g_c_d_rules3:"} & @{text "integer__last = 2147483647"} \\
\dots
\end{tabular}\ \\[1.5ex]
\ \\
Verification conditions: \\
\ \\
path(s) from assertion of line 10 to assertion of line 10 \\
\ \\
@{text procedure_g_c_d_4}\ (unproved) \\
\ \ \begin{tabular}{ll}
assumes & @{text "H1:"}\ "@{text "0 \<le> c"}" \\
and     & @{text "H2:"}\ "@{text "0 < d"}" \\
and     & @{text "H3:"}\ "@{text "gcd c d = gcd m n"}" \\
\dots \\
shows & "@{text "0 < c - c sdiv d * d"}" \\
and   & "@{text "gcd d (c - c sdiv d * d) = gcd m n"}
\end{tabular}\ \\[1.5ex]
\ \\
path(s) from assertion of line 10 to finish \\
\ \\
@{text procedure_g_c_d_11}\ (unproved) \\
\ \ \begin{tabular}{ll}
assumes & @{text "H1:"}\ "@{text "0 \<le> c"}" \\
and     & @{text "H2:"}\ "@{text "0 < d"}" \\
and     & @{text "H3:"}\ "@{text "gcd c d = gcd m n"}" \\
\dots \\
shows & "@{text "d = gcd m n"}"
\end{tabular}
\end{flushleft}
\caption{Output of \isa{\isacommand{spark\_status}} for \texttt{g\_c\_d.siv}}
\label{fig:gcd-status}
\end{figure}
We now instruct Isabelle to open
a new verification environment and load a set of VCs. This is done using the
command \isa{\isacommand{spark\_open}}, which must be given the name of a
\texttt{*.siv} file as an argument. Behind the scenes, Isabelle
parses this file and the corresponding \texttt{*.fdl} and \texttt{*.rls} files,
and converts the VCs to Isabelle terms. Using the command \isa{\isacommand{spark\_status}},
the user can display the current VCs together with their status (proved, unproved).
The variants \isa{\isacommand{spark\_status}\ (proved)}
and \isa{\isacommand{spark\_status}\ (unproved)} show only proved and unproved
VCs, respectively. For \texttt{g\_c\_d.siv}, the output of
\isa{\isacommand{spark\_status}} is shown in \figref{fig:gcd-status}.
To minimize the number of assumptions, and hence the size of the VCs,
FDL rules of the form ``\dots\ \texttt{may\_be\_replaced\_by}\ \dots'' are
turned into native Isabelle definitions, whereas other rules are modelled
as assumptions.
*}

section {* Proving the VCs *}

text {*
\label{sec:proving-vcs}
The two open VCs are @{text procedure_g_c_d_4} and @{text procedure_g_c_d_11},
both of which contain the @{text gcd} proof function that the \SPARK{} Simplifier
does not know anything about. The proof of a particular VC can be started with
the \isa{\isacommand{spark\_vc}} command, which is similar to the standard
\isa{\isacommand{lemma}} and \isa{\isacommand{theorem}} commands, with the
difference that it only takes a name of a VC but no formula as an argument.
A VC can have several conclusions that can be referenced by the identifiers
@{text "?C1"}, @{text "?C2"}, etc. If there is just one conclusion, it can
also be referenced by @{text "?thesis"}. It is important to note that the
\texttt{div} operator of FDL behaves differently from the @{text div} operator
of Isabelle/HOL on negative numbers. The former always truncates towards zero,
whereas the latter truncates towards minus infinity. This is why the FDL
\texttt{div} operator is mapped to the @{text sdiv} operator in Isabelle/HOL,
which is defined as
@{thm [display] sdiv_def}
For example, we have that
@{lemma "-5 sdiv 4 = -1" by (simp add: sdiv_neg_pos)}, but
@{lemma "(-5::int) div 4 = -2" by simp}.
For non-negative dividend and divisor, @{text sdiv} is equivalent to @{text div},
as witnessed by theorem @{text sdiv_pos_pos}:
@{thm [display,mode=no_brackets] sdiv_pos_pos}
In contrast, the behaviour of the FDL \texttt{mod} operator is equivalent to
the one of Isabelle/HOL. Moreover, since FDL has no counterpart of the \SPARK{}
operator \textbf{rem}, the \SPARK{} expression \texttt{c}\ \textbf{rem}\ \texttt{d}
just becomes @{text "c - c sdiv d * d"} in Isabelle. The first conclusion of
@{text procedure_g_c_d_4} requires us to prove that the remainder of @{text c}
and @{text d} is greater than @{text 0}. To do this, we use the theorem
@{text zmod_zdiv_equality'} describing the correspondence between @{text div}
and @{text mod}
@{thm [display] zmod_zdiv_equality'}
together with the theorem @{text pos_mod_sign} saying that the result of the
@{text mod} operator is non-negative when applied to a non-negative divisor:
@{thm [display] pos_mod_sign}
We will also need the aforementioned theorem @{text sdiv_pos_pos} in order for
the standard Isabelle/HOL theorems about @{text div} to be applicable
to the VC, which is formulated using @{text sdiv} rather that @{text div}.
Note that the proof uses \texttt{`@{text "0 \<le> c"}`} and \texttt{`@{text "0 < d"}`}
rather than @{text H1} and @{text H2} to refer to the hypotheses of the current
VC. While the latter variant seems more compact, it is not particularly robust,
since the numbering of hypotheses can easily change if the corresponding
program is modified, making the proof script hard to adjust when there are many hypotheses.
Moreover, proof scripts using abbreviations like @{text H1} and @{text H2}
are hard to read without assistance from Isabelle.
The second conclusion of @{text procedure_g_c_d_4} requires us to prove that
the @{text gcd} of @{text d} and the remainder of @{text c} and @{text d}
is equal to the @{text gcd} of the original input values @{text m} and @{text n},
which is the actual \emph{invariant} of the procedure. This is a consequence
of theorem @{text gcd_non_0_int}
@{thm [display] gcd_non_0_int}
Again, we also need theorems @{text zmod_zdiv_equality'} and @{text sdiv_pos_pos}
to justify that \SPARK{}'s \textbf{rem} operator is equivalent to Isabelle's
@{text mod} operator for non-negative operands.
The VC @{text procedure_g_c_d_11} says that if the loop invariant holds before
the last iteration of the loop, the postcondition of the procedure will hold
after execution of the loop body. To prove this, we observe that the remainder
of @{text c} and @{text d}, and hence @{text "c mod d"} is @{text 0} when exiting
the loop. This implies that @{text "gcd c d = d"}, since @{text c} is divisible
by @{text d}, so the conclusion follows using the assumption @{text "gcd c d = gcd m n"}.
This concludes the proofs of the open VCs, and hence the \SPARK{} verification
environment can be closed using the command \isa{\isacommand{spark\_end}}.
This command checks that all VCs have been proved and issues an error message
if there are remaining unproved VCs. Moreover, Isabelle checks that there is
no open \SPARK{} verification environment when the final \isa{\isacommand{end}}
command of a theory is encountered.
*}

section {* Optimizing the proof *}

text {*
\begin{figure}
\lstinputlisting{Simple_Gcd.adb}
\input{Simple_Greatest_Common_Divisor}
\caption{Simplified greatest common divisor program and proof}
\label{fig:simple-gcd-proof}
\end{figure}
When looking at the program from \figref{fig:gcd-prog} once again, several
optimizations come to mind. First of all, like the input parameters of the
procedure, the local variables \texttt{C}, \texttt{D}, and \texttt{R} can
be declared as \texttt{Natural} rather than \texttt{Integer}. Since natural
numbers are non-negative by construction, the values computed by the algorithm
are trivially proved to be non-negative. Since we are working with non-negative
numbers, we can also just use \SPARK{}'s \textbf{mod} operator instead of
\textbf{rem}, which spares us an application of theorems @{text zmod_zdiv_equality'}
and @{text sdiv_pos_pos}. Finally, as noted by Barnes @{cite \<open>\S 11.5\<close> Barnes},
we can simplify matters by placing the \textbf{assert} statement between
\textbf{while} and \textbf{loop} rather than directly after the \textbf{loop}.
In the former case, the loop invariant has to be proved only once, whereas in
the latter case, it has to be proved twice: since the \textbf{assert} occurs after
the check of the exit condition, the invariant has to be proved for the path
from the \textbf{assert} statement to the \textbf{assert} statement, and for
the path from the \textbf{assert} statement to the postcondition. In the case
of the \texttt{G\_C\_D} procedure, this might not seem particularly problematic,
since the proof of the invariant is very simple, but it can unnecessarily
complicate matters if the proof of the invariant is non-trivial. The simplified
program for computing the greatest common divisor, together with its correctness
proof, is shown in \figref{fig:simple-gcd-proof}. Since the package specification
has not changed, we only show the body of the packages. The two VCs can now be
proved by a single application of Isabelle's proof method @{text simp}.
*}

(*<*)
end
(*>*)


section \<open>Trace Theory\<close>

theory Traces
imports "Basics/Word_Prefixes"
begin

  locale traces =
    fixes ind :: "'item \<Rightarrow> 'item \<Rightarrow> bool"
    assumes independence_symmetric[sym]: "ind a b \<Longrightarrow> ind b a"
  begin

    abbreviation Ind :: "'item set \<Rightarrow> 'item set \<Rightarrow> bool"
      where "Ind A B \<equiv> \<forall> a \<in> A. \<forall> b \<in> B. ind a b"

    inductive eq_swap :: "'item list \<Rightarrow> 'item list \<Rightarrow> bool" (infix "=\<^sub>S" 50)
      where swap: "ind a b \<Longrightarrow> u @ [a] @ [b] @ v =\<^sub>S u @ [b] @ [a] @ v"

    declare eq_swap.intros[intro]
    declare eq_swap.cases[elim]

    lemma eq_swap_sym[sym]: "v =\<^sub>S w \<Longrightarrow> w =\<^sub>S v" using independence_symmetric by auto

    lemma eq_swap_length[dest]: "w\<^sub>1 =\<^sub>S w\<^sub>2 \<Longrightarrow> length w\<^sub>1 = length w\<^sub>2" by force
    lemma eq_swap_range[dest]: "w\<^sub>1 =\<^sub>S w\<^sub>2 \<Longrightarrow> set w\<^sub>1 = set w\<^sub>2" by force

    lemma eq_swap_extend:
      assumes "w\<^sub>1 =\<^sub>S w\<^sub>2"
      shows "u @ w\<^sub>1 @ v =\<^sub>S u @ w\<^sub>2 @ v"
    using assms
    proof induct
      case (swap a b u' v')
      have "u @ (u' @ [a] @ [b] @ v') @ v = (u @ u') @ [a] @ [b] @ (v' @ v)" by simp
      also have "\<dots> =\<^sub>S (u @ u') @ [b] @ [a] @ (v' @ v)" using swap by blast
      also have "\<dots> = u @ (u' @ [b] @ [a] @ v') @ v" by simp
      finally show ?case by this
    qed

    lemma eq_swap_remove1:
      assumes "w\<^sub>1 =\<^sub>S w\<^sub>2"
      obtains (equal) "remove1 c w\<^sub>1 = remove1 c w\<^sub>2" | (swap) "remove1 c w\<^sub>1 =\<^sub>S remove1 c w\<^sub>2"
    using assms
    proof induct
      case (swap a b u v)
      have "c \<notin> set (u @ [a] @ [b] @ v) \<or>
        c \<in> set u \<or>
        c \<notin> set u \<and> c = a \<or>
        c \<notin> set u \<and> c \<noteq> a \<and> c = b \<or>
        c \<notin> set u \<and> c \<noteq> a \<and> c \<noteq> b \<and> c \<in> set v"
        by auto
      thus ?case
      proof (elim disjE)
        assume 0: "c \<notin> set (u @ [a] @ [b] @ v)"
        have 1: "c \<notin> set (u @ [b] @ [a] @ v)" using 0 by auto
        have 2: "remove1 c (u @ [a] @ [b] @ v) = u @ [a] @ [b] @ v" using remove1_idem 0 by this
        have 3: "remove1 c (u @ [b] @ [a] @ v) = u @ [b] @ [a] @ v" using remove1_idem 1 by this
        have 4: "remove1 c (u @ [a] @ [b] @ v) =\<^sub>S remove1 c (u @ [b] @ [a] @ v)"
          unfolding 2 3 using eq_swap.intros swap(1) by this
        show thesis using swap(3) 4 by this
      next
        assume 0: "c \<in> set u"
        have 2: "remove1 c (u @ [a] @ [b] @ v) = remove1 c u @ [a] @ [b] @ v"
          unfolding remove1_append using 0 by simp
        have 3: "remove1 c (u @ [b] @ [a] @ v) = remove1 c u @ [b] @ [a] @ v"
          unfolding remove1_append using 0 by simp
        have 4: "remove1 c (u @ [a] @ [b] @ v) =\<^sub>S remove1 c (u @ [b] @ [a] @ v)"
          unfolding 2 3 using eq_swap.intros swap(1) by this
        show thesis using swap(3) 4 by this
      next
        assume 0: "c \<notin> set u \<and> c = a"
        have 2: "remove1 c (u @ [a] @ [b] @ v) = u @ [b] @ v"
          unfolding remove1_append using remove1_idem 0 by auto
        have 3: "remove1 c (u @ [b] @ [a] @ v) = u @ [b] @ v"
          unfolding remove1_append using remove1_idem 0 by auto
        have 4: "remove1 c (u @ [a] @ [b] @ v) = remove1 c (u @ [b] @ [a] @ v)"
          unfolding 2 3 by rule
        show thesis using swap(2) 4 by this
      next
        assume 0: "c \<notin> set u \<and> c \<noteq> a \<and> c = b"
        have 2: "remove1 c (u @ [a] @ [b] @ v) = u @ [a] @ v"
          unfolding remove1_append using remove1_idem 0 by auto
        have 3: "remove1 c (u @ [b] @ [a] @ v) = u @ [a] @ v"
          unfolding remove1_append using remove1_idem 0 by auto
        have 4: "remove1 c (u @ [a] @ [b] @ v) = remove1 c (u @ [b] @ [a] @ v)"
          unfolding 2 3 by rule
        show thesis using swap(2) 4 by this
      next
        assume 0: "c \<notin> set u \<and> c \<noteq> a \<and> c \<noteq> b \<and> c \<in> set v"
        have 2: "remove1 c (u @ [a] @ [b] @ v) = u @ [a] @ [b] @ remove1 c v"
          unfolding remove1_append using 0 by simp
        have 3: "remove1 c (u @ [b] @ [a] @ v) = u @ [b] @ [a] @ remove1 c v"
          unfolding remove1_append using 0 by simp
        have 4: "remove1 c (u @ [a] @ [b] @ v) =\<^sub>S remove1 c (u @ [b] @ [a] @ v)"
          unfolding 2 3 using eq_swap.intros swap(1) by this
        show ?thesis using swap(3) 4 by this
      qed
    qed

    lemma eq_swap_rev:
      assumes "w\<^sub>1 =\<^sub>S w\<^sub>2"
      shows "rev w\<^sub>1 =\<^sub>S rev w\<^sub>2"
    using assms
    proof induct
      case (swap a b u v)
      have 1: "rev v @ [a] @ [b] @ rev u =\<^sub>S rev v @ [b] @ [a] @ rev u" using swap by blast
      have 2: "rev v @ [b] @ [a] @ rev u =\<^sub>S rev v @ [a] @ [b] @ rev u" using 1 eq_swap_sym by blast
      show ?case using 2 by simp
    qed

    abbreviation eq_fin :: "'item list \<Rightarrow> 'item list \<Rightarrow> bool" (infix "=\<^sub>F" 50)
      where "eq_fin \<equiv> eq_swap\<^sup>*\<^sup>*"

    lemma eq_fin_symp[intro, sym]: "u =\<^sub>F v \<Longrightarrow> v =\<^sub>F u"
      using eq_swap_sym sym_rtrancl[to_pred] unfolding symp_def by metis

    lemma eq_fin_length[dest]: "w\<^sub>1 =\<^sub>F w\<^sub>2 \<Longrightarrow> length w\<^sub>1 = length w\<^sub>2"
      by (induct rule: rtranclp.induct, auto)
    lemma eq_fin_range[dest]: "w\<^sub>1 =\<^sub>F w\<^sub>2 \<Longrightarrow> set w\<^sub>1 = set w\<^sub>2"
      by (induct rule: rtranclp.induct, auto)

    lemma eq_fin_remove1:
      assumes "w\<^sub>1 =\<^sub>F w\<^sub>2"
      shows "remove1 c w\<^sub>1 =\<^sub>F remove1 c w\<^sub>2"
    using assms
    proof induct
      case (base)
      show ?case by simp
    next
      case (step w\<^sub>2 w\<^sub>3)
      show ?case
      using step(2)
      proof (cases rule: eq_swap_remove1[where ?c = c])
        case equal
        show ?thesis using step equal by simp
      next
        case swap
        show ?thesis using step swap by auto
      qed
    qed

    lemma eq_fin_rev:
      assumes "w\<^sub>1 =\<^sub>F w\<^sub>2"
      shows "rev w\<^sub>1 =\<^sub>F rev w\<^sub>2"
      using assms by (induct, auto dest: eq_swap_rev)

    lemma eq_fin_concat_eq_fin_start:
      assumes "u @ v\<^sub>1 =\<^sub>F u @ v\<^sub>2"
      shows "v\<^sub>1 =\<^sub>F v\<^sub>2"
    using assms
    proof (induct u arbitrary: v\<^sub>1 v\<^sub>2 rule: rev_induct)
      case (Nil)
      show ?case using Nil by simp
    next
      case (snoc a u)
      have 1: "u @ [a] @ v\<^sub>1 =\<^sub>F u @ [a] @ v\<^sub>2" using snoc(2) by simp
      have 2: "[a] @ v\<^sub>1 =\<^sub>F [a] @ v\<^sub>2" using snoc(1) 1 by this
      show ?case using eq_fin_remove1[OF 2, of a] by simp
    qed

    lemma eq_fin_concat: "u @ w\<^sub>1 @ v =\<^sub>F u @ w\<^sub>2 @ v \<longleftrightarrow> w\<^sub>1 =\<^sub>F w\<^sub>2"
    proof
      assume 0: "u @ w\<^sub>1 @ v =\<^sub>F u @ w\<^sub>2 @ v"
      have 1: "w\<^sub>1 @ v =\<^sub>F w\<^sub>2 @ v" using eq_fin_concat_eq_fin_start 0 by this
      have 2: "rev (w\<^sub>1 @ v) =\<^sub>F rev (w\<^sub>2 @ v)" using 1 by (blast dest: eq_fin_rev)
      have 3: "rev v @ rev w\<^sub>1 =\<^sub>F rev v @ rev w\<^sub>2" using 2 by simp
      have 4: "rev w\<^sub>1 =\<^sub>F rev w\<^sub>2" using eq_fin_concat_eq_fin_start 3 by this
      have 5: "rev (rev w\<^sub>1) =\<^sub>F rev (rev w\<^sub>2)" using 4 by (blast dest: eq_fin_rev)
      show "w\<^sub>1 =\<^sub>F w\<^sub>2" using 5 by simp
    next
      show "u @ w\<^sub>1 @ v =\<^sub>F u @ w\<^sub>2 @ v" if "w\<^sub>1 =\<^sub>F w\<^sub>2"
        using that by (induct, auto dest: eq_swap_extend[of _ _ u v])
    qed
    lemma eq_fin_concat_start[iff]: "w @ w\<^sub>1 =\<^sub>F w @ w\<^sub>2 \<longleftrightarrow> w\<^sub>1 =\<^sub>F w\<^sub>2"
      using eq_fin_concat[of "w" _ "[]"] by simp
    lemma eq_fin_concat_end[iff]: "w\<^sub>1 @ w =\<^sub>F w\<^sub>2 @ w \<longleftrightarrow> w\<^sub>1 =\<^sub>F w\<^sub>2"
      using eq_fin_concat[of "[]" _ "w"] by simp

    lemma ind_eq_fin':
      assumes "Ind {a} (set v)"
      shows "[a] @ v =\<^sub>F v @ [a]"
    using assms
    proof (induct v)
      case (Nil)
      show ?case by simp
    next
      case (Cons b v)
      have 1: "Ind {a} (set v)" using Cons(2) by auto
      have 2: "ind a b" using Cons(2) by auto
      have "[a] @ b # v = [a] @ [b] @ v" by simp
      also have "\<dots> =\<^sub>S [b] @ [a] @ v" using eq_swap.intros[OF 2, of "[]"] by auto
      also have "\<dots> =\<^sub>F [b] @ v @ [a]" using Cons(1) 1 by blast
      also have "\<dots> = (b # v) @ [a]" by simp
      finally show ?case by this
    qed

    lemma ind_eq_fin[intro]:
      assumes "Ind (set u) (set v)"
      shows "u @ v =\<^sub>F v @ u"
    using assms
    proof (induct u)
      case (Nil)
      show ?case by simp
    next
      case (Cons a u)
      have 1: "Ind (set u) (set v)" using Cons(2) by auto
      have 2: "Ind {a} (set v)" using Cons(2) by auto
      have "(a # u) @ v = [a] @ u @ v" by simp
      also have "\<dots> =\<^sub>F [a] @ v @ u" using Cons(1) 1 by blast
      also have "\<dots> = ([a] @ v) @ u" by simp
      also have "\<dots> =\<^sub>F (v @ [a]) @ u" using ind_eq_fin' 2 by blast
      also have "\<dots> = v @ (a # u)" by simp
      finally show ?case by this
    qed

    definition le_fin :: "'item list \<Rightarrow> 'item list \<Rightarrow> bool" (infix "\<preceq>\<^sub>F" 50)
      where "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2 \<equiv> \<exists> v\<^sub>1. w\<^sub>1 @ v\<^sub>1 =\<^sub>F w\<^sub>2"

    lemma le_finI[intro 0]:
      assumes "w\<^sub>1 @ v\<^sub>1 =\<^sub>F w\<^sub>2"
      shows "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2"
      using assms unfolding le_fin_def by auto
    lemma le_finE[elim 0]:
      assumes "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2"
      obtains v\<^sub>1
      where "w\<^sub>1 @ v\<^sub>1 =\<^sub>F w\<^sub>2"
      using assms unfolding le_fin_def by auto

    lemma le_fin_empty[simp]: "[] \<preceq>\<^sub>F w" by force
    lemma le_fin_trivial[intro]: "w\<^sub>1 =\<^sub>F w\<^sub>2 \<Longrightarrow> w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2"
    proof
      assume 1: "w\<^sub>1 =\<^sub>F w\<^sub>2"
      show "w\<^sub>1 @ [] =\<^sub>F w\<^sub>2" using 1 by simp
    qed

    lemma le_fin_length[dest]: "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2 \<Longrightarrow> length w\<^sub>1 \<le> length w\<^sub>2" by force
    lemma le_fin_range[dest]: "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2 \<Longrightarrow> set w\<^sub>1 \<subseteq> set w\<^sub>2" by force

    lemma eq_fin_alt_def: "w\<^sub>1 =\<^sub>F w\<^sub>2 \<longleftrightarrow> w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2 \<and> w\<^sub>2 \<preceq>\<^sub>F w\<^sub>1"
    proof
      show "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2 \<and> w\<^sub>2 \<preceq>\<^sub>F w\<^sub>1" if "w\<^sub>1 =\<^sub>F w\<^sub>2" using that by blast
    next
      assume 0: "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2 \<and> w\<^sub>2 \<preceq>\<^sub>F w\<^sub>1"
      have 1: "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>F w\<^sub>1" using 0 by auto
      have 10: "length w\<^sub>1 = length w\<^sub>2" using 1 by force
      obtain v\<^sub>1 v\<^sub>2 where 2: "w\<^sub>1 @ v\<^sub>1 =\<^sub>F w\<^sub>2" "w\<^sub>2 @ v\<^sub>2 =\<^sub>F w\<^sub>1" using 1 by (elim le_finE)
      have 3: "length w\<^sub>1 = length (w\<^sub>1 @ v\<^sub>1)" using 2 10 by force
      have 4: "w\<^sub>1 = w\<^sub>1 @ v\<^sub>1" using 3 by auto
      have 5: "length w\<^sub>2 = length (w\<^sub>2 @ v\<^sub>2)" using 2 10 by force
      have 6: "w\<^sub>2 = w\<^sub>2 @ v\<^sub>2" using 5 by auto
      show "w\<^sub>1 =\<^sub>F w\<^sub>2" using 4 6 2 by simp
    qed

    lemma le_fin_reflp[simp, intro]: "w \<preceq>\<^sub>F w" by auto
    lemma le_fin_transp[intro, trans]:
      assumes "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>F w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>3"
    proof -
      obtain v\<^sub>1 where 1: "w\<^sub>1 @ v\<^sub>1 =\<^sub>F w\<^sub>2" using assms(1) by rule
      obtain v\<^sub>2 where 2: "w\<^sub>2 @ v\<^sub>2 =\<^sub>F w\<^sub>3" using assms(2) by rule
      show ?thesis
      proof
        have "w\<^sub>1 @ v\<^sub>1 @ v\<^sub>2 = (w\<^sub>1 @ v\<^sub>1) @ v\<^sub>2" by simp
        also have "\<dots> =\<^sub>F w\<^sub>2 @ v\<^sub>2" using 1 by blast
        also have "\<dots> =\<^sub>F w\<^sub>3" using 2 by blast
        finally show "w\<^sub>1 @ v\<^sub>1 @ v\<^sub>2 =\<^sub>F w\<^sub>3" by this
      qed
    qed
    lemma eq_fin_le_fin_transp[intro, trans]:
      assumes "w\<^sub>1 =\<^sub>F w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>F w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>3"
      using assms by auto
    lemma le_fin_eq_fin_transp[intro, trans]:
      assumes "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2" "w\<^sub>2 =\<^sub>F w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>3"
      using assms by auto

    lemma le_fin_concat_start[iff]: "w @ w\<^sub>1 \<preceq>\<^sub>F w @ w\<^sub>2 \<longleftrightarrow> w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2"
    proof
      assume 0: "w @ w\<^sub>1 \<preceq>\<^sub>F w @ w\<^sub>2"
      obtain v\<^sub>1 where 1: "w @ w\<^sub>1 @ v\<^sub>1 =\<^sub>F w @ w\<^sub>2" using 0 by auto
      show "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2" using 1 by auto
    next
      assume 0: "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2"
      obtain v\<^sub>1 where 1: "w\<^sub>1 @ v\<^sub>1 =\<^sub>F w\<^sub>2" using 0 by auto
      have 2: "(w @ w\<^sub>1) @ v\<^sub>1 =\<^sub>F w @ w\<^sub>2" using 1 by auto
      show "w @ w\<^sub>1 \<preceq>\<^sub>F w @ w\<^sub>2" using 2 by blast
    qed
    lemma le_fin_concat_end[dest]:
      assumes "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2"
      shows "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2 @ w"
    proof -
      obtain v\<^sub>1 where 1: "w\<^sub>1 @ v\<^sub>1 =\<^sub>F w\<^sub>2" using assms by rule
      show ?thesis
      proof
        have "w\<^sub>1 @ v\<^sub>1 @ w = (w\<^sub>1 @ v\<^sub>1) @ w" by simp
        also have "\<dots> =\<^sub>F w\<^sub>2 @ w" using 1 by blast
        finally show "w\<^sub>1 @ v\<^sub>1 @ w =\<^sub>F w\<^sub>2 @ w" by this
      qed
    qed

    definition le_fininf :: "'item list \<Rightarrow> 'item stream \<Rightarrow> bool" (infix "\<preceq>\<^sub>F\<^sub>I" 50)
      where "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2 \<equiv> \<exists> v\<^sub>2. v\<^sub>2 \<le>\<^sub>F\<^sub>I w\<^sub>2 \<and> w\<^sub>1 \<preceq>\<^sub>F v\<^sub>2"

    lemma le_fininfI[intro 0]:
      assumes "v\<^sub>2 \<le>\<^sub>F\<^sub>I w\<^sub>2" "w\<^sub>1 \<preceq>\<^sub>F v\<^sub>2"
      shows "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2"
      using assms unfolding le_fininf_def by auto
    lemma le_fininfE[elim 0]:
      assumes "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2"
      obtains v\<^sub>2
      where "v\<^sub>2 \<le>\<^sub>F\<^sub>I w\<^sub>2" "w\<^sub>1 \<preceq>\<^sub>F v\<^sub>2"
      using assms unfolding le_fininf_def by auto

    lemma le_fininf_empty[simp]: "[] \<preceq>\<^sub>F\<^sub>I w" by force

    lemma le_fininf_range[dest]: "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2 \<Longrightarrow> set w\<^sub>1 \<subseteq> sset w\<^sub>2" by force

    lemma eq_fin_le_fininf_transp[intro, trans]:
      assumes "w\<^sub>1 =\<^sub>F w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      using assms by blast
    lemma le_fin_le_fininf_transp[intro, trans]:
      assumes "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      using assms by blast
    lemma prefix_le_fininf_transp[intro, trans]:
      assumes "w\<^sub>1 \<le> w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      using assms by auto
    lemma le_fin_prefix_fininf_transp[intro, trans]:
      assumes "w\<^sub>1 \<preceq>\<^sub>F w\<^sub>2" "w\<^sub>2 \<le>\<^sub>F\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      using assms by auto
    lemma eq_fin_prefix_fininf_transp[intro, trans]:
      assumes "w\<^sub>1 =\<^sub>F w\<^sub>2" "w\<^sub>2 \<le>\<^sub>F\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      using assms by auto

    lemma le_fininf_concat_start[iff]: "w @ w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w @- w\<^sub>2 \<longleftrightarrow> w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2"
    proof
      assume 0: "w @ w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w @- w\<^sub>2"
      obtain v\<^sub>2 where 1: "v\<^sub>2 \<le>\<^sub>F\<^sub>I w @- w\<^sub>2" "w @ w\<^sub>1 \<preceq>\<^sub>F v\<^sub>2" using 0 by rule
      have 2: "length w \<le> length v\<^sub>2" using 1(2) by force
      have 4: "w \<le> v\<^sub>2" using prefix_fininf_extend[OF 1(1) 2] by this
      obtain v\<^sub>1 where 5: "v\<^sub>2 = w @ v\<^sub>1" using 4 by rule
      show "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2"
      proof
        show "v\<^sub>1 \<le>\<^sub>F\<^sub>I w\<^sub>2" using 1(1) unfolding 5 by auto
        show "w\<^sub>1 \<preceq>\<^sub>F v\<^sub>1" using 1(2) unfolding 5 by simp
      qed
    next
      assume 0: "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2"
      obtain v\<^sub>2 where 1: "v\<^sub>2 \<le>\<^sub>F\<^sub>I w\<^sub>2" "w\<^sub>1 \<preceq>\<^sub>F v\<^sub>2" using 0 by rule
      show "w @ w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w @- w\<^sub>2"
      proof
        show "w @ v\<^sub>2 \<le>\<^sub>F\<^sub>I (w @- w\<^sub>2)" using 1(1) by auto
        show "w @ w\<^sub>1 \<preceq>\<^sub>F w @ v\<^sub>2" using 1(2) by auto
      qed
    qed

    lemma le_fininf_singleton[intro, simp]: "[shd v] \<preceq>\<^sub>F\<^sub>I v"
    proof -
      have "[shd v] \<preceq>\<^sub>F\<^sub>I shd v ## sdrop 1 v" by blast
      also have "\<dots> = v" by simp
      finally show ?thesis by this
    qed

    definition le_inf :: "'item stream \<Rightarrow> 'item stream \<Rightarrow> bool" (infix "\<preceq>\<^sub>I" 50)
      where "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2 \<equiv> \<forall> v\<^sub>1. v\<^sub>1 \<le>\<^sub>F\<^sub>I w\<^sub>1 \<longrightarrow> v\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2"

    lemma le_infI[intro 0]:
      assumes "\<And> v\<^sub>1. v\<^sub>1 \<le>\<^sub>F\<^sub>I w\<^sub>1 \<Longrightarrow> v\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2"
      shows "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2"
      using assms unfolding le_inf_def by auto
    lemma le_infE[elim 0]:
      assumes "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2" "v\<^sub>1 \<le>\<^sub>F\<^sub>I w\<^sub>1"
      obtains "v\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2"
      using assms unfolding le_inf_def by auto

    lemma le_inf_range[dest]:
      assumes "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2"
      shows "sset w\<^sub>1 \<subseteq> sset w\<^sub>2"
    proof
      fix a
      assume 1: "a \<in> sset w\<^sub>1"
      obtain i where 2: "a = w\<^sub>1 !! i" using 1 by (metis imageE sset_range)
      have 3: "stake (Suc i) w\<^sub>1 \<le>\<^sub>F\<^sub>I w\<^sub>1" by rule
      have 4: "stake (Suc i) w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2" using assms 3 by rule
      have 5: "w\<^sub>1 !! i \<in> set (stake (Suc i) w\<^sub>1)" by (meson lessI set_stake_snth)
      show "a \<in> sset w\<^sub>2" unfolding 2 using 5 4 by fastforce
    qed

    lemma le_inf_reflp[simp, intro]: "w \<preceq>\<^sub>I w" by auto
    lemma prefix_fininf_le_inf_transp[intro, trans]:
      assumes "w\<^sub>1 \<le>\<^sub>F\<^sub>I w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      using assms by blast
    lemma le_fininf_le_inf_transp[intro, trans]:
      assumes "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      using assms by blast
    lemma le_inf_transp[intro, trans]:
      assumes "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>3"
      using assms by blast

    lemma le_infI':
      assumes "\<And> k. \<exists> v. v \<le>\<^sub>F\<^sub>I w\<^sub>1 \<and> k < length v \<and> v \<preceq>\<^sub>F\<^sub>I w\<^sub>2"
      shows "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2"
    proof
      fix u
      assume 1: "u \<le>\<^sub>F\<^sub>I w\<^sub>1"
      obtain v where 2: "v \<le>\<^sub>F\<^sub>I w\<^sub>1" "length u < length v" "v \<preceq>\<^sub>F\<^sub>I w\<^sub>2" using assms by auto
      have 3: "length u \<le> length v" using 2(2) by auto
      have 4: "u \<le> v" using prefix_fininf_length 1 2(1) 3 by this
      show "u \<preceq>\<^sub>F\<^sub>I w\<^sub>2" using 4 2(3) by rule
    qed

    lemma le_infI_chain_left:
      assumes "chain w" "\<And> k. w k \<preceq>\<^sub>F\<^sub>I v"
      shows "limit w \<preceq>\<^sub>I v"
    proof (rule le_infI')
      fix k
      obtain l where 1: "k < length (w l)" using assms(1) by rule
      show "\<exists> va. va \<le>\<^sub>F\<^sub>I limit w \<and> k < length va \<and> va \<preceq>\<^sub>F\<^sub>I v"
      proof (intro exI conjI)
        show "w l \<le>\<^sub>F\<^sub>I limit w" using chain_prefix_limit assms(1) by this
        show "k < length (w l)" using 1 by this
        show "w l \<preceq>\<^sub>F\<^sub>I v" using assms(2) by this
      qed
    qed
    lemma le_infI_chain_right:
      assumes "chain w" "\<And> u. u \<le>\<^sub>F\<^sub>I v \<Longrightarrow> u \<preceq>\<^sub>F w (l u)"
      shows "v \<preceq>\<^sub>I limit w"
    proof
      fix u
      assume 1: "u \<le>\<^sub>F\<^sub>I v"
      show "u \<preceq>\<^sub>F\<^sub>I limit w"
      proof
        show "w (l u) \<le>\<^sub>F\<^sub>I limit w" using chain_prefix_limit assms(1) by this
        show "u \<preceq>\<^sub>F w (l u)" using assms(2) 1 by this
      qed
    qed
    lemma le_infI_chain_right':
      assumes "chain w" "\<And> k. stake k v \<preceq>\<^sub>F w (l k)"
      shows "v \<preceq>\<^sub>I limit w"
    proof (rule le_infI_chain_right)
      show "chain w" using assms(1) by this
    next
      fix u
      assume 1: "u \<le>\<^sub>F\<^sub>I v"
      have 2: "stake (length u) v = u" using 1 by (simp add: prefix_fininf_def shift_eq)
      have 3: "stake (length u) v \<preceq>\<^sub>F w (l (length u))" using assms(2) by this
      show "u \<preceq>\<^sub>F w (l (length u))" using 3 unfolding 2 by this
    qed

    definition eq_inf :: "'item stream \<Rightarrow> 'item stream \<Rightarrow> bool" (infix "=\<^sub>I" 50)
      where "w\<^sub>1 =\<^sub>I w\<^sub>2 \<equiv> w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2 \<and> w\<^sub>2 \<preceq>\<^sub>I w\<^sub>1"

    lemma eq_infI[intro 0]:
      assumes "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>I w\<^sub>1"
      shows "w\<^sub>1 =\<^sub>I w\<^sub>2"
      using assms unfolding eq_inf_def by auto
    lemma eq_infE[elim 0]:
      assumes "w\<^sub>1 =\<^sub>I w\<^sub>2"
      obtains "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2" "w\<^sub>2 \<preceq>\<^sub>I w\<^sub>1"
      using assms unfolding eq_inf_def by auto

    lemma eq_inf_range[dest]: "w\<^sub>1 =\<^sub>I w\<^sub>2 \<Longrightarrow> sset w\<^sub>1 = sset w\<^sub>2" by force

    lemma eq_inf_reflp[simp, intro]: "w =\<^sub>I w" by auto
    lemma eq_inf_symp[intro]: "w\<^sub>1 =\<^sub>I w\<^sub>2 \<Longrightarrow> w\<^sub>2 =\<^sub>I w\<^sub>1" by auto
    lemma eq_inf_transp[intro, trans]:
      assumes "w\<^sub>1 =\<^sub>I w\<^sub>2" "w\<^sub>2 =\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 =\<^sub>I w\<^sub>3"
      using assms by blast
    lemma le_fininf_eq_inf_transp[intro, trans]:
      assumes "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2" "w\<^sub>2 =\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>3"
      using assms by blast
    lemma le_inf_eq_inf_transp[intro, trans]:
      assumes "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2" "w\<^sub>2 =\<^sub>I w\<^sub>3"
      shows "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>3"
      using assms by blast

    lemma le_inf_concat_start[iff]: "w @- w\<^sub>1 \<preceq>\<^sub>I w @- w\<^sub>2 \<longleftrightarrow> w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2"
    proof
      assume 1: "w @- w\<^sub>1 \<preceq>\<^sub>I w @- w\<^sub>2"
      show "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2"
      proof
        fix v\<^sub>1
        assume 2: "v\<^sub>1 \<le>\<^sub>F\<^sub>I w\<^sub>1"
        have "w @ v\<^sub>1 \<le>\<^sub>F\<^sub>I w @- w\<^sub>1" using 2 by auto
        also have "\<dots> \<preceq>\<^sub>I w @- w\<^sub>2" using 1 by this
        finally show "v\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2" by rule
      qed
    next
      assume 1: "w\<^sub>1 \<preceq>\<^sub>I w\<^sub>2"
      show "w @- w\<^sub>1 \<preceq>\<^sub>I w @- w\<^sub>2"
      proof
        fix v\<^sub>1
        assume 2: "v\<^sub>1 \<le>\<^sub>F\<^sub>I w @- w\<^sub>1"
        then show "v\<^sub>1 \<preceq>\<^sub>F\<^sub>I w @- w\<^sub>2"
        proof (cases rule: prefix_fininf_append)
          case (absorb)
          show ?thesis using absorb by auto
        next
          case (extend z)
          show ?thesis using 1 extend by auto
        qed
      qed
    qed
    lemma eq_fin_le_inf_concat_end[dest]: "w\<^sub>1 =\<^sub>F w\<^sub>2 \<Longrightarrow> w\<^sub>1 @- w \<preceq>\<^sub>I w\<^sub>2 @- w"
    proof
      fix v\<^sub>1
      assume 1: "w\<^sub>1 =\<^sub>F w\<^sub>2" "v\<^sub>1 \<le>\<^sub>F\<^sub>I w\<^sub>1 @- w"
      show "v\<^sub>1 \<preceq>\<^sub>F\<^sub>I w\<^sub>2 @- w"
      using 1(2)
      proof (cases rule: prefix_fininf_append)
        case (absorb)
        show ?thesis
        proof
          show "w\<^sub>2 \<le>\<^sub>F\<^sub>I (w\<^sub>2 @- w)" by auto
          show "v\<^sub>1 \<preceq>\<^sub>F w\<^sub>2" using absorb 1(1) by auto
        qed
      next
        case (extend w')
        show ?thesis
        proof
          show "w\<^sub>2 @ w' \<le>\<^sub>F\<^sub>I (w\<^sub>2 @- w)" using extend(2) by auto
          show "v\<^sub>1 \<preceq>\<^sub>F w\<^sub>2 @ w'" unfolding extend(1) using 1(1) by auto
        qed
      qed
    qed

    lemma eq_inf_concat_start[iff]: "w @- w\<^sub>1 =\<^sub>I w @- w\<^sub>2 \<longleftrightarrow> w\<^sub>1 =\<^sub>I w\<^sub>2" by blast
    lemma eq_inf_concat_end[dest]: "w\<^sub>1 =\<^sub>F w\<^sub>2 \<Longrightarrow> w\<^sub>1 @- w =\<^sub>I w\<^sub>2 @- w"
    proof -
      assume 0: "w\<^sub>1 =\<^sub>F w\<^sub>2"
      have 1: "w\<^sub>2 =\<^sub>F w\<^sub>1" using 0 by auto
      show "w\<^sub>1 @- w =\<^sub>I w\<^sub>2 @- w"
        using eq_fin_le_inf_concat_end[OF 0] eq_fin_le_inf_concat_end[OF 1] by auto
    qed

    lemma le_fininf_suffixI[intro]:
      assumes "w =\<^sub>I w\<^sub>1 @- w\<^sub>2"
      shows "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w"
      using assms by blast
    lemma le_fininf_suffixE[elim]:
      assumes "w\<^sub>1 \<preceq>\<^sub>F\<^sub>I w"
      obtains w\<^sub>2
      where "w =\<^sub>I w\<^sub>1 @- w\<^sub>2"
    proof -
      obtain v\<^sub>2 where 1: "v\<^sub>2 \<le>\<^sub>F\<^sub>I w" "w\<^sub>1 \<preceq>\<^sub>F v\<^sub>2" using assms(1) by rule
      obtain u\<^sub>1 where 2: "w\<^sub>1 @ u\<^sub>1 =\<^sub>F v\<^sub>2" using 1(2) by rule
      obtain v\<^sub>2' where 3: "w = v\<^sub>2 @- v\<^sub>2'" using 1(1) by rule
      show ?thesis
      proof
        show "w =\<^sub>I w\<^sub>1 @- u\<^sub>1 @- v\<^sub>2'" unfolding 3 using 2 by fastforce
      qed
    qed

    lemma subsume_fin:
      assumes "u\<^sub>1 \<preceq>\<^sub>F\<^sub>I w" "v\<^sub>1 \<preceq>\<^sub>F\<^sub>I w"
      obtains w\<^sub>1
      where "u\<^sub>1 \<preceq>\<^sub>F w\<^sub>1" "v\<^sub>1 \<preceq>\<^sub>F w\<^sub>1"
    proof -
      obtain u\<^sub>2 where 2: "u\<^sub>2 \<le>\<^sub>F\<^sub>I w" "u\<^sub>1 \<preceq>\<^sub>F u\<^sub>2" using assms(1) by rule
      obtain v\<^sub>2 where 3: "v\<^sub>2 \<le>\<^sub>F\<^sub>I w" "v\<^sub>1 \<preceq>\<^sub>F v\<^sub>2" using assms(2) by rule
      show ?thesis
      proof (cases "length u\<^sub>2" "length v\<^sub>2" rule: le_cases)
        case le
        show ?thesis
        proof
          show "u\<^sub>1 \<preceq>\<^sub>F v\<^sub>2" using 2(2) prefix_fininf_length[OF 2(1) 3(1) le] by auto
          show "v\<^sub>1 \<preceq>\<^sub>F v\<^sub>2" using 3(2) by this
        qed
      next
        case ge
        show ?thesis
        proof
          show "u\<^sub>1 \<preceq>\<^sub>F u\<^sub>2" using 2(2) by this
          show "v\<^sub>1 \<preceq>\<^sub>F u\<^sub>2" using 3(2) prefix_fininf_length[OF 3(1) 2(1) ge] by auto
        qed
      qed
    qed

    lemma eq_fin_end:
      assumes "u\<^sub>1 =\<^sub>F u\<^sub>2" "u\<^sub>1 @ v\<^sub>1 =\<^sub>F u\<^sub>2 @ v\<^sub>2"
      shows "v\<^sub>1 =\<^sub>F v\<^sub>2"
    proof -
      have "u\<^sub>1 @ v\<^sub>2 =\<^sub>F u\<^sub>2 @ v\<^sub>2" using assms(1) by blast
      also have "\<dots> =\<^sub>F u\<^sub>1 @ v\<^sub>1" using assms(2) by blast
      finally show ?thesis by blast
    qed

    definition indoc :: "'item \<Rightarrow> 'item list \<Rightarrow> bool"
      where "indoc a u \<equiv> \<exists> u\<^sub>1 u\<^sub>2. u = u\<^sub>1 @ [a] @ u\<^sub>2 \<and> a \<notin> set u\<^sub>1 \<and> Ind {a} (set u\<^sub>1)"

    lemma indoc_set: "indoc a u \<Longrightarrow> a \<in> set u" unfolding indoc_def by auto

    lemma indoc_appendI1[intro]:
      assumes "indoc a u"
      shows "indoc a (u @ v)"
      using assms unfolding indoc_def by force
    lemma indoc_appendI2[intro]:
      assumes "a \<notin> set u" "Ind {a} (set u)" "indoc a v"
      shows "indoc a (u @ v)"
    proof -
      obtain v\<^sub>1 v\<^sub>2 where 1: "v = v\<^sub>1 @ [a] @ v\<^sub>2" "a \<notin> set v\<^sub>1" "Ind {a} (set v\<^sub>1)"
        using assms(3) unfolding indoc_def by blast
      show ?thesis
      proof (unfold indoc_def, intro exI conjI)
        show "u @ v = (u @ v\<^sub>1) @ [a] @ v\<^sub>2" unfolding 1(1) by simp
        show "a \<notin> set (u @ v\<^sub>1)" using assms(1) 1(2) by auto
        show "Ind {a} (set (u @ v\<^sub>1))" using assms(2) 1(3) by auto
      qed
    qed
    lemma indoc_appendE[elim!]:
      assumes "indoc a (u @ v)"
      obtains (first) "a \<in> set u" "indoc a u" | (second)  "a \<notin> set u" "Ind {a} (set u)" "indoc a v"
    proof -
      obtain w\<^sub>1 w\<^sub>2 where 1: "u @ v = w\<^sub>1 @ [a] @ w\<^sub>2" "a \<notin> set w\<^sub>1" "Ind {a} (set w\<^sub>1)"
        using assms unfolding indoc_def by blast
      show ?thesis
      proof (cases "a \<in> set u")
        case True
        obtain u\<^sub>1 u\<^sub>2 where 2: "u = u\<^sub>1 @ [a] @ u\<^sub>2" "a \<notin> set u\<^sub>1"
          using split_list_first[OF True] by auto
        have 3: "w\<^sub>1 = u\<^sub>1"
        proof (rule split_list_first_unique)
          show "w\<^sub>1 @ [a] @ w\<^sub>2 = u\<^sub>1 @ [a] @ u\<^sub>2 @ v" using 1(1) unfolding 2(1) by simp
          show "a \<notin> set w\<^sub>1" using 1(2) by auto
          show "a \<notin> set u\<^sub>1" using 2(2) by this
        qed
        show ?thesis
        proof (rule first)
          show "a \<in> set u" using True by this
          show "indoc a u"
          proof (unfold indoc_def, intro exI conjI)
            show "u = u\<^sub>1 @ [a] @ u\<^sub>2" using 2(1) by this
            show "a \<notin> set u\<^sub>1" using 1(2) unfolding 3 by this
            show "Ind {a} (set u\<^sub>1)" using 1(3) unfolding 3 by this
          qed
        qed
      next
        case False
        have 2: "a \<in> set v" using indoc_set assms False by fastforce
        obtain v\<^sub>1 v\<^sub>2 where 3: "v = v\<^sub>1 @ [a] @ v\<^sub>2" "a \<notin> set v\<^sub>1"
          using split_list_first[OF 2] by auto
        have 4: "w\<^sub>1 = u @ v\<^sub>1"
        proof (rule split_list_first_unique)
          show "w\<^sub>1 @ [a] @ w\<^sub>2 = (u @ v\<^sub>1) @ [a] @ v\<^sub>2" using 1(1) unfolding 3(1) by simp
          show "a \<notin> set w\<^sub>1" using 1(2) by auto
          show "a \<notin> set (u @ v\<^sub>1)" using False 3(2) by auto
        qed
        show ?thesis
        proof (rule second)
          show "a \<notin> set u" using False by this
          show "Ind {a} (set u)" using 1(3) 4 by auto
          show "indoc a v"
          proof (unfold indoc_def, intro exI conjI)
            show "v = v\<^sub>1 @ [a] @ v\<^sub>2" using 3(1) by this
            show "a \<notin> set v\<^sub>1" using 1(2) unfolding 4 by auto
            show "Ind {a} (set v\<^sub>1)" using 1(3) unfolding 4 by auto
          qed
        qed
      qed
    qed

    lemma indoc_single: "indoc a [b] \<longleftrightarrow> a = b"
    proof
      assume 1: "indoc a [b]"
      obtain u\<^sub>1 u\<^sub>2 where 2: "[b] = u\<^sub>1 @ [a] @ u\<^sub>2" "Ind {a} (set u\<^sub>1)"
        using 1 unfolding indoc_def by auto
      show "a = b" using 2(1)
        by (metis append_eq_Cons_conv append_is_Nil_conv list.distinct(2) list.inject)
    next
      assume 1: "a = b"
      show "indoc a [b]"
      unfolding indoc_def 1
      proof (intro exI conjI)
        show "[b] = [] @ [b] @ []" by simp
        show "b \<notin> set []" by simp
        show "Ind {b} (set [])" by simp
      qed
    qed

    lemma indoc_append[simp]: "indoc a (u @ v) \<longleftrightarrow>
      indoc a u \<or> a \<notin> set u \<and> Ind {a} (set u) \<and> indoc a v" by blast
    lemma indoc_Nil[simp]: "indoc a [] \<longleftrightarrow> False" unfolding indoc_def by auto
    lemma indoc_Cons[simp]: "indoc a (b # v) \<longleftrightarrow> a = b \<or> a \<noteq> b \<and> ind a b \<and> indoc a v"
    proof -
      have "indoc a (b # v) \<longleftrightarrow> indoc a ([b] @ v)" by simp
      also have "\<dots> \<longleftrightarrow> indoc a [b] \<or> a \<notin> set [b] \<and> Ind {a} (set [b]) \<and> indoc a v"
        unfolding indoc_append by rule
      also have "\<dots> \<longleftrightarrow> a = b \<or> a \<noteq> b \<and> ind a b \<and> indoc a v" unfolding indoc_single by simp
      finally show ?thesis by this
    qed

    lemma eq_swap_indoc: "u =\<^sub>S v \<Longrightarrow> indoc c u \<Longrightarrow> indoc c v" by auto
    lemma eq_fin_indoc: "u =\<^sub>F v \<Longrightarrow> indoc c u \<Longrightarrow> indoc c v" by (induct rule: rtranclp.induct, auto)

    lemma eq_fin_ind':
      assumes "[a] @ u =\<^sub>F u\<^sub>1 @ [a] @ u\<^sub>2" "a \<notin> set u\<^sub>1"
      shows "Ind {a} (set u\<^sub>1)"
    proof -
      have 1: "indoc a ([a] @ u)" by simp
      have 2: "indoc a (u\<^sub>1 @ [a] @ u\<^sub>2)" using eq_fin_indoc assms(1) 1 by this
      show ?thesis using assms(2) 2 by blast
    qed
    lemma eq_fin_ind:
      assumes "u @ v =\<^sub>F v @ u" "set u \<inter> set v = {}"
      shows "Ind (set u) (set v)"
    using assms
    proof (induct u)
      case Nil
      show ?case by simp
    next
      case (Cons a u)
      have 1: "Ind {a} (set v)"
      proof (rule eq_fin_ind')
        show "[a] @ u @ v =\<^sub>F v @ [a] @ u" using Cons(2) by simp
        show "a \<notin> set v" using Cons(3) by simp
      qed
      have 2: "Ind (set [a]) (set v)" using 1 by simp
      have 4: "Ind (set u) (set v)"
      proof (rule Cons(1))
        have "[a] @ u @ v = (a # u) @ v" by simp
        also have "\<dots> =\<^sub>F v @ a # u" using Cons(2) by this
        also have "\<dots> = (v @ [a]) @ u" by simp
        also have "\<dots> =\<^sub>F ([a] @ v) @ u" using 2 by blast
        also have "\<dots> = [a] @ v @ u" by simp
        finally show "u @ v =\<^sub>F v @ u" by blast
        show "set u \<inter> set v = {}" using Cons(3) by auto
      qed
      show ?case using 1 4 by auto
    qed

    lemma le_fin_member':
      assumes "[a] \<preceq>\<^sub>F u @ v" "a \<in> set u"
      shows "[a] \<preceq>\<^sub>F u"
    proof -
      obtain w where 1: "[a] @ w =\<^sub>F u @ v" using assms(1) by rule
      obtain u\<^sub>1 u\<^sub>2 where 2: "u = u\<^sub>1 @ [a] @ u\<^sub>2" "a \<notin> set u\<^sub>1"
        using split_list_first[OF assms(2)] by auto
      have 3: "Ind {a} (set u\<^sub>1)"
      proof (rule eq_fin_ind')
        show "[a] @ w =\<^sub>F u\<^sub>1 @ [a] @ u\<^sub>2 @ v" using 1 unfolding 2(1) by simp
        show "a \<notin> set u\<^sub>1" using 2(2) by this
      qed
      have 4: "Ind (set [a]) (set u\<^sub>1)" using 3 by simp
      have "[a] \<le> [a] @ u\<^sub>1 @ u\<^sub>2" by auto
      also have "\<dots> = ([a] @ u\<^sub>1) @ u\<^sub>2" by simp
      also have "\<dots> =\<^sub>F (u\<^sub>1 @ [a]) @ u\<^sub>2" using 4 by blast
      also have "\<dots> = u" unfolding 2(1) by simp
      finally show ?thesis by this
    qed
    lemma le_fin_not_member':
      assumes "[a] \<preceq>\<^sub>F u @ v" "a \<notin> set u"
      shows "[a] \<preceq>\<^sub>F v"
    proof -
      obtain w where 1: "[a] @ w =\<^sub>F u @ v" using assms(1) by rule
      have 3: "a \<in> set v" using assms by auto
      obtain v\<^sub>1 v\<^sub>2 where 4: "v = v\<^sub>1 @ [a] @ v\<^sub>2" "a \<notin> set v\<^sub>1" using split_list_first[OF 3] by auto
      have 5: "[a] @ w =\<^sub>F u @ v\<^sub>1 @ [a] @ v\<^sub>2" using 1 unfolding 4(1) by this
      have 6: "Ind {a} (set (u @ v\<^sub>1))"
      proof (rule eq_fin_ind')
        show "[a] @ w =\<^sub>F (u @ v\<^sub>1) @ [a] @ v\<^sub>2" using 5 by simp
        show "a \<notin> set (u @ v\<^sub>1)" using assms(2) 4(2) by auto
      qed
      have 9: "Ind (set [a]) (set v\<^sub>1)" using 6 by auto
      have "[a] \<le> [a] @ v\<^sub>1 @ v\<^sub>2" by auto
      also have "\<dots> = ([a] @ v\<^sub>1) @ v\<^sub>2" by simp
      also have "\<dots> =\<^sub>F (v\<^sub>1 @ [a]) @ v\<^sub>2" using 9 by blast
      also have "\<dots> = v\<^sub>1 @ [a] @ v\<^sub>2" by simp
      also have "\<dots> = v" unfolding 4(1) by rule
      finally show ?thesis by this
    qed
    lemma le_fininf_not_member':
      assumes "[a] \<preceq>\<^sub>F\<^sub>I u @- v" "a \<notin> set u"
      shows "[a] \<preceq>\<^sub>F\<^sub>I v"
    proof -
      obtain v\<^sub>2 where 1: "v\<^sub>2 \<le>\<^sub>F\<^sub>I u @- v" "[a] \<preceq>\<^sub>F v\<^sub>2" using le_fininfE assms(1) by this
      show ?thesis
      using 1(1)
      proof (cases rule: prefix_fininf_append)
        case absorb
        have "[a] \<preceq>\<^sub>F v\<^sub>2" using 1(2) by this
        also have "\<dots> \<le> u" using absorb by this
        finally have 2: "a \<in> set u" by force
        show ?thesis using assms(2) 2 by simp
      next
        case (extend z)
        have "[a] \<preceq>\<^sub>F v\<^sub>2" using 1(2) by this
        also have "\<dots> = u @ z" using extend(1) by this
        finally have 2: "[a] \<preceq>\<^sub>F u @ z" by this
        have "[a] \<preceq>\<^sub>F z" using le_fin_not_member' 2 assms(2) by this
        also have "\<dots> \<le>\<^sub>F\<^sub>I v" using extend(2) by this
        finally show ?thesis by this
      qed
    qed

    lemma le_fin_ind'':
      assumes "[a] \<preceq>\<^sub>F w" "[b] \<preceq>\<^sub>F w" "a \<noteq> b"
      shows "ind a b"
    proof -
      obtain u where 1: "[a] @ u =\<^sub>F w" using assms(1) by rule
      obtain v where 2: "[b] @ v =\<^sub>F w" using assms(2) by rule
      have 3: "[a] @ u =\<^sub>F [b] @ v" using 1 2[symmetric] by auto
      have 4: "a \<in> set v" using 3 assms(3)
        by (metis append_Cons append_Nil eq_fin_range list.set_intros(1) set_ConsD)
      obtain v\<^sub>1 v\<^sub>2 where 5: "v = v\<^sub>1 @ [a] @ v\<^sub>2" "a \<notin> set v\<^sub>1" using split_list_first[OF 4] by auto
      have 7: "Ind {a} (set ([b] @ v\<^sub>1))"
      proof (rule eq_fin_ind')
        show "[a] @ u =\<^sub>F ([b] @ v\<^sub>1) @ [a] @ v\<^sub>2" using 3 unfolding 5(1) by simp
        show "a \<notin> set ([b] @ v\<^sub>1)" using assms(3) 5(2) by auto
      qed
      show ?thesis using 7 by auto
    qed
    lemma le_fin_ind':
      assumes "[a] \<preceq>\<^sub>F w" "v \<preceq>\<^sub>F w" "a \<notin> set v"
      shows "Ind {a} (set v)"
    using assms
    proof (induct v arbitrary: w)
      case Nil
      show ?case by simp
    next
      case (Cons b v)
      have 1: "ind a b"
      proof (rule le_fin_ind'')
        show "[a] \<preceq>\<^sub>F w" using Cons(2) by this
        show "[b] \<preceq>\<^sub>F w" using Cons(3) by auto
        show "a \<noteq> b" using Cons(4) by auto
      qed
      obtain w' where 2: "[b] @ w' =\<^sub>F w" using Cons(3) by auto
      have 3: "Ind {a} (set v)"
      proof (rule Cons(1))
        show "[a] \<preceq>\<^sub>F w'"
        proof (rule le_fin_not_member')
          show "[a] \<preceq>\<^sub>F [b] @ w'" using Cons(2) 2 by auto
          show "a \<notin> set [b]" using Cons(4) by auto
        qed
        have "[b] @ v = b # v" by simp
        also have "\<dots> \<preceq>\<^sub>F w" using Cons(3) by this
        also have "\<dots> =\<^sub>F [b] @ w'" using 2 by auto
        finally show "v \<preceq>\<^sub>F w'" by blast
        show "a \<notin> set v" using Cons(4) by auto
      qed
      show ?case using 1 3 by auto
    qed
    lemma le_fininf_ind'':
      assumes "[a] \<preceq>\<^sub>F\<^sub>I w" "[b] \<preceq>\<^sub>F\<^sub>I w" "a \<noteq> b"
      shows "ind a b"
      using subsume_fin le_fin_ind'' assms by metis
    lemma le_fininf_ind':
      assumes "[a] \<preceq>\<^sub>F\<^sub>I w" "v \<preceq>\<^sub>F\<^sub>I w" "a \<notin> set v"
      shows "Ind {a} (set v)"
      using subsume_fin le_fin_ind' assms by metis

    lemma indoc_alt_def: "indoc a v \<longleftrightarrow> v =\<^sub>F [a] @ remove1 a v"
    proof
      assume 0: "indoc a v"
      obtain v\<^sub>1 v\<^sub>2 where 1: "v = v\<^sub>1 @ [a] @ v\<^sub>2" "a \<notin> set v\<^sub>1" "Ind {a} (set v\<^sub>1)"
        using 0 unfolding indoc_def by blast
      have 2: "Ind (set [a]) (set v\<^sub>1)" using 1(3) by simp
      have "v = v\<^sub>1 @ [a] @ v\<^sub>2" using 1(1) by this
      also have "\<dots> = (v\<^sub>1 @ [a]) @ v\<^sub>2" by simp
      also have "\<dots> =\<^sub>F ([a] @ v\<^sub>1) @ v\<^sub>2" using 2 by blast
      also have "\<dots> = [a] @ v\<^sub>1 @ v\<^sub>2" by simp
      also have "\<dots> = [a] @ remove1 a v" unfolding 1(1) remove1_append using 1(2) by auto
      finally show "v =\<^sub>F [a] @ remove1 a v" by this
    next
      assume 0: "v =\<^sub>F [a] @ remove1 a v"
      have 1: "indoc a ([a] @ remove1 a v)" by simp
      show "indoc a v" using eq_fin_indoc 0  1 by blast
    qed

    lemma levi_lemma:
      assumes "t @ u =\<^sub>F v @ w"
      obtains p r s q
      where "t =\<^sub>F p @ r" "u =\<^sub>F s @ q" "v =\<^sub>F p @ s" "w =\<^sub>F r @ q" "Ind (set r) (set s)"
    using assms
    proof (induct t arbitrary: thesis v w)
      case Nil
      show ?case
      proof (rule Nil(1))
        show "[] =\<^sub>F [] @ []" by simp
        show "v =\<^sub>F [] @ v" by simp
        show "u =\<^sub>F v @ w" using Nil(2) by simp
        show "w =\<^sub>F [] @ w" by simp
        show "Ind (set []) (set v)" by simp
      qed
    next
      case (Cons a t')
      have 1: "[a] \<preceq>\<^sub>F v @ w" using Cons(3) by blast
      show ?case
      proof (cases "a \<in> set v")
        case False
        have 2: "[a] \<preceq>\<^sub>F w" using le_fin_not_member' 1 False by this
        obtain w' where 3: "w =\<^sub>F [a] @ w'" using 2 by blast
        have 4: "v \<preceq>\<^sub>F v @ w" by auto
        have 5: "Ind (set [a]) (set v)" using le_fin_ind'[OF 1 4] False by simp
        have "[a] @ t' @ u = (a # t') @ u" by simp
        also have "\<dots> =\<^sub>F v @ w" using Cons(3) by this
        also have "\<dots> =\<^sub>F v @ [a] @ w'" using 3 by blast
        also have "\<dots> = (v @ [a]) @ w'" by simp
        also have "\<dots> =\<^sub>F ([a] @ v) @ w'" using 5 by blast
        also have "\<dots> = [a] @ v @ w'" by simp
        finally have 6: "t' @ u =\<^sub>F v @ w'" by blast
        obtain p r' s q where 7: "t' =\<^sub>F p @ r'" "u =\<^sub>F s @ q" "v =\<^sub>F p @ s" "w' =\<^sub>F r' @ q"
          "Ind (set r') (set s)" using Cons(1)[OF _ 6] by this
        have 8: "set v = set p \<union> set s" using eq_fin_range 7(3) by auto
        have 9: "Ind (set [a]) (set p)" using 5 8 by auto
        have 10: "Ind (set [a]) (set s)" using 5 8 by auto
        show ?thesis
        proof (rule Cons(2))
          have "a # t' = [a] @ t'" by simp
          also have "\<dots> =\<^sub>F [a] @ p @ r'" using 7(1) by blast
          also have "\<dots> = ([a] @ p) @ r'" by simp
          also have "\<dots> =\<^sub>F (p @ [a]) @ r'" using 9 by blast
          also have "\<dots> = p @ [a] @ r'" by simp
          finally show "a # t' =\<^sub>F p @ [a] @ r'" by this
          show "u =\<^sub>F s @ q" using 7(2) by this
          show "v =\<^sub>F p @ s" using 7(3) by this
          have "w =\<^sub>F [a] @ w'" using 3 by this
          also have "\<dots> =\<^sub>F [a] @ r' @ q" using 7(4) by blast
          also have "\<dots> = ([a] @ r') @ q" by simp
          finally show "w =\<^sub>F ([a] @ r') @ q" by this
          show "Ind (set ([a] @ r')) (set s)" using 7(5) 10 by auto
        qed
      next
        case True
        have 2: "[a] \<preceq>\<^sub>F v" using le_fin_member' 1 True by this
        obtain v' where 3: "v =\<^sub>F [a] @ v'" using 2 by blast
        have "[a] @ t' @ u = (a # t') @ u" by simp
        also have "\<dots> =\<^sub>F v @ w" using Cons(3) by this
        also have "\<dots> =\<^sub>F ([a] @ v') @ w" using 3 by blast
        also have "\<dots> = [a] @ v' @ w" by simp
        finally have 4: "t' @ u =\<^sub>F v' @ w" by blast
        obtain p' r s q where 7: "t' =\<^sub>F p' @ r" "u =\<^sub>F s @ q" "v' =\<^sub>F p' @ s" "w =\<^sub>F r @ q"
          "Ind (set r) (set s)" using Cons(1)[OF _ 4] by this
        show ?thesis
        proof (rule Cons(2))
          have "a # t' = [a] @ t'" by simp
          also have "\<dots> =\<^sub>F [a] @ p' @ r" using 7(1) by blast
          also have "\<dots> = ([a] @ p') @ r" by simp
          finally show "a # t' =\<^sub>F ([a] @ p') @ r" by this
          show "u =\<^sub>F s @ q" using 7(2) by this
          have "v =\<^sub>F [a] @ v'" using 3 by this
          also have "\<dots> =\<^sub>F [a] @ p' @ s" using 7(3) by blast
          also have "\<dots> = ([a] @ p') @ s" by simp
          finally show "v =\<^sub>F ([a] @ p') @ s" by this
          show "w =\<^sub>F r @ q" using 7(4) by this
          show "Ind (set r) (set s)" using 7(5) by this
        qed
      qed
    qed

  end

end


(* @LICENSE(NICTA_CORE) *)

(*  Author:     Rafal Kolanski, NICTA & UNSW

    Type agnostic definition of address and pointer types.
*)

theory Pointers
imports Main
begin

text \<open>
  A machine has two types of addresses: virtual and physical.
  Since very often they are the same size (e.g. 32-bit wide) we wish to
  differentiate them at the type level.
  Convention: paddr_word is a word type of same width as physical addresses,
              vaddr_word is a word type of same width as virtual addresses

  The addr_t type represents the two different types of addresses, even if
  their underlying widths are the same.
  Its parameters are the address size (such as "32 word") and the address
  type (physical or virtual).
\<close>
typedecl physical
typedecl virtual
datatype ('a, 'p) addr_t = Addr 'a

text \<open>
  Similarly to addr_t, we have pointers pointing to values of a specific
  type. This type is denoted with an extra phantom type ('t).
  A typed pointer contains an addr_t.
\<close>
datatype ('a, 'p, 't) ptr_t = Ptr "('a,'p) addr_t"

text \<open>NULL pointer (mostly used in C)\<close>
definition
  NULL :: "('a::zero, 'p, 't) ptr_t" where
  "NULL \<equiv> Ptr (Addr 0)"

text \<open>Extraction of values/addresses from addresses/pointers.\<close>

fun
  addr_val :: "('a, 'p) addr_t \<Rightarrow> 'a" where
  "addr_val (Addr a) = a"
fun
  ptr_val :: "('a, 'p, 't) ptr_t \<Rightarrow> ('a,'p) addr_t" where
  "ptr_val (Ptr a) = a"

text \<open>
  Extracting the address from a pointer contained within a typed pointer\<close>
definition
  "ptr_addr x \<equiv> addr_val (ptr_val x)"

lemma addr_split:
  "P (addr_val x) = (\<forall>y. x = Addr y \<longrightarrow> P y)"
  by (cases x, auto)

lemma addr_split_asm:
  "P (addr_val x) = (\<not>(\<exists>y. x = Addr y \<and> \<not> P y))"
  by (cases x, auto)

lemma Addr_addr_val [simp]: "Addr (addr_val i) = i"
  by (case_tac i, simp)

lemma Ptr_ptr_val [simp]: "Ptr (ptr_val i) = i"
  by (case_tac i, simp)

lemma ptr_split:
  "P (ptr_val x) = (\<forall>y. x = Ptr y \<longrightarrow> P y)"
  by (cases x, auto)

lemma ptr_split_asm:
  "P (ptr_val x) = (\<not>(\<exists>y. x = Ptr y \<and> \<not> P y))"
  by (cases x, auto)

lemmas addr_splits = addr_split addr_split_asm
lemmas ptr_splits = addr_splits ptr_split ptr_split_asm

section \<open>Pointer Manipulation\<close>

text \<open>Type coertion / casting\<close>
fun
  ptr_coerce :: "('a,'p,'t) ptr_t \<Rightarrow> ('a,'p,'t2) ptr_t" where
  "ptr_coerce (Ptr p) = Ptr p"

text \<open>
  Addition of an offset to an address. Note: adding two addresses makes
  no sense.\<close>
definition
  addr_add :: "('a::semiring_1,'p) addr_t \<Rightarrow> 'a \<Rightarrow> ('a,'p) addr_t" (infixl "r+" 65)
  where
  "a r+ x \<equiv> Addr (addr_val a + x)"

notation (latex output)
  addr_add (infixl "+" 65)

lemma addr_add_add [simp]:
  fixes a :: "('a::semiring_1, 'p) addr_t"
  shows "a r+ x r+ y = a r+ (x+y)"
  by (cases a, clarsimp simp: addr_add_def field_simps)

lemma addr_addr_add [simp]:
  fixes a :: "'a::semiring_1"
  shows "Addr a r+ x = Addr (a + x)"
  by (simp add: addr_add_def field_simps)

text \<open>Subtraction of an offset from an address.\<close>
definition
  addr_sub :: "('a::minus,'p) addr_t \<Rightarrow> 'a \<Rightarrow> ('a,'p) addr_t" (infixl "r-" 65)
  where
  "a r- x \<equiv> Addr (addr_val a - x)"

notation (latex output)
  addr_sub (infixl "-" 65)

lemma addr_sub_sub [simp]:
  fixes a :: "('a::ring, 'p) addr_t"
  shows "a r- x r- y = a r- (x+y)"
  by (cases a, clarsimp simp: addr_sub_def)

lemma addr_addr_sub [simp]:
  fixes a :: "'a::ring"
  shows "Addr a r- x = Addr (a - x)"
  by (simp add: addr_sub_def)

text \<open>
  A sequence of addresses of length n starting at a specific offset.
  Wrapping permitted.\<close>
primrec
  addr_seq :: "('a::semiring_1,'p) addr_t \<Rightarrow> nat \<Rightarrow> ('a,'p) addr_t list"
where
  "addr_seq p 0 = []" |
  "addr_seq p (Suc n) = p # (addr_seq (p r+ 1) n)"

lemma addr_seq_length [simp]:
  fixes p :: "('a::semiring_1,'b) addr_t"
  shows "length (addr_seq p sz) = sz"
  by (induct sz arbitrary: p, auto)

text \<open>Ordering of addresses/pointers\<close>

instantiation addr_t :: (ord,type) ord
begin
definition
  addr_less: "x < y \<equiv> addr_val x < addr_val y"
definition
  addr_le: "x \<le> y \<equiv> addr_val x \<le> addr_val y"
instance ..
end

instantiation ptr_t :: (ord,type,type) ord
begin
definition
  ptr_less: "x < y \<equiv> ptr_val x < ptr_val y"
definition
  ptr_le: "x \<le> y \<equiv> ptr_val x \<le> ptr_val y"
instance ..
end

instance addr_t :: (order,type) order
  by (intro_classes,
      auto simp: addr_le addr_less order_less_le split: ptr_splits)

instance addr_t :: (linorder,type) linorder
  by (intro_classes,
      simp add: addr_le linorder_linear split: ptr_splits)

instance ptr_t :: (order,type,type) order
  by (intro_classes,
      auto simp: ptr_le ptr_less order_less_le split: ptr_splits)

instance ptr_t :: (linorder,type,type) linorder
  by (intro_classes,
      simp add: ptr_le linorder_linear split: ptr_splits)

lemma Addr_le[simp]: "(Addr x \<le> Addr y) = (x \<le> y)"
  by (simp add: addr_le split: ptr_splits)

lemma Ptr_le[simp]: "(Ptr x \<le> Ptr y) = (x \<le> y)"
  by (simp add: ptr_le split: ptr_splits)

lemma Addr_less[simp]: "(Addr x < Addr y) = (x < y)"
  by (simp add: addr_less split: ptr_splits)
lemma Ptr_less[simp]: "(Ptr x < Ptr y) = (x < y)"
  by (simp add: ptr_less split: ptr_splits)

text \<open>Finiteness of pointer sets\<close>

lemma addr_t_UNIV: "(UNIV::('a,'p) addr_t set) = Addr ` UNIV"
  by (rule set_eqI, case_tac x, auto)
lemma ptr_t_UNIV: "(UNIV::('a,'p,'t) ptr_t set) = Ptr ` UNIV"
  by (rule set_eqI, case_tac x, auto)

instance addr_t :: (finite,type) finite
  by (intro_classes, simp add: addr_t_UNIV)

instance ptr_t :: (finite,type,type) finite
  by (intro_classes, simp add: ptr_t_UNIV)

text \<open>Misc\<close>

lemma addr_img[simp]: "(Addr x \<in> Addr ` xs) = (x \<in> xs)" by auto
lemma ptr_img[simp]: "(Ptr x \<in> Ptr ` xs) = (x \<in> xs)" by auto

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section \<open>\isaheader{Map Implementation by Association Lists with explicit invariants}\<close>
theory ListMapImpl_Invar
imports
  "../spec/MapSpec"
  "../../Lib/Assoc_List"
  "../gen_algo/MapGA"
begin
text_raw \<open>\label{thy:ListMapImpl_Invar}\<close>

(*@impl Map
  @type 'a lmi
  @abbrv lmi,l
  Maps implemented by associative lists. Version with explicit
  invariants that allows for efficient xxx-dj operations.
*)

type_synonym ('k,'v) lmi = "('k\<times>'v) list"

term revg

definition "lmi_\<alpha> \<equiv> Map.map_of"
definition "lmi_invar \<equiv> \<lambda>m. distinct (List.map fst m)"

definition lmi_basic_ops :: "('k,'v,('k,'v) lmi) map_basic_ops"
  where [icf_rec_def]: "lmi_basic_ops \<equiv> \<lparr>
  bmap_op_\<alpha> = lmi_\<alpha>,
  bmap_op_invar = lmi_invar,
  bmap_op_empty = (\<lambda>_::unit. []),
  bmap_op_lookup = (\<lambda>k m. Map.map_of m k),
  bmap_op_update = AList.update,
  bmap_op_update_dj = (\<lambda>k v m. (k, v) # m),
  bmap_op_delete = AList.delete_aux,
  bmap_op_list_it = foldli
\<rparr>"

setup Locale_Code.open_block
interpretation lmi_basic: StdBasicMapDefs lmi_basic_ops .
interpretation lmi_basic: StdBasicMap lmi_basic_ops
  unfolding lmi_basic_ops_def
  apply unfold_locales
  apply (simp_all
    add: icf_rec_unf lmi_\<alpha>_def lmi_invar_def
    add: AList.update_conv' AList.distinct_update AList.map_of_delete_aux'
      map_iterator_foldli_correct dom_map_of_conv_image_fst map_upd_eq_restrict
  )
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lmi_ops \<equiv> lmi_basic.dflt_ops \<lparr>
  map_op_add_dj := revg,
  map_op_to_list := id,
  map_op_size := length,
  map_op_isEmpty := case_list True (\<lambda>_ _. False),
  map_op_isSng := (\<lambda>l. case l of [_] \<Rightarrow> True | _ \<Rightarrow> False)
\<rparr>"

setup Locale_Code.open_block
interpretation lmi: StdMapDefs lmi_ops .
interpretation lmi: StdMap lmi_ops
proof -
  interpret aux: StdMap lmi_basic.dflt_ops by (rule lmi_basic.dflt_ops_impl)

  have [simp]: "map_add_dj lmi_\<alpha> lmi_invar revg"
    apply (unfold_locales)
    apply (auto simp: lmi_\<alpha>_def lmi_invar_def)
    apply (blast intro: map_add_comm)
    apply (simp add: rev_map[symmetric])
    apply fastforce
    done

  have [simp]: "map_to_list lmi_\<alpha> lmi_invar id"
    apply unfold_locales
    by (simp_all add: lmi_\<alpha>_def lmi_invar_def)

  have [simp]: "map_isEmpty lmi_\<alpha> lmi_invar (case_list True (\<lambda>_ _. False))"
    apply unfold_locales
    unfolding lmi_\<alpha>_def lmi_invar_def
    by (simp split: list.split)

  have [simp]: "map_isSng lmi_\<alpha> lmi_invar
     (\<lambda>l. case l of [_] \<Rightarrow> True | _ \<Rightarrow> False)"
    apply unfold_locales
    unfolding lmi_\<alpha>_def lmi_invar_def
    apply (auto split: list.split)
    apply (metis (no_types) map_upd_nonempty)
    by (metis fun_upd_other fun_upd_same option.simps(3))

  have [simp]: "map_size_axioms lmi_\<alpha> lmi_invar length"
    apply unfold_locales
    unfolding lmi_\<alpha>_def lmi_invar_def
    by (metis card_dom_map_of)

  show "StdMap lmi_ops"
    unfolding lmi_ops_def
    apply (rule StdMap_intro)
    apply (simp_all)
    apply intro_locales
    apply (simp_all add: icf_rec_unf)
    done
qed
setup Locale_Code.close_block

setup \<open>ICF_Tools.revert_abbrevs "lmi"\<close>

lemma pi_lmi[proper_it]:
  "proper_it' foldli foldli"
  by (intro proper_it'I icf_proper_iteratorI)

interpretation pi_lmi: proper_it_loc foldli foldli
  apply unfold_locales
  apply (rule pi_lmi)
  done

definition lmi_from_list_dj :: "('k\<times>'v) list \<Rightarrow> ('k,'v) lmi" where
  "lmi_from_list_dj \<equiv> id"

lemma lmi_from_list_dj_correct:
  assumes [simp]: "distinct (map fst l)"
  shows "lmi.\<alpha> (lmi_from_list_dj l) = map_of l"
        "lmi.invar (lmi_from_list_dj l)"
  by (auto simp add: lmi_from_list_dj_def icf_rec_unf lmi_\<alpha>_def lmi_invar_def)

text \<open>Code generator test\<close>
definition "test_codegen \<equiv> (
  lmi.add ,
  lmi.add_dj ,
  lmi.ball ,
  lmi.bex ,
  lmi.delete ,
  lmi.empty ,
  lmi.isEmpty ,
  lmi.isSng ,
  lmi.iterate ,
  lmi.iteratei ,
  lmi.list_it ,
  lmi.lookup ,
  lmi.restrict ,
  lmi.sel ,
  lmi.size ,
  lmi.size_abort ,
  lmi.sng ,
  lmi.to_list ,
  lmi.to_map ,
  lmi.update ,
  lmi.update_dj,
  lmi_from_list_dj
  )"

export_code test_codegen checking SML

end


section \<open>Singly Linked List Segments\<close>
theory List_Seg
imports "../Sep_Main"
begin

subsection \<open>Nodes\<close>
text \<open>
  We define a node of a list to contain a data value and a next pointer.
  As Imperative HOL does not support null-pointers, we make the next-pointer
  an optional value, \<open>None\<close> representing a null pointer.

  Unfortunately, Imperative HOL requires some boilerplate code to define
  a datatype.
\<close>
setup \<open>Sign.add_const_constraint
  (@{const_name Ref}, SOME @{typ "nat \<Rightarrow> 'a::type ref"})\<close>

datatype 'a node = Node "'a" "'a node ref option"

setup \<open>Sign.add_const_constraint
  (@{const_name Ref}, SOME @{typ "nat \<Rightarrow> 'a::heap ref"})\<close>

setup \<open>Sign.add_const_constraint (@{const_name Node},
  SOME @{typ "'a::heap \<Rightarrow> 'a node ref option \<Rightarrow> 'a node"})\<close>

text \<open>Selector Functions\<close>
primrec val :: "'a::heap node \<Rightarrow> 'a" where
  [sep_dflt_simps]: "val (Node x _) = x"

primrec "next" :: "'a::heap node \<Rightarrow> 'a node ref option" where
  [sep_dflt_simps]: "next (Node _ r) = r"

text \<open>Encoding to natural numbers, as required by Imperative/HOL\<close>
fun
  node_encode :: "'a::heap node \<Rightarrow> nat"
where
  "node_encode (Node x r) = to_nat (x, r)"

instance node :: (heap) heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "node_encode"])
  apply (case_tac x, simp_all, case_tac y, simp_all)
  ..

subsection \<open>List Segment Assertion\<close>
text \<open>
  Intuitively, \<open>lseg l p s\<close> describes a list starting at \<open>p\<close> and
  ending with a pointer \<open>s\<close>. The content of the list are \<open>l\<close>.
  Note that the pointer \<open>s\<close> may also occur earlier in the list, in which
  case it is handled as a usual next-pointer.
\<close>
fun lseg
  :: "'a::heap list \<Rightarrow> 'a node ref option \<Rightarrow> 'a node ref option \<Rightarrow> assn"
  where
  "lseg [] p s = \<up>(p=s)"
| "lseg (x#l) (Some p) s = (\<exists>\<^sub>Aq. p \<mapsto>\<^sub>r Node x q * lseg l q s)"
| "lseg (_#_) None _ = false"

lemma lseg_if_splitf1[simp, sep_dflt_simps]:
  "lseg l None None = \<up>(l=[])"
  apply (cases l, simp_all)
  done

lemma lseg_if_splitf2[simp, sep_dflt_simps]:
  "lseg (x#xs) p q
    = (\<exists>\<^sub>App n. pp \<mapsto>\<^sub>r (Node x n) * lseg xs n q * \<up>(p=Some pp))"
  apply (cases p, simp_all)
  (* TODO: One-point simproc for assertions! *)
  apply (rule ent_iffI)
  apply solve_entails
  apply solve_entails
  done

subsection \<open>Lemmas\<close>

subsubsection \<open>Concatenation\<close>
lemma lseg_prepend:
  "p\<mapsto>\<^sub>rNode x q * lseg l q s \<Longrightarrow>\<^sub>A lseg (x#l) (Some p) s"
  by sep_auto

lemma lseg_append:
  "lseg l p (Some s) * s\<mapsto>\<^sub>rNode x q \<Longrightarrow>\<^sub>A lseg (l@[x]) p q"
proof (induction l arbitrary: p)
  case Nil thus ?case by sep_auto
next
  case (Cons y l)
  show ?case
    apply (cases p)
    apply simp
    apply (sep_auto)
    apply (rule ent_frame_fwd[OF Cons.IH])
    apply frame_inference
    apply solve_entails
    done
qed

lemma lseg_conc: "lseg l1 p q * lseg l2 q r \<Longrightarrow>\<^sub>A lseg (l1@l2) p r"
proof (induct l1 arbitrary: p)
  case Nil thus ?case by simp
next
  case (Cons x l1)
  show ?case
    apply simp
    apply sep_auto
    apply (rule ent_frame_fwd[OF Cons.hyps])
    apply frame_inference
    apply solve_entails
    done
qed

subsubsection \<open>Splitting\<close>
lemma lseg_split:
  "lseg (l1@l2) p r \<Longrightarrow>\<^sub>A \<exists>\<^sub>Aq. lseg l1 p q * lseg l2 q r"
proof (induct l1 arbitrary: p)
  case Nil thus ?case by sep_auto
next
  case (Cons x l1)

  have "lseg ((x # l1) @ l2) p r
    \<Longrightarrow>\<^sub>A \<exists>\<^sub>App n. pp \<mapsto>\<^sub>r Node x n * lseg (l1 @ l2) n r * \<up> (p = Some pp)"
    by simp
  also have "\<dots> \<Longrightarrow>\<^sub>A
    \<exists>\<^sub>App n q. pp \<mapsto>\<^sub>r Node x n
      * lseg l1 n q
      * lseg l2 q r
      * \<up>(p = Some pp)"
    apply (intro ent_ex_preI)
    apply clarsimp
    apply (rule ent_frame_fwd[OF Cons.hyps])
    apply frame_inference
    apply sep_auto
    done
  also have "\<dots> \<Longrightarrow>\<^sub>A \<exists>\<^sub>Aq. lseg (x#l1) p q * lseg l2 q r"
    by sep_auto
  finally show ?case .
qed

subsubsection \<open>Precision\<close>
lemma lseg_prec1:
  "\<forall>l l'. (h\<Turnstile>
      (lseg l p (Some q) * q \<mapsto>\<^sub>r x * F1)
       \<and>\<^sub>A (lseg l' p (Some q) * q \<mapsto>\<^sub>r x * F2))
    \<longrightarrow> l=l'"
  apply (intro allI)
  subgoal for l l'
  proof (induct l arbitrary: p l' F1 F2)
    case Nil thus ?case
      apply simp_all
      apply (cases l')
      apply simp
      apply auto
      done
  next
    case (Cons y l)
    from Cons.prems show ?case
      apply (cases l')
      apply auto []
      apply (cases p)
      apply simp

      apply (clarsimp)

      apply (subgoal_tac "y=a \<and> na=n", simp)

      using Cons.hyps apply (erule prec_frame')
      apply frame_inference
      apply frame_inference

      apply (drule_tac p=aa in prec_frame[OF sngr_prec])
      apply frame_inference
      apply frame_inference
      apply simp
      done
  qed
  done

lemma lseg_prec2:
  "\<forall>l l'. (h\<Turnstile>
      (lseg l p None * F1) \<and>\<^sub>A (lseg l' p None * F2))
    \<longrightarrow> l=l'"
  apply (intro allI)
  subgoal for l l'
  proof (induct l arbitrary: p l' F1 F2)
    case Nil thus ?case
      apply simp_all
      apply (cases l')
      apply simp
      apply (cases p)
      apply auto
      done
  next
    case (Cons y l)
    from Cons.prems show ?case
      apply (cases p)
      apply simp
      apply (cases l')
      apply (auto) []

      apply (clarsimp)

      apply (subgoal_tac "y=aa \<and> na=n", simp)

      using Cons.hyps apply (erule prec_frame')
      apply frame_inference
      apply frame_inference

      apply (drule_tac p=a in prec_frame[OF sngr_prec])
      apply frame_inference
      apply frame_inference
      apply simp
      done
  qed
  done

lemma lseg_prec3:
  "\<forall>q q'. h \<Turnstile> (lseg l p q * F1) \<and>\<^sub>A (lseg l p q' * F2) \<longrightarrow> q=q'"
  apply (intro allI)
proof (induct l arbitrary: p F1 F2)
  case Nil thus ?case by auto
next
  case (Cons x l)
  show ?case
    apply auto

    apply (subgoal_tac "na=n")
    using Cons.hyps apply (erule prec_frame')
    apply frame_inference
    apply frame_inference

    apply (drule prec_frame[OF sngr_prec])
    apply frame_inference
    apply frame_inference
    apply simp
    done
qed

end


theory Homogeneity
imports   "Compositional_Structures/Basic_Modules/Scoring_Module"
          "Compositional_Structures/Elect_Composition"
          "Compositional_Structures/Basic_Modules/Condorcet_Module"
begin
(***Homogeneity***)

lemma homogeneity_elim:
  assumes "\<forall>A p n. finite_profile A p \<and> 0 < n \<longrightarrow>
      elimination_module e t r A p = elimination_module e t r A (times n p)"
shows "homogeneity (elimination_module e t r)" using homogeneity_def assms
proof-
  have "electoral_module (elimination_module e t r)" by simp
  then show ?thesis using assms
    using homogeneity_def by blast
qed

lemma homogeneity_elim_set:
  assumes "\<forall>A p n. finite_profile A p \<and> 0 < n \<longrightarrow>
      elimination_set e t r A p = elimination_set e t r A (times n p)"
shows "\<forall>A p n. finite_profile A p \<and> 0 < n \<longrightarrow>
      elimination_module e t r A p = elimination_module e t r A (times n p)"
  using assms by fastforce

(*In the eval_func_homogeneity lemma we needed the condition from this lemma, but
Isabelle did not accept it through an assumed statement directly in the lemma*)

lemma times_eval:
  shows "((e::'a Evaluation_Function) x A (times n p)) = e x A  p * n"
  sorry

(*Proof that a natural number k can be pulled out of the Max condition*)
lemma pull_numb_out_of_max:
  fixes k::nat and e::"'a Evaluation_Function"
  assumes "finite A" and "A \<noteq> {}"
  shows "Max {e x A p * k |x. x\<in>A} = Max {e x A p|x. x\<in>A} * k"
proof-
  have m: "\<And>x y. max x y * k = max (x*k) (y*k)"
    by(simp add: max_def antisym add_right_mono)
  have "{e x A p * k|x. x\<in>A} = (\<lambda>y. y * k) ` {e x A p|x. x\<in>A}" by auto
  also have "Max \<dots> = Max {e x A p|x. x\<in>A} * k"
    using assms hom_Max_commute [of "\<lambda>y. y*k" "{e x A p|x. x\<in>A}", OF m, symmetric] by simp
  finally show ?thesis by simp
qed

(*If the elim_set is equal than is also max_elim equal*)
lemma max_value_same:
  assumes "\<forall>A p n. finite_profile A p \<and> 0 < n \<longrightarrow>
       elimination_set eval_func (Max {eval_func x A p |x. x \<in> A}) (<) A p =
       elimination_set eval_func (Max {eval_func x A (Electoral_Module.times n p) |x. x \<in> A})
       (<) A (Electoral_Module.times n p)"
  shows"(\<forall>A p n. finite_profile A p \<and> 0 < n \<longrightarrow>
        max_eliminator eval_func A p = max_eliminator eval_func A (Electoral_Module.times n p))"
  unfolding max_eliminator.simps less_eliminator.simps elimination_module.simps using assms
  by fastforce

(*if max value is bigger for p than also for n*p *)
lemma from_eval_follows_eval_n:
  fixes e::"'a Evaluation_Function"
  assumes "x \<in> A" and "xb \<in> A" and "finite A" and "profile A p" and "0 < n" and
    "e xb A p < Max {e x A p |x. x \<in> A}"
  shows "e xb A (times n p) < Max {e x A (times n p) |x. x \<in> A}"
proof-
  have 0 :"Max {e x A (times n p) |x. x \<in> A} =
        Max {e x A p * n |x. x \<in> A}"
      using times_eval by metis
  then have 1:  "Max {e x A (times n p) |x. x \<in> A} =
      n* Max {e x A p |x. x \<in> A}"
  proof -
     have "\<And>A rs n. infinite A \<or> A = Collect bot \<or>
        Max {e (a::'a) A rs |a. a \<in> A} * n = Max {e a A rs * n |a. a \<in> A}"
      using pull_numb_out_of_max bot_set_def assms by fastforce
    then have f5: "\<And>rs n. Max {e a A rs |a. a \<in> A} * n =
              Max {e a A rs * n |a. a \<in> A}"
      using assms(1) assms(3) by blast
    have
      "Max {e a A (times n p) |a. a \<in> A} = Max {e a A p * n |a. a \<in> A}"
      using assms 0 by clarify
    then show "Max {e a A (times n p) |a. a \<in> A} =
          n * Max {e a A p |a. a \<in> A}"
      using f5 by (simp add: mult.commute)
  qed
  have 2:"e xb A p < Max {e x A p |x. x \<in> A} \<Longrightarrow>
            n* e xb A p < n* Max {e x A p |x. x \<in> A}"
    using assms(5) mult_less_mono2 by blast
  then have 3: "n* e xb A p < n* Max {e x A p |x. x \<in> A} \<Longrightarrow>
    e xb A (times n p) <
    Max {e x A (times n p) |x. x \<in> A}"
    by (metis (mono_tags, lifting) "1" mult.commute times_eval)
  then show "e xb A (times n p) <
    Max {e x A (times n p) |x. x \<in> A}"
    using 2 assms by auto
qed

(*if max value is bigger for n*p than also for p *)
lemma from_eval_n_follows_eval:
  fixes e::"'a Evaluation_Function"
  assumes "x \<in> A" and "finite A" and "profile A p" and "0 < n" and "xa \<in> A" and "xb \<in> A" and
  "e xb A (times n p) < Max {e x A (times n p) |x. x \<in> A}"
shows "e xb A p < Max {e x A p |x. x \<in> A}"
proof-
    have 0 :"Max {e x A (times n p) |x. x \<in> A} =
        Max {e x A p * n |x. x \<in> A}"
      using times_eval by metis
  then have 1: "Max {e x A (times n p) |x. x \<in> A} =
      n* Max {e x A p |x. x \<in> A}"
  proof -
    have "\<And>A rs n. infinite A \<or> A = Collect bot \<or>
        Max {e (a::'a) A rs |a. a \<in> A} * n = Max {e a A rs * n |a. a \<in> A}"
      using pull_numb_out_of_max bot_set_def by fastforce
    then have f5: "\<And>rs n. Max {e a A rs |a. a \<in> A} * n =
              Max {e a A rs * n |a. a \<in> A}"
      using assms(1) assms(2) by blast
    have
      "Max {e a A (times n p) |a. a \<in> A} = Max {e a A p * n |a. a \<in> A}"
      using assms 0 by clarify
    then show "Max {e a A (times n p) |a. a \<in> A} =
          n * Max {e a A p |a. a \<in> A}"
      using f5 by (simp add: mult.commute)
  qed
  have 2:"e xb A p < Max {e x A p |x. x \<in> A} \<Longrightarrow>
            n* e xb A p < n* Max {e x A p |x. x \<in> A}"
    using assms(4) mult_less_mono2 by blast
  then have 3: "n* e xb A p < n* Max {e x A p |x. x \<in> A} \<Longrightarrow>
    e xb A (times n p) < Max {e x A (times n p) |x. x \<in> A}"
    using assms(7) by auto
  then show "e xb A p < Max {e x A p |x. x \<in> A}"
     using 1 2 assms(7) times_eval
     by (metis (no_types, lifting) mult.commute mult_less_cancel2)
qed

lemma eval_func_homogeneity:
  assumes "\<forall>x. eval_func x A (times n p) = eval_func x A p * n"
  shows "homogeneity (max_eliminator eval_func)"
  unfolding homogeneity_def
proof-
  show "electoral_module (max_eliminator eval_func) \<and>
    (\<forall>A p n. finite_profile A p \<and> 0 < n \<longrightarrow> max_eliminator eval_func A p =
    max_eliminator eval_func A (Electoral_Module.times n p))"
  proof-
    have elim_set_same:
          "\<forall>A p n. finite_profile A p \<and> 0 < n \<longrightarrow>
          elimination_set eval_func (Max {eval_func x A p |x. x \<in> A}) (<) A p =
          elimination_set eval_func (Max {eval_func x A (Electoral_Module.times n p) |x. x \<in> A}) (<) A
          (Electoral_Module.times n p)"
      using from_eval_n_follows_eval from_eval_follows_eval_n
      by (smt (z3) Collect_cong elimination_set.simps)
    have elect_mod:"electoral_module (max_eliminator eval_func)" by auto
    have "(\<forall>A p n.
        finite_profile A p \<and> 0 < n \<longrightarrow>
        max_eliminator eval_func A p =
        max_eliminator eval_func A (Electoral_Module.times n p))"
      using  max_value_same elim_set_same by fastforce
    then show ?thesis
      using elect_mod by blast
  qed
qed

(*If two modules are homogenious, that the sequantial module is homogenious*)
lemma seq_hom:
  shows "homogeneity m \<Longrightarrow> homogeneity n \<Longrightarrow> homogeneity (m \<triangleright> n)"
  unfolding homogeneity_def
proof(auto)
  show "\<And>A p na.
       electoral_module m \<Longrightarrow>
       \<forall>A p n. finite A \<and> profile A p \<and> 0 < n \<longrightarrow> m A p = m A (concat (replicate n p)) \<Longrightarrow>
       electoral_module n \<Longrightarrow>
       \<forall>A p na. finite A \<and> profile A p \<and> 0 < na \<longrightarrow> n A p = n A (concat (replicate na p)) \<Longrightarrow>
       finite A \<Longrightarrow>
       profile A p \<Longrightarrow>
       0 < na \<Longrightarrow>
       (let new_A = defer m A (concat (replicate na p)); new_p = map (limit new_A) p
        in (elect m A (concat (replicate na p)) \<union> elect n new_A new_p,
            reject m A (concat (replicate na p)) \<union> reject n new_A new_p, defer n new_A new_p)) =
       (let new_A = defer m A (concat (replicate na p)); new_p =
          map (limit new_A) (concat (replicate na p))
        in (elect m A (concat (replicate na p)) \<union> elect n new_A new_p,
            reject m A (concat (replicate na p)) \<union> reject n new_A new_p, defer n new_A new_p))"
    by (smt (z3) def_presv_fin_prof limit_profile.simps map_concat map_replicate)
qed

(*elector module satisfies homogeneity*)
lemma elector_homogeneity:
  shows "homogeneity m \<Longrightarrow> homogeneity (elector m)"
proof(simp)
  have "homogeneity elect_module"
    by (simp add: homogeneity_def)
  then show "homogeneity m \<Longrightarrow> homogeneity (m \<triangleright> elect_module)" using seq_hom by auto
qed