(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_nat_lt_asymmetric
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun lt :: "Nat => Nat => bool" where
"lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S n) (S z) = lt n z"

theorem property0 :
  "((lt x y) ==> (~ (lt y x)))"
  oops

end


theory goal
  imports processDef invGen
begin

(*The safety property to prove.*)
definition safeProp :: fform where
"safeProp == (plant_v1_1 [+](Real 2)) [<] (Real 0.05) [&] (plant_v1_1 [+] (Real 2)) [>] (Real -0.05)"

(*The system clock is always positive.*)
axiomatization where
Clock : "\<forall> s. (t [\<ge>] Real 0) s"

(*The following lists the constraints for solving the differential invariants for the
differential equations.*)
(*The invariant guarantees the postcondition.*)
definition cons1 :: fform where
"cons1 \<equiv> ((t [\<ge>]Real 0 [&] t [\<le>] Real 0.128 [&] Inv) [\<longrightarrow>]  safeProp)"
(*Initialization:the initial state guarantees the invariant;
and Computation: the computation guarantees the invariant.*)
definition cons2 :: fform where
"cons2 \<equiv> ((plant_v1_1[=](Real -2) [&] plant_m1_1[=](Real 1250)
    [&] control_1[=](Real (4055/2)) [&] t[=](Real 0)) [\<longrightarrow>] Inv)"
(*The core parts: the discrete computation and differential equations garantee the invariants. *)
definition cons31 :: fform where
"cons31 == (((t [=](Real (16 / 125))) [&] Inv) [\<longrightarrow>] (Inv \<lbrakk>(Real 0), ''plant_t''\<rbrakk>))"

definition cons31_aux :: fform where
"cons31_aux == \<lambda> s. ((t [=]Real (16 / 125) [&] Inv) s \<longrightarrow>
  Inv (\<lambda>y. if y = ''plant_t'' then evalE (Real 0) s else s y))"

definition cons32 :: fform where
"cons32 == (Inv [\<longrightarrow>] (Inv \<lbrakk>(plant_m1_1 [*]
                                   (Real (811 / 500) [-] Real (1 / 100) [*] (control_1 [div] plant_m1_1 [-] Real (811 / 500)) [-]
                                    Real (3 / 5) [*] (plant_v1_1 [+] Real 2))), ''control_1''\<rbrakk>))"

definition cons32_aux :: fform where
"cons32_aux == \<lambda> s. (Inv s \<longrightarrow>
               Inv (\<lambda>y. if y = ''control_1''
                       then (evalE (plant_m1_1 [*]
                                   (Real (811 / 500) [-] Real (1 / 100) [*] (control_1 [div] plant_m1_1 [-] Real (811 / 500)) [-]
                                    Real (3 / 5) [*] (plant_v1_1 [+] Real 2)))
                             s)
                       else s y))"
definition cons4 :: fform where
"cons4 \<equiv>  exeFlow(PC_Diff11) (Inv)  [\<longrightarrow>]  Inv"
definition cons5 :: fform where
"cons5 \<equiv>  exeFlow(PC_Diff22) (Inv)  [\<longrightarrow>]  Inv"

lemma cons31_fact: "cons31 s \<Longrightarrow> cons31_aux s"
  apply (simp add:cons31_def cons31_aux_def fSubForm_def fImp_def)
  done

lemma cons32_fact: "cons32 s \<Longrightarrow> cons32_aux s"
  apply (simp add:cons32_def cons32_aux_def fSubForm_def fImp_def)
  by (metis control_1_def plant_m1_1_def plant_v1_1_def)

(*Put this whole constraint to the differential invariant generator.*)
lemma allCons: "\<forall> s. ( cons1 [&] cons2 [&] cons31 [&] cons32 [&] cons4 [&] cons5) s"
apply (simp add: cons1_def)
apply (simp add: cons2_def cons31_def cons32_def)
apply (simp add: cons4_def)
apply (simp add: cons5_def)
  apply (simp add: safeProp_def)
  apply (simp add:PC_Diff11_def PC_Diff22_def)
apply inv_oracle_SOS
done

(**You can uncomment the above lines, if you have  Mathematica, Matlab, Yalmip and SDPT3 installed. "Sorry" will go away.**)
sorry

lemma constraint11: "\<forall> s. (t [\<ge>] Real 0 [&] t [\<le>] Real (16 / 125) [&] Inv) s \<longrightarrow> safeProp s"
apply (cut_tac allCons)
apply (simp add:cons1_def)
by (metis fAnd_def fImp_def)

lemma constraint1: "\<forall> s. (t [\<le>]Real (16 / 125) [&] Inv) s \<longrightarrow> safeProp s"
apply (cut_tac allCons)
apply (cut_tac Clock)
by (metis constraint11 fAnd_def)

lemma constraint2: "\<forall> s. (plant_v1_1[=](Real -2) [&] plant_m1_1[=](Real 1250)
    [&] control_1[=](Real (4055/2)) [&] t[=](Real 0)) s \<longrightarrow> Inv s"
apply (cut_tac allCons)
apply (simp add:cons2_def)
by (metis fAnd_def fImp_def)

lemma constraint31: "\<forall> s. ((t [=]Real (16 / 125) [&] Inv) s \<longrightarrow> Inv (\<lambda>y. if y = ''plant_t'' then evalE (Real 0) s else s y))"
apply (cut_tac allCons)
  apply (simp add:cons31_def)
proof -
  { fix vv :: "char list \<Rightarrow> real"
    have "cons31_aux vv"
      by (metis allCons cons31_fact fAnd_def)
    then have "\<not> (RVar ''plant_t''[=]Real (16 / 125) [&] Inv) vv \<or> Inv (\<lambda>cs. if cs = ''plant_t'' then evalE (Real 0) vv else vv cs)"
      by (simp add: cons31_aux_def) }
  then show "\<forall>f. (RVar ''plant_t''[=]Real (16 / 125) [&] Inv) f \<longrightarrow> Inv (\<lambda>cs. if cs = ''plant_t'' then evalE (Real 0) f else f cs)"
    by meson
qed

lemma constraint32: "\<forall> s. (Inv s \<longrightarrow>
               Inv (\<lambda>y. if y = ''control_1''
                       then (evalE (plant_m1_1 [*]
                                   (Real (811 / 500) [-] Real (1 / 100) [*] (control_1 [div] plant_m1_1 [-] Real (811 / 500)) [-]
                                    Real (3 / 5) [*] (plant_v1_1 [+] Real 2)))
                             s)
                       else s y))"
  apply (cut_tac allCons)
  apply (simp add:fAnd_def, auto)
  apply (simp add:cons32_def fImp_def fSubForm_def)
  apply (drule_tac x = s in spec, auto)
  by (metis case_prod_conv cond_case_prod_eta control_1_def plant_m1_1_def plant_v1_1_def)

lemma constraint4: "\<forall> s.  exeFlow(PC_Diff11) (Inv) s  \<longrightarrow>  Inv s"
apply (cut_tac allCons)
apply (simp add:cons4_def)
by (metis fAnd_def fImp_def)

lemma constraint5: "\<forall> s.  exeFlow(PC_Diff22) (Inv) s  \<longrightarrow>  Inv s"
apply (cut_tac allCons)
apply (simp add:cons5_def)
by (metis fAnd_def fImp_def)

declare elE_def [simp del]

lemma factLess: "(RVar x [\<le>] Real r) s \<Longrightarrow>
  (RVar x [\<ge>] Real r) s \<Longrightarrow>  (RVar x [=] Real r) s"
  by (simp add:fLessEqual_def fGreaterEqual_def fLess_def fEqual_def fOr_def)

(*Goal for the whole process.*)
lemma goal : "{fTrue} PP {safeProp; (elE 0 [[|]] (almost safeProp))}"
(*mono*)
apply (cut_tac px="fTrue" and qx="t [\<le>] Real (16 / 125) [&] Inv" and Hx="(elE 0 [[|]] (almost (t [\<le>] Real (16 / 125) [&] Inv)))" in ConsequenceRule, auto)
prefer 2
apply (cut_tac constraint1, auto)
prefer 2
apply (cut_tac constraint1, auto)
apply (simp add:dOr_def almost_def, auto)
apply (simp add:PP_def PC_Init_def PD_Init_def)
(*separate into intialization and repetitive control*)
apply (cut_tac m = "((plant_v1_1[=](Real -2)) [&] (plant_m1_1[=](Real 1250)) [&] (control_1[=](Real 2027.5)) [&] (t[=](Real 0)))"
           and  H = "elE 0"  and  G="(elE 0 [[|]] (almost (t [\<le>] Real (16 / 125) [&] Inv)))"  in SequentialRule, auto)
(*Init*)
apply (cut_tac m = "((plant_v1_1[=] (Real -2)) [&] (plant_m1_1[=] (Real 1250)))"
     and  H = "elE 0"  and  G = "elE 0" in SequentialRule, auto)
apply (cut_tac m = "plant_v1_1[=]Real - 2"  and  H = "elE 0" and  G = "elE 0" in SequentialRule, auto)
apply (rule AssignRRule, auto) apply (simp add:fEqual_def)
apply (cut_tac m = "plant_v1_1[=]Real - 2 [&] plant_m1_1[=]Real 1250"
   and  H = "elE 0" and  G = "elE 0" in SequentialRule, auto)
apply (rule AssignRRule, auto) apply (simp add:fAnd_def fEqual_def)
apply (rule AssignRRule, auto) apply (simp add:fAnd_def fEqual_def)
apply (simp add:elE_def chop_def)+
apply (cut_tac m = "((plant_v1_1[=](Real -2)) [&] (plant_m1_1[=](Real 1250)) [&] (control_1[=](Real 2027.5)))"
           and  H = "elE 0" and  G = "elE 0" in SequentialRule, auto)
apply (rule AssignRRule, auto) apply (simp add:fAnd_def fEqual_def)
apply (rule AssignRRule, auto) apply (simp add:fAnd_def fEqual_def)
apply (simp add:elE_def chop_def)+
prefer 2
apply (simp add:elE_def dOr_def chop_def)
(*Rep Part*)
apply (cut_tac px="Inv [&] t[=](Real 0) [&] t [\<le>] Real (16 / 125)" and qx="Inv [&] t[=](Real 0) [&] t [\<le>] Real (16 / 125)" and Hx="(elE 0 [[|]] (almost (t [\<le>] Real (16 / 125) [&] Inv)))" in ConsequenceRule,auto)
prefer 2
apply (cut_tac constraint2, auto) apply (simp add:fAnd_def fLessEqual_def fOr_def fLess_def fEqual_def)
prefer 2
apply (simp add:fAnd_def fLessEqual_def fOr_def fLess_def)
prefer 2
apply (simp add:elE_def dOr_def)
apply (simp add:Inv3_def)
apply (cut_tac I = "Inv [&] RVar ''plant_t''[=]Real 0 [&]
     RVar ''plant_t''[\<le>]Real (16 / 125)" and
     P = "(PC_Difff; (RVar ''plant_t'') := (Real 0); PD_Rep)" and
  H = "elE 0 [[|]] almost (RVar ''plant_t''[\<le>]Real (16 / 125) [&] Inv)" in RepetitionRule_a, auto)
apply (cut_tac P = "(RVar ''plant_t''[\<le>]Real (16 / 125) [&] Inv)"
      and h = h and n = n and nd = m in chopfor, auto)
prefer 2
apply (cut_tac px = "Inv [&] RVar ''plant_t''[=]Real 0 [&]
     RVar ''plant_t''[\<le>]Real (16 /125)" and
     qx = "Inv [&] RVar ''plant_t''[=]Real 0 [&]
           RVar ''plant_t''[\<le>]Real (16 / 125)" and
     Hx = "elE 0 [[|]] (elE 0 [[|]] almost (RVar ''plant_t''[\<le>]Real (16 / 125) [&] Inv))" in ConsequenceRule, auto)
apply (simp add: dOr_def)
apply (cut_tac m = "t [=] Real (16 / 125) [&] Inv" and
    H = "(elE 0 [[|]] (almost (t [\<le>] Real (16 / 125) [&] Inv)))" and
  G= "elE 0" in  SequentialRule, auto)
prefer 2
apply (simp add: PD_Rep_def)
apply (cut_tac m = "t [=] Real 0 [&] Inv" and
    H = "elE 0" and  G= "elE 0" in  SequentialRule, auto)
apply (rule AssignRRule, auto)
apply (cut_tac constraint31, auto)
 apply (simp add:fAnd_def fLessEqual_def fOr_def fLess_def fEqual_def)
apply (rule AssignRRule, auto)
apply (cut_tac constraint32)
 apply (simp add:fAnd_def fLessEqual_def fOr_def fLess_def fEqual_def)
using control_1_def plant_m1_1_def plant_v1_1_def
apply presburger
apply (simp add:elE_def chop_def)
prefer 2
apply (simp add: chop_def elE_def)
(*Plant Part*)
apply (simp add:PC_Difff_def)
apply (rule ConditionGRule, auto)
apply (simp add:PC_Diff11_def Inv1_def)
apply (rule ContinuousRuleGT, auto)
apply (simp add:fLess_def fAnd_def fEqual_def)
apply (simp add:fAnd_def)
apply (simp add:fAnd_def, auto)
apply (cut_tac e = "RVar ''plant_t''" and f = "Real (16 / 125)" in Lessc)
apply (rule factLess, auto)
apply (cut_tac constraint4)
apply (simp add:PC_Diff11_def Inv1_def)
apply (simp add:elE_def dOr_def)
apply (simp add:dOr_def)
apply (simp add:fAnd_def almost_def)
apply (simp add:PC_Diff22_def Inv2_def)
apply (rule ContinuousRuleGT, auto)
apply (simp add:fLess_def fAnd_def fEqual_def)
apply (simp add:fAnd_def)
apply (simp add:fAnd_def, auto)
apply (cut_tac e = "RVar ''plant_t''" and f = "Real (16 / 125)" in Lessc)
apply (rule factLess, auto)
apply (cut_tac constraint5)
apply (simp add:PC_Diff22_def Inv2_def)
apply (simp add:elE_def dOr_def)
apply (simp add:dOr_def)
apply (simp add:fAnd_def almost_def)
done

end


(*<*)
theory simp2 imports Main begin
(*>*)

section{*Simplification*}

text{*\label{sec:simplification-II}\index{simplification|(}
This section describes features not covered until now.  It also
outlines the simplification process itself, which can be helpful
when the simplifier does not do what you expect of it.
*}

subsection{*Advanced Features*}

subsubsection{*Congruence Rules*}

text{*\label{sec:simp-cong}
While simplifying the conclusion $Q$
of $P \Imp Q$, it is legal to use the assumption $P$.
For $\Imp$ this policy is hardwired, but
contextual information can also be made available for other
operators. For example, @{prop"xs = [] --> xs@xs = xs"} simplifies to @{term
True} because we may use @{prop"xs = []"} when simplifying @{prop"xs@xs =
xs"}. The generation of contextual information during simplification is
controlled by so-called \bfindex{congruence rules}. This is the one for
@{text"\<longrightarrow>"}:
@{thm[display]imp_cong[no_vars]}
It should be read as follows:
In order to simplify @{prop"P-->Q"} to @{prop"P'-->Q'"},
simplify @{prop P} to @{prop P'}
and assume @{prop"P'"} when simplifying @{prop Q} to @{prop"Q'"}.

Here are some more examples.  The congruence rules for bounded
quantifiers supply contextual information about the bound variable:
@{thm[display,eta_contract=false,margin=60]ball_cong[no_vars]}
One congruence rule for conditional expressions supplies contextual
information for simplifying the @{text then} and @{text else} cases:
@{thm[display]if_cong[no_vars]}
An alternative congruence rule for conditional expressions
actually \emph{prevents} simplification of some arguments:
@{thm[display]if_weak_cong[no_vars]}
Only the first argument is simplified; the others remain unchanged.
This makes simplification much faster and is faithful to the evaluation
strategy in programming languages, which is why this is the default
congruence rule for @{text "if"}. Analogous rules control the evaluation of
@{text case} expressions.

You can declare your own congruence rules with the attribute \attrdx{cong},
either globally, in the usual manner,
\begin{quote}
\isacommand{declare} \textit{theorem-name} @{text"[cong]"}
\end{quote}
or locally in a @{text"simp"} call by adding the modifier
\begin{quote}
@{text"cong:"} \textit{list of theorem names}
\end{quote}
The effect is reversed by @{text"cong del"} instead of @{text cong}.

\begin{warn}
The congruence rule @{thm[source]conj_cong}
@{thm[display]conj_cong[no_vars]}
\par\noindent
is occasionally useful but is not a default rule; you have to declare it explicitly.
\end{warn}
*}

subsubsection{*Permutative Rewrite Rules*}

text{*
\index{rewrite rules!permutative|bold}%
An equation is a \textbf{permutative rewrite rule} if the left-hand
side and right-hand side are the same up to renaming of variables.  The most
common permutative rule is commutativity: @{prop"x+y = y+x"}.  Other examples
include @{prop"(x-y)-z = (x-z)-y"} in arithmetic and @{prop"insert x (insert
y A) = insert y (insert x A)"} for sets. Such rules are problematic because
once they apply, they can be used forever. The simplifier is aware of this
danger and treats permutative rules by means of a special strategy, called
\bfindex{ordered rewriting}: a permutative rewrite
rule is only applied if the term becomes smaller with respect to a fixed
lexicographic ordering on terms. For example, commutativity rewrites
@{term"b+a"} to @{term"a+b"}, but then stops because @{term"a+b"} is strictly
smaller than @{term"b+a"}.  Permutative rewrite rules can be turned into
simplification rules in the usual manner via the @{text simp} attribute; the
simplifier recognizes their special status automatically.

Permutative rewrite rules are most effective in the case of
associative-commutative functions.  (Associativity by itself is not
permutative.)  When dealing with an AC-function~$f$, keep the
following points in mind:
\begin{itemize}\index{associative-commutative function}

\item The associative law must always be oriented from left to right,
  namely $f(f(x,y),z) = f(x,f(y,z))$.  The opposite orientation, if
  used with commutativity, can lead to nontermination.

\item To complete your set of rewrite rules, you must add not just
  associativity~(A) and commutativity~(C) but also a derived rule, {\bf
    left-com\-mut\-ativ\-ity} (LC): $f(x,f(y,z)) = f(y,f(x,z))$.
\end{itemize}
Ordered rewriting with the combination of A, C, and LC sorts a term
lexicographically:
\[\def\maps#1{~\stackrel{#1}{\leadsto}~}
 f(f(b,c),a) \maps{A} f(b,f(c,a)) \maps{C} f(b,f(a,c)) \maps{LC} f(a,f(b,c)) \]

Note that ordered rewriting for @{text"+"} and @{text"*"} on numbers is rarely
necessary because the built-in arithmetic prover often succeeds without
such tricks.
*}

subsection{*How the Simplifier Works*}

text{*\label{sec:SimpHow}
Roughly speaking, the simplifier proceeds bottom-up: subterms are simplified
first.  A conditional equation is only applied if its condition can be
proved, again by simplification.  Below we explain some special features of
the rewriting process.
*}

subsubsection{*Higher-Order Patterns*}

text{*\index{simplification rule|(}
So far we have pretended the simplifier can deal with arbitrary
rewrite rules. This is not quite true.  For reasons of feasibility,
the simplifier expects the
left-hand side of each rule to be a so-called \emph{higher-order
pattern}~@{cite "nipkow-patterns"}\indexbold{patterns!higher-order}.
This restricts where
unknowns may occur.  Higher-order patterns are terms in $\beta$-normal
form.  (This means there are no subterms of the form $(\lambda x. M)(N)$.)
Each occurrence of an unknown is of the form
$\Var{f}~x@1~\dots~x@n$, where the $x@i$ are distinct bound
variables. Thus all ordinary rewrite rules, where all unknowns are
of base type, for example @{thm add.assoc}, are acceptable: if an unknown is
of base type, it cannot have any arguments. Additionally, the rule
@{text"(\<forall>x. ?P x \<and> ?Q x) = ((\<forall>x. ?P x) \<and> (\<forall>x. ?Q x))"} is also acceptable, in
both directions: all arguments of the unknowns @{text"?P"} and
@{text"?Q"} are distinct bound variables.

If the left-hand side is not a higher-order pattern, all is not lost.
The simplifier will still try to apply the rule provided it
matches directly: without much $\lambda$-calculus hocus
pocus.  For example, @{text"(?f ?x \<in> range ?f) = True"} rewrites
@{term"g a \<in> range g"} to @{const True}, but will fail to match
@{text"g(h b) \<in> range(\<lambda>x. g(h x))"}.  However, you can
eliminate the offending subterms --- those that are not patterns ---
by adding new variables and conditions.
In our example, we eliminate @{text"?f ?x"} and obtain
 @{text"?y =
?f ?x \<Longrightarrow> (?y \<in> range ?f) = True"}, which is fine
as a conditional rewrite rule since conditions can be arbitrary
terms.  However, this trick is not a panacea because the newly
introduced conditions may be hard to solve.

There is no restriction on the form of the right-hand
sides.  They may not contain extraneous term or type variables, though.
*}

subsubsection{*The Preprocessor*}

text{*\label{sec:simp-preprocessor}
When a theorem is declared a simplification rule, it need not be a
conditional equation already.  The simplifier will turn it into a set of
conditional equations automatically.  For example, @{prop"f x =
g x & h x = k x"} becomes the two separate
simplification rules @{prop"f x = g x"} and @{prop"h x = k x"}. In
general, the input theorem is converted as follows:
\begin{eqnarray}
\neg P &\mapsto& P = \hbox{\isa{False}} \nonumber\\
P \longrightarrow Q &\mapsto& P \Longrightarrow Q \nonumber\\
P \land Q &\mapsto& P,\ Q \nonumber\\
\forall x.~P~x &\mapsto& P~\Var{x}\nonumber\\
\forall x \in A.\ P~x &\mapsto& \Var{x} \in A \Longrightarrow P~\Var{x} \nonumber\\
@{text "if"}\ P\ @{text then}\ Q\ @{text else}\ R &\mapsto&
 P \Longrightarrow Q,\ \neg P \Longrightarrow R \nonumber
\end{eqnarray}
Once this conversion process is finished, all remaining non-equations
$P$ are turned into trivial equations $P =\isa{True}$.
For example, the formula
\begin{center}@{prop"(p \<longrightarrow> t=u \<and> ~r) \<and> s"}\end{center}
is converted into the three rules
\begin{center}
@{prop"p \<Longrightarrow> t = u"},\quad  @{prop"p \<Longrightarrow> r = False"},\quad  @{prop"s = True"}.
\end{center}
\index{simplification rule|)}
\index{simplification|)}
*}
(*<*)
end
(*>*)


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_mul3acc_assoc2
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
  "add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
  "mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3acc
            (mul3acc x2 x3 x4)
            (add3acc
               (mul3acc (S Z) x3 x4) (mul3acc x2 (S Z) x4) (mul3acc x2 x3 (S Z)))
            (add3acc (S x2) (S x3) (S x4)))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3acc (mul3acc x1 x2 x3acc) x4 x5) =
      (mul3acc x1 (mul3acc x2 x3acc x4) x5))"
  oops

end


(*  Author:     Tobias Nipkow, 2007  *)

theory Cooper
imports PresArith
begin

subsection{*Cooper*}

text{* This section formalizes Cooper's algorithm~\cite{Cooper72}. *}

lemma set_atoms0_iff:
 "qfree \<phi> \<Longrightarrow> a : set(Z.atoms\<^sub>0 \<phi>) \<longleftrightarrow> a : atoms \<phi> \<and> hd_coeff a \<noteq> 0"
by(induct \<phi>) (auto split:split_if_asm)

definition
"hd_coeffs1 \<phi> =
 (let m = zlcms(map hd_coeff (Z.atoms\<^sub>0 \<phi>))
  in And (Atom(Dvd m 0 [1])) (map\<^bsub>fm\<^esub> (hd_coeff1 m) \<phi>))"

lemma I_hd_coeffs1:
assumes "qfree \<phi>"
shows "(\<exists>x. Z.I (hd_coeffs1 \<phi>) (x#xs)) = (\<exists>x. Z.I \<phi> (x#xs))" (is "?L = ?R")
proof -
  let ?l = "zlcms(map hd_coeff (Z.atoms\<^sub>0 \<phi>))"
  have "?l>0" by(simp add: zlcms_pos set_atoms0_iff[OF `qfree \<phi>`])
  have "?L = (\<exists>x. ?l dvd x+0 \<and> Z.I (map\<^bsub>fm\<^esub> (hd_coeff1 ?l) \<phi>) (x#xs))"
    by(simp add:hd_coeffs1_def)
  also have "\<dots> = (\<exists>x. Z.I (map\<^bsub>fm\<^esub> (hd_coeff1 ?l) \<phi>) (?l*x#xs))"
    by(rule unity_coeff_ex[THEN meta_eq_to_obj_eq,symmetric])
  also have "\<dots> = ?R"
    by(simp add: I_hd_coeff1_mult[OF `?l>0` `qfree \<phi>`] dvd_zlcms)
  finally show ?thesis .
qed

fun min_inf :: "atom fm \<Rightarrow> atom fm" ("inf\<^sub>-") where
"inf\<^sub>- (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (inf\<^sub>- \<phi>\<^sub>1) (inf\<^sub>- \<phi>\<^sub>2)" |
"inf\<^sub>- (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (inf\<^sub>- \<phi>\<^sub>1) (inf\<^sub>- \<phi>\<^sub>2)" |
"inf\<^sub>- (Atom(Le i (k#ks))) =
  (if k<0 then TrueF else if k>0 then FalseF else Atom(Le i (0#ks)))" |
"inf\<^sub>- \<phi> = \<phi>"

definition
"qe_cooper\<^sub>1 \<phi> =
 (let as = Z.atoms\<^sub>0 \<phi>; d = zlcms(map divisor as); ls = lbounds as
  in or (Disj [0..d - 1] (\<lambda>n. subst n [] (inf\<^sub>- \<phi>)))
        (Disj ls (\<lambda>(i,ks).
           Disj [0..d - 1] (\<lambda>n. subst (i + n) (-ks) \<phi>))))"

lemma min_inf:
  "nqfree f \<Longrightarrow> \<forall>a\<in>set(Z.atoms\<^sub>0 f). hd_coeff_is1 a
   \<Longrightarrow> \<exists>x.\<forall>y<x. Z.I (inf\<^sub>- f) (y # xs) = Z.I f (y # xs)"
  (is "_ \<Longrightarrow> _ \<Longrightarrow> \<exists>x. ?P f x")
proof(induct f rule: min_inf.induct)
  case (3 i k ks)
  { assume "k=0" hence ?case using 3 by simp }
  moreover
  { assume "k= -1"
    hence "?P (Atom(Le i (k#ks))) (-i + \<langle>ks,xs\<rangle> - 1)" using 3 by auto
    hence ?case .. }
  moreover
  { assume "k=1"
    hence "?P (Atom(Le i (k#ks))) (i - \<langle>ks,xs\<rangle> - 1)" using 3 by auto
    hence ?case .. }
  ultimately show ?case using 3 by auto
next
  case (1 f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (And f1 f2) (min x1 x2)" by simp
  thus ?case ..
next
  case (2 f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (Or f1 f2) (min x1 x2)" by simp
  thus ?case ..
qed simp_all

lemma min_inf_repeats:
  "nqfree \<phi> \<Longrightarrow> \<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). divisor a dvd d \<Longrightarrow>
  Z.I (inf\<^sub>- \<phi>) ((x - k*d)#xs) = Z.I (inf\<^sub>- \<phi>) (x#xs)"
proof(induct \<phi> rule:min_inf.induct)
  case ("4_4" da i ks)
  show ?case
  proof (cases ks)
    case Nil thus ?thesis by simp
  next
    case (Cons j js)
    show ?thesis
    proof cases
      assume "j=0" thus ?thesis using Cons by simp
    next
      assume "j\<noteq>0"
      hence "da dvd d" using Cons "4_4" by simp
      hence "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
             da dvd i + (j * x + \<langle>js,xs\<rangle>)"
      proof -
        have "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
              da dvd (i + j*x + \<langle>js,xs\<rangle>) - (j*k)*d"
          by(simp add: algebra_simps)
        also have "\<dots> \<longleftrightarrow> da dvd i + j*x + \<langle>js,xs\<rangle>" using `da dvd d`
          by (metis dvd_diff zdvd_zdiffD dvd_mult mult.commute)
        also have "\<dots> \<longleftrightarrow> da dvd i + (j * x + \<langle>js,xs\<rangle>)"
          by(simp add: algebra_simps)
        finally show ?thesis .
      qed
      then show ?thesis using Cons by (simp add:ring_distribs)
    qed
  qed
next
  case ("4_5" da i ks)
  show ?case
  proof (cases ks)
    case Nil thus ?thesis by simp
  next
    case (Cons j js)
    show ?thesis
    proof cases
      assume "j=0" thus ?thesis using Cons by simp
    next
      assume "j\<noteq>0"
      hence "da dvd d" using Cons "4_5" by simp
      hence "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
             da dvd i + (j * x + \<langle>js,xs\<rangle>)"
      proof -
        have "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
              da dvd (i + j*x + \<langle>js,xs\<rangle>) - (j*k)*d"
          by(simp add: algebra_simps)
        also have "\<dots> \<longleftrightarrow> da dvd i + j*x + \<langle>js,xs\<rangle>" using `da dvd d`
          by (metis dvd_diff zdvd_zdiffD dvd_mult mult.commute)
        also have "\<dots> \<longleftrightarrow> da dvd i + (j * x + \<langle>js,xs\<rangle>)"
          by(simp add: algebra_simps)
        finally show ?thesis .
      qed
      then show ?thesis using Cons by (simp add:ring_distribs)
    qed
  qed
qed simp_all

lemma atoms_subset: "qfree f \<Longrightarrow> set(Z.atoms\<^sub>0(f::atom fm)) \<le> atoms f"
by (induct f) auto

(* copied from Amine *)
lemma \<beta>:
  "\<lbrakk> nqfree \<phi>;  \<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). hd_coeff_is1 a;
     \<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). divisor a dvd d; d > 0;
     \<not>(\<exists>j\<in>{0 .. d - 1}. \<exists>(i,ks) \<in> set(lbounds(Z.atoms\<^sub>0 \<phi>)).
         x = i - \<langle>ks,xs\<rangle> + j); Z.I \<phi> (x#xs) \<rbrakk>
  \<Longrightarrow> Z.I \<phi> ((x-d)#xs)"
proof(induct \<phi>)
  case (Atom a)
  show ?case
  proof (cases a)
    case (Le i js)
    show ?thesis
    proof (cases js)
      case Nil thus ?thesis using Le Atom by simp
    next
      case (Cons k ks) thus ?thesis using Le Atom
        by (auto simp:lbounds_def Ball_def split:split_if_asm) arith
    qed
  next
    case (Dvd m i js)
    show ?thesis
    proof (cases js)
      case Nil thus ?thesis using Dvd Atom by simp
    next
      case (Cons k ks)
      show ?thesis
      proof cases
        assume "k=0" thus ?thesis using Cons Dvd Atom by simp
      next
        assume "k\<noteq>0"
        hence "m dvd d" using Cons Dvd Atom by auto
        have "m dvd i + (x + \<langle>ks,xs\<rangle>) \<Longrightarrow> m dvd i + (x - d + \<langle>ks,xs\<rangle>)"
          (is "?L \<Longrightarrow> _")
        proof -
          assume ?L
          hence "m dvd i + (x + \<langle>ks,xs\<rangle>) - d"
            by (metis `m dvd d` dvd_diff)
          thus ?thesis by(simp add:algebra_simps)
        qed
        thus ?thesis using Atom Dvd Cons by(auto split:split_if_asm)
      qed
    qed
  next
    case (NDvd m i js)
    show ?thesis
    proof (cases js)
      case Nil thus ?thesis using NDvd Atom by simp
    next
      case (Cons k ks)
      show ?thesis
      proof cases
        assume "k=0" thus ?thesis using Cons NDvd Atom by simp
      next
        assume "k\<noteq>0"
        hence "m dvd d" using Cons NDvd Atom by auto
        have "m dvd i + (x - d + \<langle>ks,xs\<rangle>) \<Longrightarrow> m dvd i + (x + \<langle>ks,xs\<rangle>)"
          (is "?L \<Longrightarrow> _")
        proof -
          assume ?L
          hence "m dvd i + (x + \<langle>ks,xs\<rangle>) - d" by(simp add:algebra_simps)
          thus ?thesis by (metis `m dvd d` zdvd_zdiffD)
        qed
        thus ?thesis using Atom NDvd Cons by(auto split:split_if_asm)
      qed
    qed
  qed
qed force+

lemma periodic_finite_ex:
  assumes dpos: "(0::int) < d" and modd: "\<forall>x k. P x = P(x - k*d)"
  shows "(\<exists>x. P x) = (\<exists>j\<in>{0..d - 1}. P j)"
  (is "?LHS = ?RHS")
proof
  assume ?LHS
  then obtain x where P: "P x" ..
  have "x mod d = x - (x div d)*d"
    by(simp add:zmod_zdiv_equality ac_simps eq_diff_eq)
  hence Pmod: "P x = P(x mod d)" using modd by simp
  have "P(x mod d)" using dpos P Pmod by simp
  moreover have "x mod d : {0..d - 1}" using dpos by auto
  ultimately show ?RHS ..
qed auto

lemma cpmi_eq: "(0::int) < D \<Longrightarrow> (\<exists>z. \<forall>x. x < z \<longrightarrow> (P x = P1 x))
\<Longrightarrow> \<forall>x.\<not>(\<exists>j\<in>{0..D - 1}. \<exists>b\<in>B. P(b+j)) \<longrightarrow> P (x) \<longrightarrow> P (x - D)
\<Longrightarrow> \<forall>x. \<forall>k. P1 x = P1(x-k*D)
\<Longrightarrow> (\<exists>x. P(x)) = ((\<exists>j\<in>{0..D - 1}. P1(j)) \<or> (\<exists>j\<in>{0..D - 1}. \<exists>b\<in>B. P(b+j)))"
apply(rule iffI)
prefer 2
apply(drule minusinfinity)
apply assumption+
apply(fastforce)
apply clarsimp
apply(subgoal_tac "\<And>k. 0\<le>k \<Longrightarrow> \<forall>x. P x \<longrightarrow> P (x - k*D)")
apply(frule_tac x = x and z=z in decr_lemma)
apply(subgoal_tac "P1(x - (\<bar>x - z\<bar> + 1) * D)")
prefer 2
apply(subgoal_tac "0 \<le> (\<bar>x - z\<bar> + 1)")
prefer 2 apply arith
 apply fastforce
apply(drule (1)  periodic_finite_ex)
apply blast
apply(blast dest:decr_mult_lemma)
done

(* end of Amine *)

lemma qfree_min_inf[simp]: "qfree \<phi> \<Longrightarrow> qfree (inf\<^sub>- \<phi>)"
by (induct \<phi> rule:min_inf.induct) simp_all

lemma I_qe_cooper\<^sub>1:
assumes norm: "\<forall>a\<in>atoms \<phi>. divisor a \<noteq> 0"
and hd: "\<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). hd_coeff_is1 a" and "nqfree \<phi>"
shows "Z.I (qe_cooper\<^sub>1 \<phi>) xs = (\<exists>x. Z.I \<phi> (x#xs))"
proof -
  let ?as = "Z.atoms\<^sub>0 \<phi>"
  let ?d = "zlcms(map divisor ?as)"
  have "?d > 0" using norm atoms_subset[of \<phi>] `nqfree \<phi>`
    by(fastforce intro:zlcms_pos)
  have alld: "\<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). divisor a dvd ?d" by(simp add:dvd_zlcms)
  from cp_thm[OF `nqfree \<phi>` hd alld `?d>0`]
  show ?thesis using `nqfree \<phi>`
    by (simp add:qe_cooper\<^sub>1_def I_subst[symmetric] split_def algebra_simps) blast
qed

lemma divisor_hd_coeff1_neq0:
  "qfree \<phi> \<Longrightarrow> a \<in> atoms \<phi> \<Longrightarrow> divisor a \<noteq> 0 \<Longrightarrow>
   divisor (hd_coeff1 (zlcms (map hd_coeff (Z.atoms\<^sub>0 \<phi>))) a) \<noteq> 0"
apply (case_tac a)

apply simp
apply(rename_tac list) apply(case_tac list) apply simp apply(simp split:split_if_asm)

apply simp
apply(rename_tac list)apply(case_tac list) apply simp
apply(clarsimp split:split_if_asm)
apply(hypsubst_thin)
apply(subgoal_tac "a : set(map hd_coeff (Z.atoms\<^sub>0 \<phi>))")
 apply(subgoal_tac "\<forall>i\<in>set(map hd_coeff (Z.atoms\<^sub>0 \<phi>)). i \<noteq> 0")
  apply (metis dvd_zlcms mult_eq_0_iff dvd_mult_div_cancel zlcms0_iff)
 apply (simp add:set_atoms0_iff)
apply(fastforce simp:image_def set_atoms0_iff Bex_def)

apply simp
apply(rename_tac list) apply(case_tac list) apply simp
apply(clarsimp split:split_if_asm)
apply(hypsubst_thin)
apply(subgoal_tac "a : set(map hd_coeff (Z.atoms\<^sub>0 \<phi>))")
 apply(subgoal_tac "\<forall>i\<in>set(map hd_coeff (Z.atoms\<^sub>0 \<phi>)). i \<noteq> 0")
  apply (metis dvd_zlcms mult_eq_0_iff dvd_mult_div_cancel zlcms0_iff)
 apply (simp add:set_atoms0_iff)
apply(fastforce simp:image_def set_atoms0_iff Bex_def)
done

lemma hd_coeff_is1_hd_coeff1:
  "hd_coeff (hd_coeff1 m a) \<noteq> 0 \<longrightarrow> hd_coeff_is1 (hd_coeff1 m a)"
by (induct a rule: hd_coeff1.induct) (simp_all add:zsgn_def)

lemma I_cooper1_hd_coeffs1: "Z.normal \<phi> \<Longrightarrow> nqfree \<phi>
       \<Longrightarrow> Z.I (qe_cooper\<^sub>1(hd_coeffs1 \<phi>)) xs = (\<exists>x. Z.I \<phi> (x # xs))"
apply(simp add:Z.normal_def)
apply(subst I_qe_cooper\<^sub>1)
   apply(clarsimp simp:hd_coeffs1_def image_def set_atoms0_iff divisor_hd_coeff1_neq0)
  apply (clarsimp simp:hd_coeffs1_def qfree_map_fm set_atoms0_iff
                     hd_coeff_is1_hd_coeff1)
 apply(simp add:hd_coeffs1_def nqfree_map_fm)
apply(simp add: I_hd_coeffs1)
done

definition "qe_cooper = Z.lift_nnf_qe (qe_cooper\<^sub>1 \<circ> hd_coeffs1)"

lemma qfree_cooper1_hd_coeffs1: "qfree \<phi> \<Longrightarrow> qfree (qe_cooper\<^sub>1 (hd_coeffs1 \<phi>))"
by(auto simp:qe_cooper\<^sub>1_def hd_coeffs1_def qfree_map_fm
        intro!: qfree_or qfree_and qfree_list_disj qfree_min_inf)

lemma normal_min_inf: "Z.normal \<phi> \<Longrightarrow> Z.normal(inf\<^sub>- \<phi>)"
by(induct \<phi> rule:min_inf.induct) simp_all

lemma normal_cooper1: "Z.normal \<phi> \<Longrightarrow> Z.normal(qe_cooper\<^sub>1 \<phi>)"
by(simp add:qe_cooper\<^sub>1_def Logic.or_def Z.normal_map_fm normal_min_inf split_def)

lemma normal_hd_coeffs1: "qfree \<phi> \<Longrightarrow> Z.normal \<phi> \<Longrightarrow> Z.normal(hd_coeffs1 \<phi>)"
by(auto simp: hd_coeffs1_def image_def set_atoms0_iff
              divisor_hd_coeff1_neq0 Z.normal_def)

theorem I_cooper: "Z.normal \<phi> \<Longrightarrow>  Z.I (qe_cooper \<phi>) xs = Z.I \<phi> xs"
by(simp add:qe_cooper_def Z.I_lift_nnf_qe_normal qfree_cooper1_hd_coeffs1 I_cooper1_hd_coeffs1 normal_cooper1 normal_hd_coeffs1)

theorem qfree_cooper: "qfree (qe_cooper \<phi>)"
by(simp add:qe_cooper_def Z.qfree_lift_nnf_qe qfree_cooper1_hd_coeffs1)

end


(*  Title:      HOL/ex/Reflection_Examples.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section {* Examples for generic reflection and reification *}

theory Reflection_Examples
imports Complex_Main "~~/src/HOL/Library/Reflection"
begin

text {* This theory presents two methods: reify and reflection *}

text {*
Consider an HOL type @{text \<sigma>}, the structure of which is not recongnisable
on the theory level.  This is the case of @{typ bool}, arithmetical terms such as @{typ int},
@{typ real} etc \dots  In order to implement a simplification on terms of type @{text \<sigma>} we
often need its structure.  Traditionnaly such simplifications are written in ML,
proofs are synthesized.

An other strategy is to declare an HOL datatype @{text \<tau>} and an HOL function (the
interpretation) that maps elements of @{text \<tau>} to elements of @{text \<sigma>}.

The functionality of @{text reify} then is, given a term @{text t} of type @{text \<sigma>},
to compute a term @{text s} of type @{text \<tau>}.  For this it needs equations for the
interpretation.

N.B: All the interpretations supported by @{text reify} must have the type
@{text "'a list \<Rightarrow> \<tau> \<Rightarrow> \<sigma>"}.  The method @{text reify} can also be told which subterm
of the current subgoal should be reified.  The general call for @{text reify} is
@{text "reify eqs (t)"}, where @{text eqs} are the defining equations of the interpretation
and @{text "(t)"} is an optional parameter which specifies the subterm to which reification
should be applied to.  If @{text "(t)"} is abscent, @{text reify} tries to reify the whole
subgoal.

The method @{text reflection} uses @{text reify} and has a very similar signature:
@{text "reflection corr_thm eqs (t)"}.  Here again @{text eqs} and @{text "(t)"}
are as described above and @{text corr_thm} is a theorem proving
@{prop "I vs (f t) = I vs t"}.  We assume that @{text I} is the interpretation
and @{text f} is some useful and executable simplification of type @{text "\<tau> \<Rightarrow> \<tau>"}.
The method @{text reflection} applies reification and hence the theorem @{prop "t = I xs s"}
and hence using @{text corr_thm} derives @{prop "t = I xs (f s)"}.  It then uses
normalization by equational rewriting to prove @{prop "f s = s'"} which almost finishes
the proof of @{prop "t = t'"} where @{prop "I xs s' = t'"}.
*}

text {* Example 1 : Propositional formulae and NNF. *}
text {* The type @{text fm} represents simple propositional formulae: *}

datatype form = TrueF | FalseF | Less nat nat
  | And form form | Or form form | Neg form | ExQ form

primrec interp :: "form \<Rightarrow> ('a::ord) list \<Rightarrow> bool"
where
  "interp TrueF vs \<longleftrightarrow> True"
| "interp FalseF vs \<longleftrightarrow> False"
| "interp (Less i j) vs \<longleftrightarrow> vs ! i < vs ! j"
| "interp (And f1 f2) vs \<longleftrightarrow> interp f1 vs \<and> interp f2 vs"
| "interp (Or f1 f2) vs \<longleftrightarrow> interp f1 vs \<or> interp f2 vs"
| "interp (Neg f) vs \<longleftrightarrow> \<not> interp f vs"
| "interp (ExQ f) vs \<longleftrightarrow> (\<exists>v. interp f (v # vs))"

lemmas interp_reify_eqs = interp.simps
declare interp_reify_eqs [reify]

lemma "\<exists>x. x < y \<and> x < z"
  apply reify
  oops

datatype fm = And fm fm | Or fm fm | Imp fm fm | Iff fm fm | NOT fm | At nat

primrec Ifm :: "fm \<Rightarrow> bool list \<Rightarrow> bool"
where
  "Ifm (At n) vs \<longleftrightarrow> vs ! n"
| "Ifm (And p q) vs \<longleftrightarrow> Ifm p vs \<and> Ifm q vs"
| "Ifm (Or p q) vs \<longleftrightarrow> Ifm p vs \<or> Ifm q vs"
| "Ifm (Imp p q) vs \<longleftrightarrow> Ifm p vs \<longrightarrow> Ifm q vs"
| "Ifm (Iff p q) vs \<longleftrightarrow> Ifm p vs = Ifm q vs"
| "Ifm (NOT p) vs \<longleftrightarrow> \<not> Ifm p vs"

lemma "Q \<longrightarrow> (D \<and> F \<and> ((\<not> D) \<and> (\<not> F)))"
  apply (reify Ifm.simps)
oops

text {* Method @{text reify} maps a @{typ bool} to an @{typ fm}.  For this it needs the
semantics of @{text fm}, i.e.\ the rewrite rules in @{text Ifm.simps}. *}

text {* You can also just pick up a subterm to reify. *}
lemma "Q \<longrightarrow> (D \<and> F \<and> ((\<not> D) \<and> (\<not> F)))"
  apply (reify Ifm.simps ("((\<not> D) \<and> (\<not> F))"))
oops

text {* Let's perform NNF. This is a version that tends to generate disjunctions *}
primrec fmsize :: "fm \<Rightarrow> nat"
where
  "fmsize (At n) = 1"
| "fmsize (NOT p) = 1 + fmsize p"
| "fmsize (And p q) = 1 + fmsize p + fmsize q"
| "fmsize (Or p q) = 1 + fmsize p + fmsize q"
| "fmsize (Imp p q) = 2 + fmsize p + fmsize q"
| "fmsize (Iff p q) = 2 + 2* fmsize p + 2* fmsize q"

lemma [measure_function]: "is_measure fmsize" ..

fun nnf :: "fm \<Rightarrow> fm"
where
  "nnf (At n) = At n"
| "nnf (And p q) = And (nnf p) (nnf q)"
| "nnf (Or p q) = Or (nnf p) (nnf q)"
| "nnf (Imp p q) = Or (nnf (NOT p)) (nnf q)"
| "nnf (Iff p q) = Or (And (nnf p) (nnf q)) (And (nnf (NOT p)) (nnf (NOT q)))"
| "nnf (NOT (And p q)) = Or (nnf (NOT p)) (nnf (NOT q))"
| "nnf (NOT (Or p q)) = And (nnf (NOT p)) (nnf (NOT q))"
| "nnf (NOT (Imp p q)) = And (nnf p) (nnf (NOT q))"
| "nnf (NOT (Iff p q)) = Or (And (nnf p) (nnf (NOT q))) (And (nnf (NOT p)) (nnf q))"
| "nnf (NOT (NOT p)) = nnf p"
| "nnf (NOT p) = NOT p"

text {* The correctness theorem of @{const nnf}: it preserves the semantics of @{typ fm} *}
lemma nnf [reflection]:
  "Ifm (nnf p) vs = Ifm p vs"
  by (induct p rule: nnf.induct) auto

text {* Now let's perform NNF using our @{const nnf} function defined above.  First to the
  whole subgoal. *}
lemma "A \<noteq> B \<and> (B \<longrightarrow> A \<noteq> (B \<or> C \<and> (B \<longrightarrow> A \<or> D))) \<longrightarrow> A \<or> B \<and> D"
  apply (reflection Ifm.simps)
oops

text {* Now we specify on which subterm it should be applied *}
lemma "A \<noteq> B \<and> (B \<longrightarrow> A \<noteq> (B \<or> C \<and> (B \<longrightarrow> A \<or> D))) \<longrightarrow> A \<or> B \<and> D"
  apply (reflection Ifm.simps only: "B \<or> C \<and> (B \<longrightarrow> A \<or> D)")
oops

text {* Example 2: Simple arithmetic formulae *}

text {* The type @{text num} reflects linear expressions over natural number *}
datatype num = C nat | Add num num | Mul nat num | Var nat | CN nat nat num

text {* This is just technical to make recursive definitions easier. *}
primrec num_size :: "num \<Rightarrow> nat"
where
  "num_size (C c) = 1"
| "num_size (Var n) = 1"
| "num_size (Add a b) = 1 + num_size a + num_size b"
| "num_size (Mul c a) = 1 + num_size a"
| "num_size (CN n c a) = 4 + num_size a "

lemma [measure_function]: "is_measure num_size" ..

text {* The semantics of num *}
primrec Inum:: "num \<Rightarrow> nat list \<Rightarrow> nat"
where
  Inum_C  : "Inum (C i) vs = i"
| Inum_Var: "Inum (Var n) vs = vs!n"
| Inum_Add: "Inum (Add s t) vs = Inum s vs + Inum t vs "
| Inum_Mul: "Inum (Mul c t) vs = c * Inum t vs "
| Inum_CN : "Inum (CN n c t) vs = c*(vs!n) + Inum t vs "

text {* Let's reify some nat expressions \dots *}
lemma "4 * (2 * x + (y::nat)) + f a \<noteq> 0"
  apply (reify Inum.simps ("4 * (2 * x + (y::nat)) + f a"))
oops
text {* We're in a bad situation! @{text x}, @{text y} and @{text f} have been recongnized
as constants, which is correct but does not correspond to our intuition of the constructor C.
It should encapsulate constants, i.e. numbers, i.e. numerals. *}

text {* So let's leave the @{text "Inum_C"} equation at the end and see what happens \dots*}
lemma "4 * (2 * x + (y::nat)) \<noteq> 0"
  apply (reify Inum_Var Inum_Add Inum_Mul Inum_CN Inum_C ("4 * (2 * x + (y::nat))"))
oops
text {* Hm, let's specialize @{text Inum_C} with numerals.*}

lemma Inum_number: "Inum (C (numeral t)) vs = numeral t" by simp
lemmas Inum_eqs = Inum_Var Inum_Add Inum_Mul Inum_CN Inum_number

text {* Second attempt *}
lemma "1 * (2 * x + (y::nat)) \<noteq> 0"
  apply (reify Inum_eqs ("1 * (2 * x + (y::nat))"))
oops

text{* That was fine, so let's try another one \dots *}

lemma "1 * (2 * x + (y::nat) + 0 + 1) \<noteq> 0"
  apply (reify Inum_eqs ("1 * (2 * x + (y::nat) + 0 + 1)"))
oops

text {* Oh!! 0 is not a variable \dots\ Oh! 0 is not a @{text "numeral"} \dots\ thing.
The same for 1. So let's add those equations, too. *}

lemma Inum_01: "Inum (C 0) vs = 0" "Inum (C 1) vs = 1" "Inum (C(Suc n)) vs = Suc n"
  by simp_all

lemmas Inum_eqs'= Inum_eqs Inum_01

text{* Third attempt: *}

lemma "1 * (2 * x + (y::nat) + 0 + 1) \<noteq> 0"
  apply (reify Inum_eqs' ("1 * (2 * x + (y::nat) + 0 + 1)"))
oops

text {* Okay, let's try reflection. Some simplifications on @{typ num} follow. You can
  skim until the main theorem @{text linum}. *}

fun lin_add :: "num \<Rightarrow> num \<Rightarrow> num"
where
  "lin_add (CN n1 c1 r1) (CN n2 c2 r2) =
    (if n1 = n2 then
      (let c = c1 + c2
       in (if c = 0 then lin_add r1 r2 else CN n1 c (lin_add r1 r2)))
     else if n1 \<le> n2 then (CN n1 c1 (lin_add r1 (CN n2 c2 r2)))
     else (CN n2 c2 (lin_add (CN n1 c1 r1) r2)))"
| "lin_add (CN n1 c1 r1) t = CN n1 c1 (lin_add r1 t)"
| "lin_add t (CN n2 c2 r2) = CN n2 c2 (lin_add t r2)"
| "lin_add (C b1) (C b2) = C (b1 + b2)"
| "lin_add a b = Add a b"

lemma lin_add:
  "Inum (lin_add t s) bs = Inum (Add t s) bs"
  apply (induct t s rule: lin_add.induct, simp_all add: Let_def)
  apply (case_tac "c1+c2 = 0",case_tac "n1 \<le> n2", simp_all)
  apply (case_tac "n1 = n2", simp_all add: algebra_simps)
  done

fun lin_mul :: "num \<Rightarrow> nat \<Rightarrow> num"
where
  "lin_mul (C j) i = C (i * j)"
| "lin_mul (CN n c a) i = (if i=0 then (C 0) else CN n (i * c) (lin_mul a i))"
| "lin_mul t i = (Mul i t)"

lemma lin_mul:
  "Inum (lin_mul t i) bs = Inum (Mul i t) bs"
  by (induct t i rule: lin_mul.induct) (auto simp add: algebra_simps)

fun linum:: "num \<Rightarrow> num"
where
  "linum (C b) = C b"
| "linum (Var n) = CN n 1 (C 0)"
| "linum (Add t s) = lin_add (linum t) (linum s)"
| "linum (Mul c t) = lin_mul (linum t) c"
| "linum (CN n c t) = lin_add (linum (Mul c (Var n))) (linum t)"

lemma linum [reflection]:
  "Inum (linum t) bs = Inum t bs"
  by (induct t rule: linum.induct) (simp_all add: lin_mul lin_add)

text {* Now we can use linum to simplify nat terms using reflection *}

lemma "Suc (Suc 1) * (x + Suc 1 * y) = 3 * x + 6 * y"
  apply (reflection Inum_eqs' only: "Suc (Suc 1) * (x + Suc 1 * y)")
oops

text {* Let's lift this to formulae and see what happens *}

datatype aform = Lt num num  | Eq num num | Ge num num | NEq num num |
  Conj aform aform | Disj aform aform | NEG aform | T | F

primrec linaformsize:: "aform \<Rightarrow> nat"
where
  "linaformsize T = 1"
| "linaformsize F = 1"
| "linaformsize (Lt a b) = 1"
| "linaformsize (Ge a b) = 1"
| "linaformsize (Eq a b) = 1"
| "linaformsize (NEq a b) = 1"
| "linaformsize (NEG p) = 2 + linaformsize p"
| "linaformsize (Conj p q) = 1 + linaformsize p + linaformsize q"
| "linaformsize (Disj p q) = 1 + linaformsize p + linaformsize q"

lemma [measure_function]: "is_measure linaformsize" ..

primrec is_aform :: "aform => nat list => bool"
where
  "is_aform T vs = True"
| "is_aform F vs = False"
| "is_aform (Lt a b) vs = (Inum a vs < Inum b vs)"
| "is_aform (Eq a b) vs = (Inum a vs = Inum b vs)"
| "is_aform (Ge a b) vs = (Inum a vs \<ge> Inum b vs)"
| "is_aform (NEq a b) vs = (Inum a vs \<noteq> Inum b vs)"
| "is_aform (NEG p) vs = (\<not> (is_aform p vs))"
| "is_aform (Conj p q) vs = (is_aform p vs \<and> is_aform q vs)"
| "is_aform (Disj p q) vs = (is_aform p vs \<or> is_aform q vs)"

text{* Let's reify and do reflection *}
lemma "(3::nat) * x + t < 0 \<and> (2 * x + y \<noteq> 17)"
  apply (reify Inum_eqs' is_aform.simps)
oops

text {* Note that reification handles several interpretations at the same time*}
lemma "(3::nat) * x + t < 0 \<and> x * x + t * x + 3 + 1 = z * t * 4 * z \<or> x + x + 1 < 0"
  apply (reflection Inum_eqs' is_aform.simps only: "x + x + 1")
oops

text {* For reflection we now define a simple transformation on aform: NNF + linum on atoms *}

fun linaform:: "aform \<Rightarrow> aform"
where
  "linaform (Lt s t) = Lt (linum s) (linum t)"
| "linaform (Eq s t) = Eq (linum s) (linum t)"
| "linaform (Ge s t) = Ge (linum s) (linum t)"
| "linaform (NEq s t) = NEq (linum s) (linum t)"
| "linaform (Conj p q) = Conj (linaform p) (linaform q)"
| "linaform (Disj p q) = Disj (linaform p) (linaform q)"
| "linaform (NEG T) = F"
| "linaform (NEG F) = T"
| "linaform (NEG (Lt a b)) = Ge a b"
| "linaform (NEG (Ge a b)) = Lt a b"
| "linaform (NEG (Eq a b)) = NEq a b"
| "linaform (NEG (NEq a b)) = Eq a b"
| "linaform (NEG (NEG p)) = linaform p"
| "linaform (NEG (Conj p q)) = Disj (linaform (NEG p)) (linaform (NEG q))"
| "linaform (NEG (Disj p q)) = Conj (linaform (NEG p)) (linaform (NEG q))"
| "linaform p = p"

lemma linaform: "is_aform (linaform p) vs = is_aform p vs"
  by (induct p rule: linaform.induct) (auto simp add: linum)

lemma "(Suc (Suc (Suc 0)) * ((x::nat) + Suc (Suc 0)) + Suc (Suc (Suc 0)) *
  (Suc (Suc (Suc 0))) * ((x::nat) + Suc (Suc 0))) < 0 \<and> Suc 0 + Suc 0 < 0"
  apply (reflection Inum_eqs' is_aform.simps rules: linaform)
oops

declare linaform [reflection]

lemma "(Suc (Suc (Suc 0)) * ((x::nat) + Suc (Suc 0)) + Suc (Suc (Suc 0)) *
  (Suc (Suc (Suc 0))) * ((x::nat) + Suc (Suc 0))) < 0 \<and> Suc 0 + Suc 0 < 0"
  apply (reflection Inum_eqs' is_aform.simps)
oops

text {* We now give an example where interpretaions have zero or more than only
  one envornement of different types and show that automatic reification also deals with
  bindings *}

datatype rb = BC bool | BAnd rb rb | BOr rb rb

primrec Irb :: "rb \<Rightarrow> bool"
where
  "Irb (BC p) \<longleftrightarrow> p"
| "Irb (BAnd s t) \<longleftrightarrow> Irb s \<and> Irb t"
| "Irb (BOr s t) \<longleftrightarrow> Irb s \<or> Irb t"

lemma "A \<and> (B \<or> D \<and> B) \<and> A \<and> (B \<or> D \<and> B) \<or> A \<and> (B \<or> D \<and> B) \<or> A \<and> (B \<or> D \<and> B)"
  apply (reify Irb.simps)
oops

datatype rint = IC int | IVar nat | IAdd rint rint | IMult rint rint
  | INeg rint | ISub rint rint

primrec Irint :: "rint \<Rightarrow> int list \<Rightarrow> int"
where
  Irint_Var: "Irint (IVar n) vs = vs ! n"
| Irint_Neg: "Irint (INeg t) vs = - Irint t vs"
| Irint_Add: "Irint (IAdd s t) vs = Irint s vs + Irint t vs"
| Irint_Sub: "Irint (ISub s t) vs = Irint s vs - Irint t vs"
| Irint_Mult: "Irint (IMult s t) vs = Irint s vs * Irint t vs"
| Irint_C: "Irint (IC i) vs = i"

lemma Irint_C0: "Irint (IC 0) vs = 0"
  by simp

lemma Irint_C1: "Irint (IC 1) vs = 1"
  by simp

lemma Irint_Cnumeral: "Irint (IC (numeral x)) vs = numeral x"
  by simp

lemmas Irint_simps = Irint_Var Irint_Neg Irint_Add Irint_Sub Irint_Mult Irint_C0 Irint_C1 Irint_Cnumeral

lemma "(3::int) * x + y * y - 9 + (- z) = 0"
  apply (reify Irint_simps ("(3::int) * x + y * y - 9 + (- z)"))
  oops

datatype rlist = LVar nat | LEmpty | LCons rint rlist | LAppend rlist rlist

primrec Irlist :: "rlist \<Rightarrow> int list \<Rightarrow> int list list \<Rightarrow> int list"
where
  "Irlist (LEmpty) is vs = []"
| "Irlist (LVar n) is vs = vs ! n"
| "Irlist (LCons i t) is vs = Irint i is # Irlist t is vs"
| "Irlist (LAppend s t) is vs = Irlist s is vs @ Irlist t is vs"

lemma "[(1::int)] = []"
  apply (reify Irlist.simps Irint_simps ("[1] :: int list"))
  oops

lemma "([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs = [y * y - z - 9 + (3::int) * x]"
  apply (reify Irlist.simps Irint_simps ("([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs"))
  oops

datatype rnat = NC nat| NVar nat| NSuc rnat | NAdd rnat rnat | NMult rnat rnat
  | NNeg rnat | NSub rnat rnat | Nlgth rlist

primrec Irnat :: "rnat \<Rightarrow> int list \<Rightarrow> int list list \<Rightarrow> nat list \<Rightarrow> nat"
where
  Irnat_Suc: "Irnat (NSuc t) is ls vs = Suc (Irnat t is ls vs)"
| Irnat_Var: "Irnat (NVar n) is ls vs = vs ! n"
| Irnat_Neg: "Irnat (NNeg t) is ls vs = 0"
| Irnat_Add: "Irnat (NAdd s t) is ls vs = Irnat s is ls vs + Irnat t is ls vs"
| Irnat_Sub: "Irnat (NSub s t) is ls vs = Irnat s is ls vs - Irnat t is ls vs"
| Irnat_Mult: "Irnat (NMult s t) is ls vs = Irnat s is ls vs * Irnat t is ls vs"
| Irnat_lgth: "Irnat (Nlgth rxs) is ls vs = length (Irlist rxs is ls)"
| Irnat_C: "Irnat (NC i) is ls vs = i"

lemma Irnat_C0: "Irnat (NC 0) is ls vs = 0"
  by simp

lemma Irnat_C1: "Irnat (NC 1) is ls vs = 1"
  by simp

lemma Irnat_Cnumeral: "Irnat (NC (numeral x)) is ls vs = numeral x"
  by simp

lemmas Irnat_simps = Irnat_Suc Irnat_Var Irnat_Neg Irnat_Add Irnat_Sub Irnat_Mult Irnat_lgth
  Irnat_C0 Irnat_C1 Irnat_Cnumeral

lemma "Suc n * length (([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs) = length xs"
  apply (reify Irnat_simps Irlist.simps Irint_simps
     ("Suc n * length (([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs)"))
  oops

datatype rifm = RT | RF | RVar nat
  | RNLT rnat rnat | RNILT rnat rint | RNEQ rnat rnat
  | RAnd rifm rifm | ROr rifm rifm | RImp rifm rifm| RIff rifm rifm
  | RNEX rifm | RIEX rifm | RLEX rifm | RNALL rifm | RIALL rifm | RLALL rifm
  | RBEX rifm | RBALL rifm

primrec Irifm :: "rifm \<Rightarrow> bool list \<Rightarrow> int list \<Rightarrow> (int list) list \<Rightarrow> nat list \<Rightarrow> bool"
where
  "Irifm RT ps is ls ns \<longleftrightarrow> True"
| "Irifm RF ps is ls ns \<longleftrightarrow> False"
| "Irifm (RVar n) ps is ls ns \<longleftrightarrow> ps ! n"
| "Irifm (RNLT s t) ps is ls ns \<longleftrightarrow> Irnat s is ls ns < Irnat t is ls ns"
| "Irifm (RNILT s t) ps is ls ns \<longleftrightarrow> int (Irnat s is ls ns) < Irint t is"
| "Irifm (RNEQ s t) ps is ls ns \<longleftrightarrow> Irnat s is ls ns = Irnat t is ls ns"
| "Irifm (RAnd p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<and> Irifm q ps is ls ns"
| "Irifm (ROr p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<or> Irifm q ps is ls ns"
| "Irifm (RImp p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<longrightarrow> Irifm q ps is ls ns"
| "Irifm (RIff p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns = Irifm q ps is ls ns"
| "Irifm (RNEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps is ls (x # ns))"
| "Irifm (RIEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps (x # is) ls ns)"
| "Irifm (RLEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps is (x # ls) ns)"
| "Irifm (RBEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p (x # ps) is ls ns)"
| "Irifm (RNALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps is ls (x#ns))"
| "Irifm (RIALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps (x # is) ls ns)"
| "Irifm (RLALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps is (x#ls) ns)"
| "Irifm (RBALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p (x # ps) is ls ns)"

lemma " \<forall>x. \<exists>n. ((Suc n) * length (([(3::int) * x + f t * y - 9 + (- z)] @ []) @ xs) = length xs) \<and> m < 5*n - length (xs @ [2,3,4,x*z + 8 - y]) \<longrightarrow> (\<exists>p. \<forall>q. p \<and> q \<longrightarrow> r)"
  apply (reify Irifm.simps Irnat_simps Irlist.simps Irint_simps)
oops

text {* An example for equations containing type variables *}

datatype prod = Zero | One | Var nat | Mul prod prod
  | Pw prod nat | PNM nat nat prod

primrec Iprod :: " prod \<Rightarrow> ('a::linordered_idom) list \<Rightarrow>'a"
where
  "Iprod Zero vs = 0"
| "Iprod One vs = 1"
| "Iprod (Var n) vs = vs ! n"
| "Iprod (Mul a b) vs = Iprod a vs * Iprod b vs"
| "Iprod (Pw a n) vs = Iprod a vs ^ n"
| "Iprod (PNM n k t) vs = (vs ! n) ^ k * Iprod t vs"

datatype sgn = Pos prod | Neg prod | ZeroEq prod | NZeroEq prod | Tr | F
  | Or sgn sgn | And sgn sgn

primrec Isgn :: "sgn \<Rightarrow> ('a::linordered_idom) list \<Rightarrow> bool"
where
  "Isgn Tr vs \<longleftrightarrow> True"
| "Isgn F vs \<longleftrightarrow> False"
| "Isgn (ZeroEq t) vs \<longleftrightarrow> Iprod t vs = 0"
| "Isgn (NZeroEq t) vs \<longleftrightarrow> Iprod t vs \<noteq> 0"
| "Isgn (Pos t) vs \<longleftrightarrow> Iprod t vs > 0"
| "Isgn (Neg t) vs \<longleftrightarrow> Iprod t vs < 0"
| "Isgn (And p q) vs \<longleftrightarrow> Isgn p vs \<and> Isgn q vs"
| "Isgn (Or p q) vs \<longleftrightarrow> Isgn p vs \<or> Isgn q vs"

lemmas eqs = Isgn.simps Iprod.simps

lemma "(x::'a::{linordered_idom}) ^ 4 * y * z * y ^ 2 * z ^ 23 > 0"
  apply (reify eqs)
  oops

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Basic Setup\<close>
theory Transport_Compositions_Generic_Base
  imports
    HOL_Basics.Galois_Relator
    Transport_Base
begin

locale transport_comp =
  t1 : transport L1 R1 l1 r1 + t2 : transport L2 R2 l2 r2
  for L1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and R1 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  and l1 :: "'a \<Rightarrow> 'b"
  and r1 :: "'b \<Rightarrow> 'a"
  and L2 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  and R2 :: "'c \<Rightarrow> 'c \<Rightarrow> bool"
  and l2 :: "'b \<Rightarrow> 'c"
  and r2 :: "'c \<Rightarrow> 'b"
begin

text \<open>This locale collects results about the composition of transportable
components under some generic compatibility conditions on @{term "R1"} and
@{term "L2"} (cf. below). The composition is rather subtle, but in return can
cover quite general cases.

Explanations and intuition about the construction can be found in the Transport
paper.\<close>

notation L1 (infix "\<le>\<^bsub>L1\<^esub>" 50)
notation R1 (infix "\<le>\<^bsub>R1\<^esub>" 50)
notation L2 (infix "\<le>\<^bsub>L2\<^esub>" 50)
notation R2 (infix "\<le>\<^bsub>R2\<^esub>" 50)

notation t1.ge_left (infix "\<ge>\<^bsub>L1\<^esub>" 50)
notation t1.ge_right (infix "\<ge>\<^bsub>R1\<^esub>" 50)
notation t2.ge_left (infix "\<ge>\<^bsub>L2\<^esub>" 50)
notation t2.ge_right (infix "\<ge>\<^bsub>R2\<^esub>" 50)

notation t1.Galois (infix "\<^bsub>L1\<^esub>\<lessapprox>" 50)
notation t1.flip_Galois (infix "\<^bsub>R1\<^esub>\<lessapprox>" 50)
notation t2.Galois (infix "\<^bsub>L2\<^esub>\<lessapprox>" 50)
notation t2.flip_Galois (infix "\<^bsub>R2\<^esub>\<lessapprox>" 50)

notation t1.ge_Galois (infix "\<greaterapprox>\<^bsub>L1\<^esub>" 50)
notation t1.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R1\<^esub>" 50)
notation t2.ge_Galois (infix "\<greaterapprox>\<^bsub>L2\<^esub>" 50)
notation t2.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R2\<^esub>" 50)

notation t1.flip_inv_Galois (infix "\<^bsub>R1\<^esub>\<greaterapprox>" 50)
notation t1.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R1\<^esub>" 50)
notation t2.flip_inv_Galois (infix "\<^bsub>R2\<^esub>\<greaterapprox>" 50)
notation t2.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R2\<^esub>" 50)

notation t1.flip_flip_inv_Galois (infix "\<^bsub>L1\<^esub>\<greaterapprox>" 50)
notation t1.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L1\<^esub>" 50)
notation t2.flip_flip_inv_Galois (infix "\<^bsub>L2\<^esub>\<greaterapprox>" 50)
notation t2.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L2\<^esub>" 50)

notation t1.unit ("\<eta>\<^sub>1")
notation t1.counit ("\<epsilon>\<^sub>1")
notation t2.unit ("\<eta>\<^sub>2")
notation t2.counit ("\<epsilon>\<^sub>2")

definition "L \<equiv> (\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<^bsub>R1\<^esub>\<lessapprox>)"

lemma left_rel_eq_comp: "L = (\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<^bsub>R1\<^esub>\<lessapprox>)"
  unfolding L_def ..

definition "l \<equiv> l2 \<circ> l1"

lemma left_eq_comp: "l = l2 \<circ> l1"
  unfolding l_def ..

lemma left_eq [simp]: "l x = l2 (l1 x)"
  unfolding left_eq_comp by simp

context
begin

interpretation flip : transport_comp R2 L2 r2 l2 R1 L1 r1 l1 .

abbreviation "R \<equiv> flip.L"
abbreviation "r \<equiv> flip.l"

lemma right_rel_eq_comp: "R = (\<^bsub>R2\<^esub>\<lessapprox>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>)"
  unfolding flip.L_def ..

lemma right_eq_comp: "r = r1 \<circ> r2"
  unfolding flip.l_def ..

lemma right_eq [simp]: "r z = r1 (r2 z)"
  unfolding right_eq_comp by simp

lemmas transport_defs = left_rel_eq_comp left_eq_comp right_rel_eq_comp right_eq_comp

end

sublocale transport L R l r .

(*FIXME: somehow the notation for the fixed parameters L and R, defined in
Order_Functions_Base.thy, is lost. We hence re-declare it here.*)
notation L (infix "\<le>\<^bsub>L\<^esub>" 50)
notation R (infix "\<le>\<^bsub>R\<^esub>" 50)

lemma left_relI [intro]:
  assumes "x \<^bsub>L1\<^esub>\<lessapprox> y"
  and "y \<le>\<^bsub>L2\<^esub> y'"
  and "y' \<^bsub>R1\<^esub>\<lessapprox> x'"
  shows "x \<le>\<^bsub>L\<^esub> x'"
  unfolding left_rel_eq_comp using assms by blast

lemma left_relE [elim]:
  assumes "x \<le>\<^bsub>L\<^esub> x'"
  obtains y y' where "x \<^bsub>L1\<^esub>\<lessapprox> y" "y \<le>\<^bsub>L2\<^esub> y'" "y' \<^bsub>R1\<^esub>\<lessapprox> x'"
  using assms unfolding left_rel_eq_comp by blast

context
begin

interpretation flip : transport_comp R2 L2 r2 l2 R1 L1 r1 l1 .
interpretation inv : transport_comp "(\<ge>\<^bsub>L1\<^esub>)" "(\<ge>\<^bsub>R1\<^esub>)" l1 r1 "(\<ge>\<^bsub>L2\<^esub>)" "(\<ge>\<^bsub>R2\<^esub>)" l2 r2 .

lemma ge_left_rel_eq_left_rel_inv_if_galois_prop [simp]:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1" "((\<le>\<^bsub>R1\<^esub>) \<unlhd> (\<le>\<^bsub>L1\<^esub>)) r1 l1"
  shows "(\<ge>\<^bsub>L\<^esub>) = transport_comp.L (\<ge>\<^bsub>L1\<^esub>) (\<ge>\<^bsub>R1\<^esub>) l1 r1 (\<ge>\<^bsub>L2\<^esub>)"
  using assms unfolding left_rel_eq_comp inv.left_rel_eq_comp
  by (simp add: rel_comp_assoc)

corollary left_rel_inv_iff_left_rel_if_galois_prop [iff]:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1" "((\<le>\<^bsub>R1\<^esub>) \<unlhd> (\<le>\<^bsub>L1\<^esub>)) r1 l1"
  shows "(transport_comp.L (\<ge>\<^bsub>L1\<^esub>) (\<ge>\<^bsub>R1\<^esub>) l1 r1 (\<ge>\<^bsub>L2\<^esub>)) x x' \<longleftrightarrow> x' \<le>\<^bsub>L\<^esub> x"
  using assms by (simp flip: ge_left_rel_eq_left_rel_inv_if_galois_prop)

subparagraph \<open>Simplification of Relations\<close>

lemma left_rel_le_left_rel1I:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>R1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>L1\<^esub>)) r1 l1"
  and trans_L1: "transitive (\<le>\<^bsub>L1\<^esub>)"
  and mono_l1: "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))) l1"
  shows "(\<le>\<^bsub>L\<^esub>) \<le> (\<le>\<^bsub>L1\<^esub>)"
proof (rule le_relI)
  fix x x' assume "x \<le>\<^bsub>L\<^esub> x'"
  with mono_l1 obtain y where "l1 x \<le>\<^bsub>R1\<^esub> y" "y \<le>\<^bsub>R1\<^esub> l1 x'" by blast
  with \<open>((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1\<close> \<open>x \<le>\<^bsub>L\<^esub> x'\<close> have "x \<le>\<^bsub>L1\<^esub> r1 y" by blast
  moreover from \<open>((\<le>\<^bsub>R1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>L1\<^esub>)) r1 l1\<close> \<open>y \<le>\<^bsub>R1\<^esub> l1 x'\<close> \<open>x \<le>\<^bsub>L\<^esub> x'\<close>
    have "... \<le>\<^bsub>L1\<^esub> x'" by blast
  ultimately show "x \<le>\<^bsub>L1\<^esub> x'" using trans_L1 by blast
qed

lemma left_rel1_le_left_relI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and mono_l1: "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))) l1"
  shows "(\<le>\<^bsub>L1\<^esub>) \<le> (\<le>\<^bsub>L\<^esub>)"
proof (rule le_relI)
  fix x x' assume "x \<le>\<^bsub>L1\<^esub> x'"
  with mono_l1 obtain y y' where
    "l1 x \<le>\<^bsub>R1\<^esub> y" "y \<le>\<^bsub>L2\<^esub> y'" "y' \<le>\<^bsub>R1\<^esub> l1 x'" by blast
  with \<open>((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1\<close> \<open>x \<le>\<^bsub>L1\<^esub> x'\<close> have "x \<^bsub>L1\<^esub>\<lessapprox> y" by blast
  moreover note \<open>y \<le>\<^bsub>L2\<^esub> y'\<close>
  moreover from \<open>y' \<le>\<^bsub>R1\<^esub> l1 x'\<close> \<open>x \<le>\<^bsub>L1\<^esub> x'\<close> have "y' \<^bsub>R1\<^esub>\<lessapprox> x'" by blast
  ultimately show "x \<le>\<^bsub>L\<^esub> x'" by blast
qed

corollary left_rel_eq_left_rel1I:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>R1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>L1\<^esub>)) r1 l1"
  and "transitive (\<le>\<^bsub>L1\<^esub>)"
  and "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))) l1"
  and "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))) l1"
  shows "(\<le>\<^bsub>L\<^esub>) = (\<le>\<^bsub>L1\<^esub>)"
  using assms by (intro antisym left_rel_le_left_rel1I left_rel1_le_left_relI)

text \<open>Note that we may not necessarily have @{term "(\<le>\<^bsub>L\<^esub>) = (\<le>\<^bsub>L1\<^esub>)"}, even in
case of equivalence relations. Depending on the use case, one thus may wish to
use an alternative composition operation.\<close>

lemma ex_order_equiv_left_rel_neq_left_rel1:
  "\<exists>(L1 :: bool \<Rightarrow> _) (R1 :: bool \<Rightarrow> _) l1 r1
    (L2 :: bool \<Rightarrow> _) (R2 :: bool \<Rightarrow> _) l2 r2.
    (L1 \<equiv>\<^sub>o R1) l1 r1
    \<and> equivalence_rel L1 \<and> equivalence_rel R1
    \<and> (L2 \<equiv>\<^sub>o R2) l2 r2
    \<and> equivalence_rel L2 \<and> equivalence_rel R2
    \<and> transport_comp.L L1 R1 l1 r1 L2 \<noteq> L1"
proof (intro exI conjI)
  let ?L1 = "(=) :: bool \<Rightarrow> _" let ?R1 = ?L1 let ?l1 = id let ?r1 = ?l1
  let ?L2 = "\<top> :: bool \<Rightarrow> bool \<Rightarrow> bool" let ?R2 = ?L2 let ?l2 = id let ?r2 = ?l2
  interpret tc : transport_comp ?L1 ?R1 ?l1 ?r1 ?L2 ?R2 ?l2 ?r2 .
  show "(?L1 \<equiv>\<^sub>o ?R1) ?l1 ?r1" by fastforce
  show "equivalence_rel ?L1" "equivalence_rel ?R1" by (fact equivalence_eq)+
  show "(?L2 \<equiv>\<^sub>o ?R2) ?l2 ?r2" by fastforce
  show "equivalence_rel ?L2" "equivalence_rel ?R2" by (fact equivalence_top)+
  show "tc.L \<noteq> ?L1"
  proof -
    have "\<not>(?L1 False True)" by blast
    moreover have "tc.L False True" by (intro tc.left_relI) auto
    ultimately show ?thesis by auto
  qed
qed

end

subparagraph \<open>Generic Left to Right Introduction Rules\<close>

text \<open>The following lemmas generalise the proof outline used, for example,
when proving monotonicity and the Galois property (cf. the Transport paper).\<close>

interpretation flip : transport_comp R2 L2 r2 l2 R1 L1 r1 l1 .

lemma right_rel_if_left_relI:
  assumes "x \<le>\<^bsub>L\<^esub> x'"
  and l1_R1_if_L1_r1: "\<And>y. in_codom (\<le>\<^bsub>R1\<^esub>) y \<Longrightarrow> x \<le>\<^bsub>L1\<^esub> r1 y \<Longrightarrow> l1 x \<le>\<^bsub>R1\<^esub> y"
  and t_R1_if_l1_R1: "\<And>y. l1 x \<le>\<^bsub>R1\<^esub> y \<Longrightarrow> t y \<le>\<^bsub>R1\<^esub> y"
  and R2_l2_if_t_L2_if_l1_R1:
    "\<And>y y'. l1 x \<le>\<^bsub>R1\<^esub> y \<Longrightarrow> t y \<le>\<^bsub>L2\<^esub> y' \<Longrightarrow> z \<le>\<^bsub>R2\<^esub> l2 y'"
  and R1_b_if_R1_l1_if_R1_l1:
    "\<And>y y'. y \<le>\<^bsub>R1\<^esub> l1 x' \<Longrightarrow> y' \<le>\<^bsub>R1\<^esub> l1 x' \<Longrightarrow> y' \<le>\<^bsub>R1\<^esub> b y"
  and b_L2_r2_if_in_codom_L2_b_if_R1_l1:
    "\<And>y. y \<le>\<^bsub>R1\<^esub> l1 x' \<Longrightarrow> in_codom (\<le>\<^bsub>L2\<^esub>) (b y) \<Longrightarrow> b y \<le>\<^bsub>L2\<^esub> r2 z'"
  and in_codom_R2_if_in_codom_L2_b_if_R1_l1:
    "\<And>y. y \<le>\<^bsub>R1\<^esub> l1 x' \<Longrightarrow> in_codom (\<le>\<^bsub>L2\<^esub>) (b y) \<Longrightarrow> in_codom (\<le>\<^bsub>R2\<^esub>) z'"
  and rel_comp_le: "(\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<le> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)"
  and in_codom_rel_comp_le: "in_codom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_codom (\<le>\<^bsub>L2\<^esub>)"
  shows "z \<le>\<^bsub>R\<^esub> z'"
proof -
  from \<open>x \<le>\<^bsub>L\<^esub> x'\<close> obtain yl yl' where "l1 x \<le>\<^bsub>R1\<^esub> yl" "yl \<le>\<^bsub>L2\<^esub> yl'" "yl' \<le>\<^bsub>R1\<^esub> l1 x'"
    using l1_R1_if_L1_r1 by blast
  moreover then have "t yl \<le>\<^bsub>R1\<^esub> yl" by (intro t_R1_if_l1_R1)
  ultimately have "((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) (t yl) (l1 x')" using rel_comp_le by blast
  then obtain y where "t yl \<le>\<^bsub>L2\<^esub> y" "y \<le>\<^bsub>R1\<^esub> l1 x'" by blast
  show "z \<le>\<^bsub>R\<^esub> z'"
  proof (rule flip.left_relI)
    from \<open>t yl \<le>\<^bsub>L2\<^esub> y\<close> \<open>l1 x \<le>\<^bsub>R1\<^esub> yl\<close> show "z \<^bsub>R2\<^esub>\<lessapprox> y"
      by (auto intro: R2_l2_if_t_L2_if_l1_R1)
    from \<open>yl' \<le>\<^bsub>R1\<^esub> l1 x'\<close> \<open>y \<le>\<^bsub>R1\<^esub> l1 x'\<close> show "y \<le>\<^bsub>R1\<^esub> b yl'"
      by (rule R1_b_if_R1_l1_if_R1_l1)
    show "b yl' \<^bsub>L2\<^esub>\<lessapprox> z'"
    proof (rule t2.GaloisI)
      from \<open>yl' \<le>\<^bsub>R1\<^esub> l1 x'\<close> have "yl' \<le>\<^bsub>R1\<^esub> b yl'"
        by (intro R1_b_if_R1_l1_if_R1_l1)
      with \<open>l1 x \<le>\<^bsub>R1\<^esub> yl\<close> \<open>yl \<le>\<^bsub>L2\<^esub> yl'\<close> in_codom_rel_comp_le
        have "in_codom (\<le>\<^bsub>L2\<^esub>) (b yl')" by blast
      with \<open>yl' \<le>\<^bsub>R1\<^esub> l1 x'\<close> show "b yl' \<le>\<^bsub>L2\<^esub> r2 z'" "in_codom (\<le>\<^bsub>R2\<^esub>) z'"
        by (auto intro: b_L2_r2_if_in_codom_L2_b_if_R1_l1
          in_codom_R2_if_in_codom_L2_b_if_R1_l1)
    qed
  qed
qed

lemma right_rel_if_left_relI':
  assumes "x \<le>\<^bsub>L\<^esub> x'"
  and l1_R1_if_L1_r1: "\<And>y. in_codom (\<le>\<^bsub>R1\<^esub>) y \<Longrightarrow> x \<le>\<^bsub>L1\<^esub> r1 y \<Longrightarrow> l1 x \<le>\<^bsub>R1\<^esub> y"
  and R1_b_if_R1_l1: "\<And>y. y \<le>\<^bsub>R1\<^esub> l1 x' \<Longrightarrow> y \<le>\<^bsub>R1\<^esub> b y"
  and L2_r2_if_L2_b_if_R1_l1:
    "\<And>y y'. y \<le>\<^bsub>R1\<^esub> l1 x' \<Longrightarrow> y' \<le>\<^bsub>L2\<^esub> b y \<Longrightarrow> y' \<le>\<^bsub>L2\<^esub> r2 z'"
  and in_codom_R2_if_L2_b_if_R1_l1:
    "\<And>y y'. y \<le>\<^bsub>R1\<^esub> l1 x' \<Longrightarrow> y' \<le>\<^bsub>L2\<^esub> b y \<Longrightarrow> in_codom (\<le>\<^bsub>R2\<^esub>) z'"
  and t_R1_if_R1_l1_if_l1_R1:
    "\<And>y y' y''. l1 x \<le>\<^bsub>R1\<^esub> y \<Longrightarrow> l1 x \<le>\<^bsub>R1\<^esub> y' \<Longrightarrow> t y \<le>\<^bsub>R1\<^esub> y'"
  and R2_l2_t_if_in_dom_L2_t_if_l1_R1:
    "\<And>y y'. l1 x \<le>\<^bsub>R1\<^esub> y \<Longrightarrow> in_dom (\<le>\<^bsub>L2\<^esub>) (t y) \<Longrightarrow> z \<le>\<^bsub>R2\<^esub> l2 (t y)"
  and in_codom_L2_t_if_in_dom_L2_t_if_l1_R1:
    "\<And>y y'. l1 x \<le>\<^bsub>R1\<^esub> y \<Longrightarrow> in_dom (\<le>\<^bsub>L2\<^esub>) (t y) \<Longrightarrow> in_codom (\<le>\<^bsub>L2\<^esub>) (t y)"
  and rel_comp_le: "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  and in_dom_rel_comp_le: "in_dom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_dom (\<le>\<^bsub>L2\<^esub>)"
  shows "z \<le>\<^bsub>R\<^esub> z'"
proof -
  from \<open>x \<le>\<^bsub>L\<^esub> x'\<close> obtain yl yl' where "l1 x \<le>\<^bsub>R1\<^esub> yl" "yl \<le>\<^bsub>L2\<^esub> yl'" "yl' \<le>\<^bsub>R1\<^esub> l1 x'"
    using l1_R1_if_L1_r1 by blast
  moreover then have "yl' \<le>\<^bsub>R1\<^esub> b yl'" by (intro R1_b_if_R1_l1)
  ultimately have "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) (l1 x) (b yl')" using rel_comp_le by blast
  then obtain y where "l1 x \<le>\<^bsub>R1\<^esub> y" "y \<le>\<^bsub>L2\<^esub> b yl'" by blast
  show "z \<le>\<^bsub>R\<^esub> z'"
  proof (rule flip.left_relI)
    from \<open>yl' \<le>\<^bsub>R1\<^esub> l1 x'\<close> \<open>y \<le>\<^bsub>L2\<^esub> b yl'\<close>
      have "in_codom (\<le>\<^bsub>R2\<^esub>) z'" "y \<le>\<^bsub>L2\<^esub> r2 z'"
      by (auto intro: in_codom_R2_if_L2_b_if_R1_l1 L2_r2_if_L2_b_if_R1_l1)
    then show "y \<^bsub>L2\<^esub>\<lessapprox> z'" by blast
    from \<open>l1 x \<le>\<^bsub>R1\<^esub> yl\<close> \<open>l1 x \<le>\<^bsub>R1\<^esub> y\<close> show "t yl \<le>\<^bsub>R1\<^esub> y" by (rule t_R1_if_R1_l1_if_l1_R1)
    show "z \<^bsub>R2\<^esub>\<lessapprox> t yl"
    proof (rule flip.t1.GaloisI)
      from \<open>l1 x \<le>\<^bsub>R1\<^esub> yl\<close> have "t yl \<le>\<^bsub>R1\<^esub> yl" by (intro t_R1_if_R1_l1_if_l1_R1)
      with \<open>yl \<le>\<^bsub>L2\<^esub> yl'\<close> \<open>yl' \<le>\<^bsub>R1\<^esub> l1 x'\<close> in_dom_rel_comp_le have "in_dom (\<le>\<^bsub>L2\<^esub>) (t yl)"
        by blast
      with \<open>l1 x \<le>\<^bsub>R1\<^esub> yl\<close>
        show "z \<le>\<^bsub>R2\<^esub> l2 (t yl)" "in_codom (\<le>\<^bsub>L2\<^esub>) (t yl)" by (auto intro:
          R2_l2_t_if_in_dom_L2_t_if_l1_R1 in_codom_L2_t_if_in_dom_L2_t_if_l1_R1)
    qed
  qed
qed

subparagraph \<open>Simplification of Monotonicity Assumptions\<close>

text \<open>Some sufficient conditions for monotonicity assumptions that repeatedly
arise in various places.\<close>

lemma mono_in_dom_left_rel_left1_if_in_dom_rel_comp_le:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "in_dom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_dom (\<le>\<^bsub>L2\<^esub>)"
  shows "([in_dom (\<le>\<^bsub>L\<^esub>)] \<Rrightarrow>\<^sub>m in_dom (\<le>\<^bsub>L2\<^esub>)) l1"
  using assms by (intro dep_mono_wrt_predI) blast

lemma mono_in_codom_left_rel_left1_if_in_codom_rel_comp_le:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "in_codom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_codom (\<le>\<^bsub>L2\<^esub>)"
  shows "([in_codom (\<le>\<^bsub>L\<^esub>)] \<Rrightarrow>\<^sub>m in_codom (\<le>\<^bsub>L2\<^esub>)) l1"
  using assms by (intro dep_mono_wrt_predI) blast

subparagraph \<open>Simplification of Compatibility Conditions\<close>

text \<open>Most results will depend on certain compatibility conditions between
@{term "(\<le>\<^bsub>R1\<^esub>)"} and @{term "(\<le>\<^bsub>L2\<^esub>)"}. We next derive some sufficient assumptions
for these conditions.\<close>

end

lemma rel_comp_comp_le_rel_comp_if_rel_comp_comp_if_in_dom_leI:
  assumes trans_R: "transitive R"
  and refl_S: "reflexive_on P S"
  and in_dom_le: "in_dom (R \<circ>\<circ> S \<circ>\<circ> R) \<le> P"
  and rel_comp_le: "(S \<circ>\<circ> R \<circ>\<circ> S) \<le> (S \<circ>\<circ> R)"
  shows "(R \<circ>\<circ> S \<circ>\<circ> R) \<le> (S \<circ>\<circ> R)"
proof (intro le_relI)
  fix x y assume "(R \<circ>\<circ> S \<circ>\<circ> R) x y"
  moreover with in_dom_le refl_S have "S x x" by blast
  ultimately have "((S \<circ>\<circ> R \<circ>\<circ> S) \<circ>\<circ> R) x y" by blast
  with rel_comp_le have "(S \<circ>\<circ> R \<circ>\<circ> R) x y" by blast
  with trans_R show "(S \<circ>\<circ> R) x y" by blast
qed

lemma rel_comp_comp_le_rel_comp_if_rel_comp_comp_if_in_codom_leI:
  assumes trans_R: "transitive R"
  and refl_S: "reflexive_on P S"
  and in_codom_le: "in_codom (R \<circ>\<circ> S \<circ>\<circ> R) \<le> P"
  and rel_comp_le: "(S \<circ>\<circ> R \<circ>\<circ> S) \<le> (R \<circ>\<circ> S)"
  shows "(R \<circ>\<circ> S \<circ>\<circ> R) \<le> (R \<circ>\<circ> S)"
proof (intro le_relI)
  fix x y assume "(R \<circ>\<circ> S \<circ>\<circ> R) x y"
  moreover with in_codom_le refl_S have "S y y" by blast
  ultimately have "(R \<circ>\<circ> (S \<circ>\<circ> R \<circ>\<circ> S)) x y" by blast
  with rel_comp_le have "(R \<circ>\<circ> R \<circ>\<circ> S) x y" by blast
  with trans_R show "(R \<circ>\<circ> S) x y" by blast
qed

lemma rel_comp_comp_le_rel_comp_if_rel_comp_le_if_transitive:
  assumes trans_R: "transitive R"
  and R_S_le: "(R \<circ>\<circ> S) \<le> (S \<circ>\<circ> R)"
  shows "(R \<circ>\<circ> S \<circ>\<circ> R) \<le> (S \<circ>\<circ> R)"
proof -
  from trans_R have R_R_le: "(R \<circ>\<circ> R) \<le> R" by (intro rel_comp_le_self_if_transitive)
  have "(R \<circ>\<circ> S \<circ>\<circ> R) \<le> (S \<circ>\<circ> R \<circ>\<circ> R)"
    using monoD[OF mono_rel_comp1 R_S_le] by blast
  also have "... \<le> (S \<circ>\<circ> R)"
    using monoD[OF mono_rel_comp2 R_R_le] by (auto simp flip: rel_comp_assoc)
  finally show ?thesis .
qed

lemma rel_comp_comp_le_rel_comp_if_rel_comp_le_if_transitive':
  assumes trans_R: "transitive R"
  and S_R_le: "(S \<circ>\<circ> R) \<le> (R \<circ>\<circ> S)"
  shows "(R \<circ>\<circ> S \<circ>\<circ> R) \<le> (R \<circ>\<circ> S)"
proof -
  from trans_R have R_R_le: "(R \<circ>\<circ> R) \<le> R" by (intro rel_comp_le_self_if_transitive)
  have "(R \<circ>\<circ> S \<circ>\<circ> R) \<le> (R \<circ>\<circ> R \<circ>\<circ> S)"
    using monoD[OF mono_rel_comp2 S_R_le] by (auto simp flip: rel_comp_assoc)
  also have "... \<le> (R \<circ>\<circ> S)" using monoD[OF mono_rel_comp1 R_R_le] by blast
  finally show ?thesis .
qed

lemma rel_comp_eq_rel_comp_if_le_if_transitive_if_reflexive:
  assumes refl_R: "reflexive_on (in_field S) R"
  and trans_S: "transitive S"
  and R_le: "R \<le> S \<squnion> (=)"
  shows "(R \<circ>\<circ> S) = (S \<circ>\<circ> R)"
proof (intro ext iffI)
  fix x y assume "(R \<circ>\<circ> S) x y"
  then obtain z where "R x z" "S z y" by blast
  with R_le have "(S \<squnion> (=)) x z" by blast
  with \<open>S z y\<close> trans_S have "S x y" by auto
  moreover from \<open>S z y\<close> refl_R have "R y y" by blast
  ultimately show "(S \<circ>\<circ> R) x y" by blast
next
  fix x y assume "(S \<circ>\<circ> R) x y"
  then obtain z where "S x z" "R z y" by blast
  with R_le have "(S \<squnion> (=)) z y" by blast
  with \<open>S x z\<close> trans_S have "S x y" by auto
  moreover from \<open>S x y\<close> refl_R have "R x x" by blast
  ultimately show "(R \<circ>\<circ> S) x y" by blast
qed

lemma rel_comp_eq_rel_comp_if_in_field_le_if_le_eq:
  assumes le_eq: "R \<le> (=)"
  and in_field_le: "in_field S \<le> in_field R"
  shows "(R \<circ>\<circ> S) = (S \<circ>\<circ> R)"
proof (intro ext iffI)
  fix x y assume "(R \<circ>\<circ> S) x y"
  then obtain z where "R x z" "S z y" by blast
  with le_eq have "S x y" by blast
  with assms show "(S \<circ>\<circ> R) x y" by blast
next
  fix x y assume "(S \<circ>\<circ> R) x y"
  then obtain z where "S x z" "R z y" by blast
  with le_eq have "S x y" by blast
  with assms show "(R \<circ>\<circ> S) x y" by blast
qed

context transport_comp
begin

lemma left2_right1_left2_le_left2_right1_if_right1_left2_right1_le_left2_right1:
  assumes "reflexive_on (in_codom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  and "in_codom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_codom (\<le>\<^bsub>R1\<^esub>)"
  shows "((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  using assms by (intro rel_comp_comp_le_rel_comp_if_rel_comp_comp_if_in_codom_leI)
  auto

lemma left2_right1_left2_le_right1_left2_if_right1_left2_right1_le_right1_left2I:
  assumes "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  and "in_dom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_dom (\<le>\<^bsub>R1\<^esub>)"
  shows "((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  using assms by (intro rel_comp_comp_le_rel_comp_if_rel_comp_comp_if_in_dom_leI)
  auto

lemma in_dom_right1_left2_right1_le_if_right1_left2_right1_le:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  shows "in_dom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_dom (\<le>\<^bsub>L2\<^esub>)"
  using monoD[OF mono_in_dom assms] by (auto intro: in_dom_if_in_dom_rel_comp)

lemma in_codom_right1_left2_right1_le_if_right1_left2_right1_le:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  shows "in_codom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_codom (\<le>\<^bsub>L2\<^esub>)"
  using monoD[OF mono_in_codom assms]
  by (auto intro: in_codom_if_in_codom_rel_comp)

text \<open>Our main results will be derivable for two different sets of compatibility
conditions. The next two lemmas show the equivalence_rel between those two sets
under certain assumptions. In cases where these assumptions are met, we will
only state the result for one of the two compatibility conditions. The other one
will then be derivable using one of the following lemmas.\<close>

definition "middle_compatible_dom \<equiv>
  (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<le> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)
  \<and> in_dom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_dom (\<le>\<^bsub>L2\<^esub>)
  \<and> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))
  \<and> in_dom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_dom (\<le>\<^bsub>R1\<^esub>)"

lemma middle_compatible_domI [intro]:
  assumes "(\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<le> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)"
  and "in_dom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_dom (\<le>\<^bsub>L2\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  and "in_dom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_dom (\<le>\<^bsub>R1\<^esub>)"
  shows "middle_compatible_dom"
  unfolding middle_compatible_dom_def using assms by blast

lemma middle_compatible_domE [elim]:
  assumes "middle_compatible_dom"
  obtains "(\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<le> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)"
  and "in_dom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_dom (\<le>\<^bsub>L2\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  and "in_dom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_dom (\<le>\<^bsub>R1\<^esub>)"
  using assms unfolding middle_compatible_dom_def by blast

definition "middle_compatible_codom \<equiv>
  ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))
  \<and> in_codom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_codom (\<le>\<^bsub>L2\<^esub>)
  \<and> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<le> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)
  \<and> in_codom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_codom (\<le>\<^bsub>R1\<^esub>)"

lemma middle_compatible_codomI [intro]:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  and "in_codom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_codom (\<le>\<^bsub>L2\<^esub>)"
  and "(\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<le> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)"
  and "in_codom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_codom (\<le>\<^bsub>R1\<^esub>)"
  shows "middle_compatible_codom"
  unfolding middle_compatible_codom_def using assms by blast

lemma middle_compatible_codomE [elim]:
  assumes "middle_compatible_codom"
  obtains "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  and "in_codom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_codom (\<le>\<^bsub>L2\<^esub>)"
  and "(\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<le> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)"
  and "in_codom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_codom (\<le>\<^bsub>R1\<^esub>)"
  using assms unfolding middle_compatible_codom_def by blast

context
begin

interpretation flip : transport_comp R2 L2 r2 l2 R1 L1 r1 l1 .

lemma rel_comp_comp_le_assms_if_in_codom_rel_comp_comp_leI:
  assumes "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "preorder_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "middle_compatible_codom"
  shows "middle_compatible_dom"
  using assms by (intro middle_compatible_domI)
  (auto intro!:
    left2_right1_left2_le_left2_right1_if_right1_left2_right1_le_left2_right1
    flip.left2_right1_left2_le_left2_right1_if_right1_left2_right1_le_left2_right1
    in_dom_right1_left2_right1_le_if_right1_left2_right1_le
    flip.in_dom_right1_left2_right1_le_if_right1_left2_right1_le
    intro: reflexive_on_if_le_pred_if_reflexive_on in_field_if_in_codom)

lemma rel_comp_comp_le_assms_if_in_dom_rel_comp_comp_leI:
  assumes "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "preorder_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "middle_compatible_dom"
  shows "middle_compatible_codom"
  using assms by (intro middle_compatible_codomI)
  (auto intro!:
    left2_right1_left2_le_right1_left2_if_right1_left2_right1_le_right1_left2I
    flip.left2_right1_left2_le_right1_left2_if_right1_left2_right1_le_right1_left2I
    in_codom_right1_left2_right1_le_if_right1_left2_right1_le
    flip.in_codom_right1_left2_right1_le_if_right1_left2_right1_le
    intro: reflexive_on_if_le_pred_if_reflexive_on in_field_if_in_dom)

lemma middle_compatible_dom_iff_middle_compatible_codom_if_preorder_on:
  assumes "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "preorder_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  shows "middle_compatible_dom \<longleftrightarrow> middle_compatible_codom"
  using assms by (intro iffI rel_comp_comp_le_assms_if_in_codom_rel_comp_comp_leI)
  (auto intro!: rel_comp_comp_le_assms_if_in_dom_rel_comp_comp_leI)

end

text \<open>Finally we derive some sufficient assumptions for the compatibility
conditions.\<close>

lemma right1_left2_right1_le_assms_if_right1_left2_eqI:
  assumes "transitive (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) = ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  shows "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  and "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  using assms rel_comp_comp_le_rel_comp_if_rel_comp_le_if_transitive[of R1 L2]
  by auto

interpretation flip : transport_comp R2 L2 r2 l2 R1 L1 r1 l1
  rewrites "((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) = ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<equiv> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) = ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  by (simp only: eq_commute)

lemma middle_compatible_codom_if_rel_comp_eq_if_transitive:
  assumes "transitive (\<le>\<^bsub>R1\<^esub>)" "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) = ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  shows "middle_compatible_codom"
  using assms by (intro middle_compatible_codomI
    in_codom_right1_left2_right1_le_if_right1_left2_right1_le
    flip.in_codom_right1_left2_right1_le_if_right1_left2_right1_le
    right1_left2_right1_le_assms_if_right1_left2_eqI
    flip.right1_left2_right1_le_assms_if_right1_left2_eqI)
  auto

lemma middle_compatible_codom_if_right1_le_left2_eqI:
  assumes "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)" "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "(\<le>\<^bsub>R1\<^esub>) \<le> (\<le>\<^bsub>L2\<^esub>) \<squnion> (=)"
  and "in_field (\<le>\<^bsub>L2\<^esub>) \<le> in_field (\<le>\<^bsub>R1\<^esub>)"
  shows "middle_compatible_codom"
  using assms by (intro middle_compatible_codomI
    in_codom_right1_left2_right1_le_if_right1_left2_right1_le
    flip.in_codom_right1_left2_right1_le_if_right1_left2_right1_le
    right1_left2_right1_le_assms_if_right1_left2_eqI
    flip.right1_left2_right1_le_assms_if_right1_left2_eqI
    rel_comp_eq_rel_comp_if_le_if_transitive_if_reflexive)
  (auto intro: reflexive_on_if_le_pred_if_reflexive_on)

lemma middle_compatible_codom_if_right1_le_eqI:
  assumes "(\<le>\<^bsub>R1\<^esub>) \<le> (=)"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "in_field (\<le>\<^bsub>L2\<^esub>) \<le> in_field (\<le>\<^bsub>R1\<^esub>)"
  shows "middle_compatible_codom"
  using assms by (intro middle_compatible_codomI
    in_codom_right1_left2_right1_le_if_right1_left2_right1_le
    flip.in_codom_right1_left2_right1_le_if_right1_left2_right1_le
    right1_left2_right1_le_assms_if_right1_left2_eqI
    flip.right1_left2_right1_le_assms_if_right1_left2_eqI
    rel_comp_eq_rel_comp_if_in_field_le_if_le_eq)
  auto

end

end