(*  Title:      HOL/UNITY/ProgressSets.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2003  University of Cambridge

Progress Sets.  From

    David Meier and Beverly Sanders,
    Composing Leads-to Properties
    Theoretical Computer Science 243:1-2 (2000), 339-361.

    David Meier,
    Progress Properties in Program Refinement and Parallel Composition
    Swiss Federal Institute of Technology Zurich (1997)
*)

section{*Progress Sets*}

theory ProgressSets imports Transformers begin

subsection {*Complete Lattices and the Operator @{term cl}*}

definition lattice :: "'a set set => bool" where
   --{*Meier calls them closure sets, but they are just complete lattices*}
   "lattice L ==
         (\<forall>M. M \<subseteq> L --> \<Inter>M \<in> L) & (\<forall>M. M \<subseteq> L --> \<Union>M \<in> L)"

definition cl :: "['a set set, 'a set] => 'a set" where
   --{*short for ``closure''*}
   "cl L r == \<Inter>{x. x\<in>L & r \<subseteq> x}"

lemma UNIV_in_lattice: "lattice L ==> UNIV \<in> L"
by (force simp add: lattice_def)

lemma empty_in_lattice: "lattice L ==> {} \<in> L"
by (force simp add: lattice_def)

lemma Union_in_lattice: "[|M \<subseteq> L; lattice L|] ==> \<Union>M \<in> L"
by (simp add: lattice_def)

lemma Inter_in_lattice: "[|M \<subseteq> L; lattice L|] ==> \<Inter>M \<in> L"
by (simp add: lattice_def)

lemma UN_in_lattice:
     "[|lattice L; !!i. i\<in>I ==> r i \<in> L|] ==> (\<Union>i\<in>I. r i) \<in> L"
apply (unfold SUP_def)
apply (blast intro: Union_in_lattice)
done

lemma INT_in_lattice:
     "[|lattice L; !!i. i\<in>I ==> r i \<in> L|] ==> (\<Inter>i\<in>I. r i)  \<in> L"
apply (unfold INF_def)
apply (blast intro: Inter_in_lattice)
done

lemma Un_in_lattice: "[|x\<in>L; y\<in>L; lattice L|] ==> x\<union>y \<in> L"
  using Union_in_lattice [of "{x, y}" L] by simp

lemma Int_in_lattice: "[|x\<in>L; y\<in>L; lattice L|] ==> x\<inter>y \<in> L"
  using Inter_in_lattice [of "{x, y}" L] by simp

lemma lattice_stable: "lattice {X. F \<in> stable X}"
by (simp add: lattice_def stable_def constrains_def, blast)

text{*The next three results state that @{term "cl L r"} is the minimal
 element of @{term L} that includes @{term r}.*}
lemma cl_in_lattice: "lattice L ==> cl L r \<in> L"
apply (simp add: lattice_def cl_def)
apply (erule conjE)
apply (drule spec, erule mp, blast)
done

lemma cl_least: "[|c\<in>L; r\<subseteq>c|] ==> cl L r \<subseteq> c"
by (force simp add: cl_def)

text{*The next three lemmas constitute assertion (4.61)*}
lemma cl_mono: "r \<subseteq> r' ==> cl L r \<subseteq> cl L r'"
by (simp add: cl_def, blast)

lemma subset_cl: "r \<subseteq> cl L r"
by (simp add: cl_def le_Inf_iff)

text{*A reformulation of @{thm subset_cl}*}
lemma clI: "x \<in> r ==> x \<in> cl L r"
by (simp add: cl_def, blast)

text{*A reformulation of @{thm cl_least}*}
lemma clD: "[|c \<in> cl L r; B \<in> L; r \<subseteq> B|] ==> c \<in> B"
by (force simp add: cl_def)

lemma cl_UN_subset: "(\<Union>i\<in>I. cl L (r i)) \<subseteq> cl L (\<Union>i\<in>I. r i)"
by (simp add: cl_def, blast)

lemma cl_Un: "lattice L ==> cl L (r\<union>s) = cl L r \<union> cl L s"
apply (rule equalityI)
 prefer 2
  apply (simp add: cl_def, blast)
apply (rule cl_least)
 apply (blast intro: Un_in_lattice cl_in_lattice)
apply (blast intro: subset_cl [THEN subsetD])
done

lemma cl_UN: "lattice L ==> cl L (\<Union>i\<in>I. r i) = (\<Union>i\<in>I. cl L (r i))"
apply (rule equalityI)
 prefer 2 apply (simp add: cl_def, blast)
apply (rule cl_least)
 apply (blast intro: UN_in_lattice cl_in_lattice)
apply (blast intro: subset_cl [THEN subsetD])
done

lemma cl_Int_subset: "cl L (r\<inter>s) \<subseteq> cl L r \<inter> cl L s"
by (simp add: cl_def, blast)

lemma cl_idem [simp]: "cl L (cl L r) = cl L r"
by (simp add: cl_def, blast)

lemma cl_ident: "r\<in>L ==> cl L r = r"
by (force simp add: cl_def)

lemma cl_empty [simp]: "lattice L ==> cl L {} = {}"
by (simp add: cl_ident empty_in_lattice)

lemma cl_UNIV [simp]: "lattice L ==> cl L UNIV = UNIV"
by (simp add: cl_ident UNIV_in_lattice)

text{*Assertion (4.62)*}
lemma cl_ident_iff: "lattice L ==> (cl L r = r) = (r\<in>L)"
apply (rule iffI)
 apply (erule subst)
 apply (erule cl_in_lattice)
apply (erule cl_ident)
done

lemma cl_subset_in_lattice: "[|cl L r \<subseteq> r; lattice L|] ==> r\<in>L"
by (simp add: cl_ident_iff [symmetric] equalityI subset_cl)

subsection {*Progress Sets and the Main Lemma*}
text{*A progress set satisfies certain closure conditions and is a
simple way of including the set @{term "wens_set F B"}.*}

definition closed :: "['a program, 'a set, 'a set,  'a set set] => bool" where
   "closed F T B L == \<forall>M. \<forall>act \<in> Acts F. B\<subseteq>M & T\<inter>M \<in> L -->
                              T \<inter> (B \<union> wp act M) \<in> L"

definition progress_set :: "['a program, 'a set, 'a set] => 'a set set set" where
   "progress_set F T B ==
      {L. lattice L & B \<in> L & T \<in> L & closed F T B L}"

lemma closedD:
   "[|closed F T B L; act \<in> Acts F; B\<subseteq>M; T\<inter>M \<in> L|]
    ==> T \<inter> (B \<union> wp act M) \<in> L"
by (simp add: closed_def)

text{*Note: the formalization below replaces Meier's @{term q} by @{term B}
and @{term m} by @{term X}. *}

text{*Part of the proof of the claim at the bottom of page 97.  It's
proved separately because the argument requires a generalization over
all @{term "act \<in> Acts F"}.*}
lemma lattice_awp_lemma:
  assumes TXC:  "T\<inter>X \<in> C" --{*induction hypothesis in theorem below*}
      and BsubX:  "B \<subseteq> X"   --{*holds in inductive step*}
      and latt: "lattice C"
      and TC:   "T \<in> C"
      and BC:   "B \<in> C"
      and clos: "closed F T B C"
    shows "T \<inter> (B \<union> awp F (X \<union> cl C (T\<inter>r))) \<in> C"
apply (simp del: INT_simps add: awp_def INT_extend_simps)
apply (rule INT_in_lattice [OF latt])
apply (erule closedD [OF clos])
apply (simp add: subset_trans [OF BsubX Un_upper1])
apply (subgoal_tac "T \<inter> (X \<union> cl C (T\<inter>r)) = (T\<inter>X) \<union> cl C (T\<inter>r)")
 prefer 2 apply (blast intro: TC clD)
apply (erule ssubst)
apply (blast intro: Un_in_lattice latt cl_in_lattice TXC)
done

text{*Remainder of the proof of the claim at the bottom of page 97.*}
lemma lattice_lemma:
  assumes TXC:  "T\<inter>X \<in> C" --{*induction hypothesis in theorem below*}
      and BsubX:  "B \<subseteq> X"   --{*holds in inductive step*}
      and act:  "act \<in> Acts F"
      and latt: "lattice C"
      and TC:   "T \<in> C"
      and BC:   "B \<in> C"
      and clos: "closed F T B C"
    shows "T \<inter> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)) \<union> X) \<in> C"
apply (subgoal_tac "T \<inter> (B \<union> wp act X) \<in> C")
 prefer 2 apply (simp add: closedD [OF clos] act BsubX TXC)
apply (drule Int_in_lattice
              [OF _ lattice_awp_lemma [OF TXC BsubX latt TC BC clos, of r]
                    latt])
apply (subgoal_tac
         "T \<inter> (B \<union> wp act X) \<inter> (T \<inter> (B \<union> awp F (X \<union> cl C (T\<inter>r)))) =
          T \<inter> (B \<union> wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)))")
 prefer 2 apply blast
apply simp
apply (drule Un_in_lattice [OF _ TXC latt])
apply (subgoal_tac
         "T \<inter> (B \<union> wp act X \<inter> awp F (X \<union> cl C (T\<inter>r))) \<union> T\<inter>X =
          T \<inter> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)) \<union> X)")
 apply simp
apply (blast intro: BsubX [THEN subsetD])
done

text{*Induction step for the main lemma*}
lemma progress_induction_step:
  assumes TXC:  "T\<inter>X \<in> C" --{*induction hypothesis in theorem below*}
      and act:  "act \<in> Acts F"
      and Xwens: "X \<in> wens_set F B"
      and latt: "lattice C"
      and  TC:  "T \<in> C"
      and  BC:  "B \<in> C"
      and clos: "closed F T B C"
      and Fstable: "F \<in> stable T"
  shows "T \<inter> wens F act X \<in> C"
proof -
  from Xwens have BsubX: "B \<subseteq> X"
    by (rule wens_set_imp_subset)
  let ?r = "wens F act X"
  have "?r \<subseteq> (wp act X \<inter> awp F (X\<union>?r)) \<union> X"
    by (simp add: wens_unfold [symmetric])
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (X\<union>?r)) \<union> X)"
    by blast
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (T \<inter> (X\<union>?r))) \<union> X)"
    by (simp add: awp_Int_eq Fstable stable_imp_awp_ident, blast)
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X)"
    by (blast intro: awp_mono [THEN [2] rev_subsetD] subset_cl [THEN subsetD])
  then have "cl C (T\<inter>?r) \<subseteq>
             cl C (T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X))"
    by (rule cl_mono)
  then have "cl C (T\<inter>?r) \<subseteq>
             T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X)"
    by (simp add: cl_ident lattice_lemma [OF TXC BsubX act latt TC BC clos])
  then have "cl C (T\<inter>?r) \<subseteq> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X"
    by blast
  then have "cl C (T\<inter>?r) \<subseteq> ?r"
    by (blast intro!: subset_wens)
  then have cl_subset: "cl C (T\<inter>?r) \<subseteq> T\<inter>?r"
    by (simp add: cl_ident TC
                  subset_trans [OF cl_mono [OF Int_lower1]])
  show ?thesis
    by (rule cl_subset_in_lattice [OF cl_subset latt])
qed

text{*Proved on page 96 of Meier's thesis.  The special case when
   @{term "T=UNIV"} states that every progress set for the program @{term F}
   and set @{term B} includes the set @{term "wens_set F B"}.*}
lemma progress_set_lemma:
     "[|C \<in> progress_set F T B; r \<in> wens_set F B; F \<in> stable T|] ==> T\<inter>r \<in> C"
apply (simp add: progress_set_def, clarify)
apply (erule wens_set.induct)
  txt{*Base*}
  apply (simp add: Int_in_lattice)
 txt{*The difficult @{term wens} case*}
 apply (simp add: progress_induction_step)
txt{*Disjunctive case*}
apply (subgoal_tac "(\<Union>U\<in>W. T \<inter> U) \<in> C")
 apply simp
apply (blast intro: UN_in_lattice)
done

subsection {*The Progress Set Union Theorem*}

lemma closed_mono:
  assumes BB':  "B \<subseteq> B'"
      and TBwp: "T \<inter> (B \<union> wp act M) \<in> C"
      and B'C:  "B' \<in> C"
      and TC:   "T \<in> C"
      and latt: "lattice C"
  shows "T \<inter> (B' \<union> wp act M) \<in> C"
proof -
  from TBwp have "(T\<inter>B) \<union> (T \<inter> wp act M) \<in> C"
    by (simp add: Int_Un_distrib)
  then have TBBC: "(T\<inter>B') \<union> ((T\<inter>B) \<union> (T \<inter> wp act M)) \<in> C"
    by (blast intro: Int_in_lattice Un_in_lattice TC B'C latt)
  show ?thesis
    by (rule eqelem_imp_iff [THEN iffD1, OF _ TBBC],
        blast intro: BB' [THEN subsetD])
qed

lemma progress_set_mono:
    assumes BB':  "B \<subseteq> B'"
    shows
     "[| B' \<in> C;  C \<in> progress_set F T B|]
      ==> C \<in> progress_set F T B'"
by (simp add: progress_set_def closed_def closed_mono [OF BB']
                 subset_trans [OF BB'])

theorem progress_set_Union:
  assumes leadsTo: "F \<in> A leadsTo B'"
      and prog: "C \<in> progress_set F T B"
      and Fstable: "F \<in> stable T"
      and BB':  "B \<subseteq> B'"
      and B'C:  "B' \<in> C"
      and Gco: "!!X. X\<in>C ==> G \<in> X-B co X"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B'"
apply (insert prog Fstable)
apply (rule leadsTo_Join [OF leadsTo])
  apply (force simp add: progress_set_def awp_iff_stable [symmetric])
apply (simp add: awp_iff_constrains)
apply (drule progress_set_mono [OF BB' B'C])
apply (blast intro: progress_set_lemma Gco constrains_weaken_L
                    BB' [THEN subsetD])
done

subsection {*Some Progress Sets*}

lemma UNIV_in_progress_set: "UNIV \<in> progress_set F T B"
by (simp add: progress_set_def lattice_def closed_def)

subsubsection {*Lattices and Relations*}
text{*From Meier's thesis, section 4.5.3*}

definition relcl :: "'a set set => ('a * 'a) set" where
    -- {*Derived relation from a lattice*}
    "relcl L == {(x,y). y \<in> cl L {x}}"

definition latticeof :: "('a * 'a) set => 'a set set" where
    -- {*Derived lattice from a relation: the set of upwards-closed sets*}
    "latticeof r == {X. \<forall>s t. s \<in> X & (s,t) \<in> r --> t \<in> X}"

lemma relcl_refl: "(a,a) \<in> relcl L"
by (simp add: relcl_def subset_cl [THEN subsetD])

lemma relcl_trans:
     "[| (a,b) \<in> relcl L; (b,c) \<in> relcl L; lattice L |] ==> (a,c) \<in> relcl L"
apply (simp add: relcl_def)
apply (blast intro: clD cl_in_lattice)
done

lemma refl_relcl: "lattice L ==> refl (relcl L)"
by (simp add: refl_onI relcl_def subset_cl [THEN subsetD])

lemma trans_relcl: "lattice L ==> trans (relcl L)"
by (blast intro: relcl_trans transI)

lemma lattice_latticeof: "lattice (latticeof r)"
by (auto simp add: lattice_def latticeof_def)

lemma lattice_singletonI:
     "[|lattice L; !!s. s \<in> X ==> {s} \<in> L|] ==> X \<in> L"
apply (cut_tac UN_singleton [of X])
apply (erule subst)
apply (simp only: UN_in_lattice)
done

text{*Equation (4.71) of Meier's thesis.  He gives no proof.*}
lemma cl_latticeof:
     "[|refl r; trans r|]
      ==> cl (latticeof r) X = {t. \<exists>s. s\<in>X & (s,t) \<in> r}"
apply (rule equalityI)
 apply (rule cl_least)
  apply (simp (no_asm_use) add: latticeof_def trans_def, blast)
 apply (simp add: latticeof_def refl_on_def, blast)
apply (simp add: latticeof_def, clarify)
apply (unfold cl_def, blast)
done

text{*Related to (4.71).*}
lemma cl_eq_Collect_relcl:
     "lattice L ==> cl L X = {t. \<exists>s. s\<in>X & (s,t) \<in> relcl L}"
apply (cut_tac UN_singleton [of X])
apply (erule subst)
apply (force simp only: relcl_def cl_UN)
done

text{*Meier's theorem of section 4.5.3*}
theorem latticeof_relcl_eq: "lattice L ==> latticeof (relcl L) = L"
apply (rule equalityI)
 prefer 2 apply (force simp add: latticeof_def relcl_def cl_def, clarify)
apply (rename_tac X)
apply (rule cl_subset_in_lattice)
 prefer 2 apply assumption
apply (drule cl_ident_iff [OF lattice_latticeof, THEN iffD2])
apply (drule equalityD1)
apply (rule subset_trans)
 prefer 2 apply assumption
apply (thin_tac "?U \<subseteq> X")
apply (cut_tac A=X in UN_singleton)
apply (erule subst)
apply (simp only: cl_UN lattice_latticeof
                  cl_latticeof [OF refl_relcl trans_relcl])
apply (simp add: relcl_def)
done

theorem relcl_latticeof_eq:
     "[|refl r; trans r|] ==> relcl (latticeof r) = r"
by (simp add: relcl_def cl_latticeof)

subsubsection {*Decoupling Theorems*}

definition decoupled :: "['a program, 'a program] => bool" where
   "decoupled F G ==
        \<forall>act \<in> Acts F. \<forall>B. G \<in> stable B --> G \<in> stable (wp act B)"

text{*Rao's Decoupling Theorem*}
lemma stableco: "F \<in> stable A ==> F \<in> A-B co A"
by (simp add: stable_def constrains_def, blast)

theorem decoupling:
  assumes leadsTo: "F \<in> A leadsTo B"
      and Gstable: "G \<in> stable B"
      and dec:     "decoupled F G"
  shows "F\<squnion>G \<in> A leadsTo B"
proof -
  have prog: "{X. G \<in> stable X} \<in> progress_set F UNIV B"
    by (simp add: progress_set_def lattice_stable Gstable closed_def
                  stable_Un [OF Gstable] dec [unfolded decoupled_def])
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B"
    by (rule progress_set_Union [OF leadsTo prog],
        simp_all add: Gstable stableco)
  thus ?thesis by simp
qed

text{*Rao's Weak Decoupling Theorem*}
theorem weak_decoupling:
  assumes leadsTo: "F \<in> A leadsTo B"
      and stable: "F\<squnion>G \<in> stable B"
      and dec:     "decoupled F (F\<squnion>G)"
  shows "F\<squnion>G \<in> A leadsTo B"
proof -
  have prog: "{X. F\<squnion>G \<in> stable X} \<in> progress_set F UNIV B"
    by (simp del: Join_stable
             add: progress_set_def lattice_stable stable closed_def
                  stable_Un [OF stable] dec [unfolded decoupled_def])
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B"
    by (rule progress_set_Union [OF leadsTo prog],
        simp_all del: Join_stable add: stable,
        simp add: stableco)
  thus ?thesis by simp
qed

text{*The ``Decoupling via @{term G'} Union Theorem''*}
theorem decoupling_via_aux:
  assumes leadsTo: "F \<in> A leadsTo B"
      and prog: "{X. G' \<in> stable X} \<in> progress_set F UNIV B"
      and GG':  "G \<le> G'"
               --{*Beware!  This is the converse of the refinement relation!*}
  shows "F\<squnion>G \<in> A leadsTo B"
proof -
  from prog have stable: "G' \<in> stable B"
    by (simp add: progress_set_def)
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B"
    by (rule progress_set_Union [OF leadsTo prog],
        simp_all add: stable stableco component_stable [OF GG'])
  thus ?thesis by simp
qed

subsection{*Composition Theorems Based on Monotonicity and Commutativity*}

subsubsection{*Commutativity of @{term "cl L"} and assignment.*}
definition commutes :: "['a program, 'a set, 'a set,  'a set set] => bool" where
   "commutes F T B L ==
       \<forall>M. \<forall>act \<in> Acts F. B \<subseteq> M -->
           cl L (T \<inter> wp act M) \<subseteq> T \<inter> (B \<union> wp act (cl L (T\<inter>M)))"

text{*From Meier's thesis, section 4.5.6*}
lemma commutativity1_lemma:
  assumes commutes: "commutes F T B L"
      and lattice:  "lattice L"
      and BL: "B \<in> L"
      and TL: "T \<in> L"
  shows "closed F T B L"
apply (simp add: closed_def, clarify)
apply (rule ProgressSets.cl_subset_in_lattice [OF _ lattice])
apply (simp add: Int_Un_distrib cl_Un [OF lattice]
                 cl_ident Int_in_lattice [OF TL BL lattice] Un_upper1)
apply (subgoal_tac "cl L (T \<inter> wp act M) \<subseteq> T \<inter> (B \<union> wp act (cl L (T \<inter> M)))")
 prefer 2
 apply (cut_tac commutes, simp add: commutes_def)
apply (erule subset_trans)
apply (simp add: cl_ident)
apply (blast intro: rev_subsetD [OF _ wp_mono])
done

text{*Version packaged with @{thm progress_set_Union}*}
lemma commutativity1:
  assumes leadsTo: "F \<in> A leadsTo B"
      and lattice:  "lattice L"
      and BL: "B \<in> L"
      and TL: "T \<in> L"
      and Fstable: "F \<in> stable T"
      and Gco: "!!X. X\<in>L ==> G \<in> X-B co X"
      and commutes: "commutes F T B L"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
by (rule progress_set_Union [OF leadsTo _ Fstable subset_refl BL Gco],
    simp add: progress_set_def commutativity1_lemma commutes lattice BL TL)

text{*Possibly move to Relation.thy, after @{term single_valued}*}
definition funof :: "[('a*'b)set, 'a] => 'b" where
   "funof r == (\<lambda>x. THE y. (x,y) \<in> r)"

lemma funof_eq: "[|single_valued r; (x,y) \<in> r|] ==> funof r x = y"
by (simp add: funof_def single_valued_def, blast)

lemma funof_Pair_in:
     "[|single_valued r; x \<in> Domain r|] ==> (x, funof r x) \<in> r"
by (force simp add: funof_eq)

lemma funof_in:
     "[|r``{x} \<subseteq> A; single_valued r; x \<in> Domain r|] ==> funof r x \<in> A"
by (force simp add: funof_eq)

lemma funof_imp_wp: "[|funof act t \<in> A; single_valued act|] ==> t \<in> wp act A"
by (force simp add: in_wp_iff funof_eq)

subsubsection{*Commutativity of Functions and Relation*}
text{*Thesis, page 109*}

(*FIXME: this proof is still an ungodly mess*)
text{*From Meier's thesis, section 4.5.6*}
lemma commutativity2_lemma:
  assumes dcommutes:
      "\<And>act s t. act \<in> Acts F \<Longrightarrow> s \<in> T \<Longrightarrow> (s, t) \<in> relcl L \<Longrightarrow>
        s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
    and determ: "!!act. act \<in> Acts F ==> single_valued act"
    and total: "!!act. act \<in> Acts F ==> Domain act = UNIV"
    and lattice:  "lattice L"
    and BL: "B \<in> L"
    and TL: "T \<in> L"
    and Fstable: "F \<in> stable T"
  shows  "commutes F T B L"
proof -
  { fix M and act and t
    assume 1: "B \<subseteq> M" "act \<in> Acts F" "t \<in> cl L (T \<inter> wp act M)"
    then have "\<exists>s. (s,t) \<in> relcl L \<and> s \<in> T \<inter> wp act M"
      by (force simp add: cl_eq_Collect_relcl [OF lattice])
    then obtain s where 2: "(s, t) \<in> relcl L" "s \<in> T" "s \<in> wp act M"
      by blast
    then have 3: "\<forall>u\<in>L. s \<in> u --> t \<in> u"
      apply (intro ballI impI)
      apply (subst cl_ident [symmetric], assumption)
      apply (simp add: relcl_def)
      apply (blast intro: cl_mono [THEN [2] rev_subsetD])
      done
    with 1 2 Fstable have 4: "funof act s \<in> T\<inter>M"
      by (force intro!: funof_in
        simp add: wp_def stable_def constrains_def determ total)
    with 1 2 3 have 5: "s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
      by (intro dcommutes) assumption+
    with 1 2 3 4 have "t \<in> B | funof act t \<in> cl L (T\<inter>M)"
      by (simp add: relcl_def) (blast intro: BL cl_mono [THEN [2] rev_subsetD])
    with 1 2 3 4 5 have "t \<in> B | t \<in> wp act (cl L (T\<inter>M))"
      by (blast intro: funof_imp_wp determ)
    with 2 3 have "t \<in> T \<and> (t \<in> B \<or> t \<in> wp act (cl L (T \<inter> M)))"
      by (blast intro: TL cl_mono [THEN [2] rev_subsetD])
    then have"t \<in> T \<inter> (B \<union> wp act (cl L (T \<inter> M)))"
      by simp
  }
  then show "commutes F T B L" unfolding commutes_def by clarify
qed

text{*Version packaged with @{thm progress_set_Union}*}
lemma commutativity2:
  assumes leadsTo: "F \<in> A leadsTo B"
      and dcommutes:
        "\<forall>act \<in> Acts F.
         \<forall>s \<in> T. \<forall>t. (s,t) \<in> relcl L -->
                      s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
      and determ: "!!act. act \<in> Acts F ==> single_valued act"
      and total: "!!act. act \<in> Acts F ==> Domain act = UNIV"
      and lattice:  "lattice L"
      and BL: "B \<in> L"
      and TL: "T \<in> L"
      and Fstable: "F \<in> stable T"
      and Gco: "!!X. X\<in>L ==> G \<in> X-B co X"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
apply (rule commutativity1 [OF leadsTo lattice])
apply (simp_all add: Gco commutativity2_lemma dcommutes determ total
                     lattice BL TL Fstable)
done

subsection {*Monotonicity*}
text{*From Meier's thesis, section 4.5.7, page 110*}
(*to be continued?*)

end


section \<open>Union-Find Data-Structure\<close>
theory Union_Find_Fun
imports
  Collections.Partial_Equivalence_Relation
 (* "../Sep_Main"
  "HOL-Library.Code_Target_Numeral" *)
begin
text \<open>
  We implement a simple union-find data-structure based on an array.
  It uses path compression and a size-based union heuristics.
\<close>

subsection \<open>Abstract Union-Find on Lists\<close>
text \<open>
  We first formulate union-find structures on lists, and later implement
  them using Imperative/HOL. This is a separation of proof concerns
  between proving the algorithmic idea correct and generating the verification
  conditions.
\<close>

subsubsection \<open>Representatives\<close>
text \<open>
  We define a function that searches for the representative of an element.
  This function is only partially defined, as it does not terminate on all
  lists. We use the domain of this function to characterize valid union-find
  lists.
\<close>
function (domintros) rep_of
  where "rep_of l i = (if l!i = i then i else rep_of l (l!i))"
  by pat_completeness auto

text \<open>A valid union-find structure only contains valid indexes, and
  the \<open>rep_of\<close> function terminates for all indexes.\<close>
definition
  "ufa_invar l \<equiv> \<forall>i<length l. rep_of_dom (l,i) \<and> l!i<length l"

lemma ufa_invarD:
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> rep_of_dom (l,i)"
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> l!i<length l"
  unfolding ufa_invar_def by auto

text \<open>We derive the following equations for the \<open>rep-of\<close> function.\<close>
lemma rep_of_refl: "l!i=i \<Longrightarrow> rep_of l i = i"
  apply (subst rep_of.psimps)
  apply (rule rep_of.domintros)
  apply (auto)
  done

lemma rep_of_step:
  "\<lbrakk>ufa_invar l; i<length l; l!i\<noteq>i\<rbrakk> \<Longrightarrow> rep_of l i = rep_of l (l!i)"
  apply (subst rep_of.psimps)
  apply (auto dest: ufa_invarD)
  done

lemmas rep_of_simps = rep_of_refl rep_of_step

lemma rep_of_iff: "\<lbrakk>ufa_invar l; i<length l\<rbrakk>
  \<Longrightarrow> rep_of l i = (if l!i=i then i else rep_of l (l!i))"
  by (simp add: rep_of_simps)

text \<open>We derive a custom induction rule, that is more suited to
  our purposes.\<close>
lemma rep_of_induct[case_names base step, consumes 2]:
  assumes I: "ufa_invar l"
  assumes L: "i<length l"
  assumes BASE: "\<And>i. \<lbrakk> ufa_invar l; i<length l; l!i=i \<rbrakk> \<Longrightarrow> P l i"
  assumes STEP: "\<And>i. \<lbrakk> ufa_invar l; i<length l; l!i\<noteq>i; P l (l!i) \<rbrakk>
    \<Longrightarrow> P l i"
  shows "P l i"
proof -
  from ufa_invarD[OF I L] have "ufa_invar l \<and> i<length l \<longrightarrow> P l i"
    apply (induct l\<equiv>l i rule: rep_of.pinduct)
    apply (auto intro: STEP BASE dest: ufa_invarD)
    done
  thus ?thesis using I L by simp
qed

text \<open>In the following, we define various properties of \<open>rep_of\<close>.\<close>
lemma rep_of_min:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
proof -
  have "\<lbrakk>rep_of_dom (l,i) \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
    apply (induct arbitrary:  rule: rep_of.pinduct)
    apply (subst rep_of.psimps, assumption)
    apply (subst (2) rep_of.psimps, assumption)
    apply auto
    done
  thus "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
    by (metis ufa_invarD(1))
qed

lemma rep_of_bound:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> rep_of l i < length l"
  apply (induct rule: rep_of_induct)
  apply (auto simp: rep_of_iff)
  done

lemma rep_of_idem:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> rep_of l (rep_of l i) = rep_of l i"
  by (auto simp: rep_of_min rep_of_refl)

lemma rep_of_min_upd: "\<lbrakk> ufa_invar l; x<length l; i<length l \<rbrakk> \<Longrightarrow>
  rep_of (l[rep_of l x := rep_of l x]) i = rep_of l i"
  by (metis list_update_id rep_of_min)

lemma rep_of_idx:
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> rep_of l (l!i) = rep_of l i"
  by (metis rep_of_step)

subsubsection \<open>Abstraction to Partial Equivalence Relation\<close>
definition ufa_\<alpha> :: "nat list \<Rightarrow> (nat\<times>nat) set"
  where "ufa_\<alpha> l
    \<equiv> {(x,y). x<length l \<and> y<length l \<and> rep_of l x = rep_of l y}"

lemma ufa_\<alpha>_equiv[simp, intro!]: "part_equiv (ufa_\<alpha> l)"
  by rule (auto simp: ufa_\<alpha>_def intro: symI transI)

lemma ufa_\<alpha>_lenD:
  "(x,y)\<in>ufa_\<alpha> l \<Longrightarrow> x<length l"
  "(x,y)\<in>ufa_\<alpha> l \<Longrightarrow> y<length l"
  unfolding ufa_\<alpha>_def by auto

lemma ufa_\<alpha>_dom[simp]: "Domain (ufa_\<alpha> l) = {0..<length l}"
  unfolding ufa_\<alpha>_def by auto

lemma ufa_\<alpha>_refl[simp]: "(i,i)\<in>ufa_\<alpha> l \<longleftrightarrow> i<length l"
  unfolding ufa_\<alpha>_def
  by simp

lemma ufa_\<alpha>_len_eq:
  assumes "ufa_\<alpha> l = ufa_\<alpha> l'"
  shows "length l = length l'"
  by (metis assms le_antisym less_not_refl linorder_le_less_linear ufa_\<alpha>_refl)

subsubsection \<open>Operations\<close>
lemma ufa_init_invar: "ufa_invar [0..<n]"
  unfolding ufa_invar_def
  by (auto intro: rep_of.domintros)

lemma ufa_init_correct: "ufa_\<alpha> [0..<n] = {(x,x) | x. x<n}"
  unfolding ufa_\<alpha>_def
  using ufa_init_invar[of n]
  apply (auto simp: rep_of_refl)
  done

lemma ufa_find_correct: "\<lbrakk>ufa_invar l; x<length l; y<length l\<rbrakk>
  \<Longrightarrow> rep_of l x = rep_of l y \<longleftrightarrow> (x,y)\<in>ufa_\<alpha> l"
  unfolding ufa_\<alpha>_def
  by auto

abbreviation "ufa_union l x y \<equiv> l[rep_of l x := rep_of l y]"

lemma ufa_union_invar:
  assumes I: "ufa_invar l"
  assumes L: "x<length l" "y<length l"
  shows "ufa_invar (ufa_union l x y)"
  unfolding ufa_invar_def
proof (intro allI impI, simp only: length_list_update)
  fix i
  assume A: "i<length l"
  with I have "rep_of_dom (l,i)" by (auto dest: ufa_invarD)

  have "ufa_union l x y ! i < length l" using I L A
    apply (cases "i=rep_of l x")
    apply (auto simp: rep_of_bound dest: ufa_invarD)
    done
  moreover have "rep_of_dom (ufa_union l x y, i)" using I A L
  proof (induct rule: rep_of_induct)
    case (base i)
    thus ?case
      apply -
      apply (rule rep_of.domintros)
      apply (cases "i=rep_of l x")
      apply auto
      apply (rule rep_of.domintros)
      apply (auto simp: rep_of_min)
      done
  next
    case (step i)

    from step.prems \<open>ufa_invar l\<close> \<open>i<length l\<close> \<open>l!i\<noteq>i\<close>
    have [simp]: "ufa_union l x y ! i = l!i"
      apply (auto simp: rep_of_min rep_of_bound nth_list_update)
      done

    from step show ?case
      apply -
      apply (rule rep_of.domintros)
      apply simp
      done
  qed
  ultimately show
    "rep_of_dom (ufa_union l x y, i) \<and> ufa_union l x y ! i < length l"
    by blast

qed

lemma ufa_union_aux:
  assumes I: "ufa_invar l"
  assumes L: "x<length l" "y<length l"
  assumes IL: "i<length l"
  shows "rep_of (ufa_union l x y) i =
    (if rep_of l i = rep_of l x then rep_of l y else rep_of l i)"
  using I IL
proof (induct rule: rep_of_induct)
  case (base i)
  have [simp]: "rep_of l i = i" using \<open>l!i=i\<close> by (simp add: rep_of_refl)
  note [simp] = \<open>ufa_invar l\<close> \<open>i<length l\<close>
  show ?case proof (cases)
    assume A[simp]: "rep_of l x = i"
    have [simp]: "l[i := rep_of l y] ! i = rep_of l y"
      by (auto simp: rep_of_bound)

    show ?thesis proof (cases)
      assume [simp]: "rep_of l y = i"
      show ?thesis by (simp add: rep_of_refl)
    next
      assume A: "rep_of l y \<noteq> i"
      have [simp]: "rep_of (l[i := rep_of l y]) i = rep_of l y"
        apply (subst rep_of_step[OF ufa_union_invar[OF I L], simplified])
        using A apply simp_all
        apply (subst rep_of_refl[where i="rep_of l y"])
        using I L
        apply (simp_all add: rep_of_min)
        done
      show ?thesis by (simp add: rep_of_refl)
    qed
  next
    assume A: "rep_of l x \<noteq> i"
    hence "ufa_union l x y ! i = l!i" by (auto)
    also note \<open>l!i=i\<close>
    finally have "rep_of (ufa_union l x y) i = i" by (simp add: rep_of_refl)
    thus ?thesis using A by auto
  qed
next
  case (step i)

  note [simp] = I L \<open>i<length l\<close>

  have "rep_of l x \<noteq> i" by (metis I L(1) rep_of_min \<open>l!i\<noteq>i\<close>)
  hence [simp]: "ufa_union l x y ! i = l!i"
    by (auto simp add: nth_list_update rep_of_bound \<open>l!i\<noteq>i\<close>) []

  have "rep_of (ufa_union l x y) i = rep_of (ufa_union l x y) (l!i)"
    by (auto simp add: rep_of_iff[OF ufa_union_invar[OF I L]])
  also note step.hyps(4)
  finally show ?case
    by (auto simp: rep_of_idx)
qed

lemma ufa_union_correct: "\<lbrakk> ufa_invar l; x<length l; y<length l \<rbrakk>
  \<Longrightarrow> ufa_\<alpha> (ufa_union l x y) = per_union (ufa_\<alpha> l) x y"
  unfolding ufa_\<alpha>_def per_union_def
  by (auto simp: ufa_union_aux
    split: if_split_asm
  )

lemma ufa_compress_aux:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_invar (l[x := rep_of l x])"
  and "\<forall>i<length l. rep_of (l[x := rep_of l x]) i = rep_of l i"
proof -
  {
    fix i
    assume "i<length (l[x := rep_of l x])"
    hence IL: "i<length l" by simp

    have G1: "l[x := rep_of l x] ! i < length (l[x := rep_of l x])"
      using I IL
      by (auto dest: ufa_invarD[OF I] simp: nth_list_update rep_of_bound)
    from I IL have G2: "rep_of (l[x := rep_of l x]) i = rep_of l i
      \<and> rep_of_dom (l[x := rep_of l x], i)"
    proof (induct rule: rep_of_induct)
      case (base i)
      thus ?case
        apply (cases "x=i")
        apply (auto intro: rep_of.domintros simp: rep_of_refl)
        done
    next
      case (step i)
      hence D: "rep_of_dom (l[x := rep_of l x], i)"
        apply -
        apply (rule rep_of.domintros)
        apply (cases "x=i")
        apply (auto intro: rep_of.domintros simp: rep_of_min)
        done

      thus ?case apply simp using step
        apply -
        apply (subst rep_of.psimps[OF D])
        apply (cases "x=i")
        apply (auto simp: rep_of_min rep_of_idx)
        apply (subst rep_of.psimps[where i="rep_of l i"])
        apply (auto intro: rep_of.domintros simp: rep_of_min)
        done
    qed
    note G1 G2
  } note G=this

  thus "\<forall>i<length l. rep_of (l[x := rep_of l x]) i = rep_of l i"
    by auto

  from G show "ufa_invar (l[x := rep_of l x])"
    by (auto simp: ufa_invar_def)
qed

lemma ufa_compress_invar:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_invar (l[x := rep_of l x])"
  using assms by (rule ufa_compress_aux)

lemma ufa_compress_correct:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_\<alpha> (l[x := rep_of l x]) = ufa_\<alpha> l"
  by (auto simp: ufa_\<alpha>_def ufa_compress_aux[OF I])

end


section \<open>Transposition function\<close>

theory Transposition
  imports MainRLT
begin

definition transpose :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>
  where \<open>transpose a b c = (if c = a then b else if c = b then a else c)\<close>

lemma transpose_apply_first [simp]:
  \<open>transpose a b a = b\<close>
  by (simp add: transpose_def)

lemma transpose_apply_second [simp]:
  \<open>transpose a b b = a\<close>
  by (simp add: transpose_def)

lemma transpose_apply_other [simp]:
  \<open>transpose a b c = c\<close> if \<open>c \<noteq> a\<close> \<open>c \<noteq> b\<close>
  using that by (simp add: transpose_def)

lemma transpose_same [simp]:
  \<open>transpose a a = id\<close>
  by (simp add: fun_eq_iff transpose_def)

lemma transpose_eq_iff:
  \<open>transpose a b c = d \<longleftrightarrow> (c \<noteq> a \<and> c \<noteq> b \<and> d = c) \<or> (c = a \<and> d = b) \<or> (c = b \<and> d = a)\<close>
  by (auto simp add: transpose_def)

lemma transpose_eq_imp_eq:
  \<open>c = d\<close> if \<open>transpose a b c = transpose a b d\<close>
  using that by (auto simp add: transpose_eq_iff)

lemma transpose_commute [ac_simps]:
  \<open>transpose b a = transpose a b\<close>
  by (auto simp add: fun_eq_iff transpose_eq_iff)

lemma transpose_involutory [simp]:
  \<open>transpose a b (transpose a b c) = c\<close>
  by (auto simp add: transpose_eq_iff)

lemma transpose_comp_involutory [simp]:
  \<open>transpose a b \<circ> transpose a b = id\<close>
  by (rule ext) simp

lemma transpose_triple:
  \<open>transpose a b (transpose b c (transpose a b d)) = transpose a c d\<close>
  if \<open>a \<noteq> c\<close> and \<open>b \<noteq> c\<close>
  using that by (simp add: transpose_def)

lemma transpose_comp_triple:
  \<open>transpose a b \<circ> transpose b c \<circ> transpose a b = transpose a c\<close>
  if \<open>a \<noteq> c\<close> and \<open>b \<noteq> c\<close>
  using that by (simp add: fun_eq_iff transpose_triple)

lemma transpose_image_eq [simp]:
  \<open>transpose a b ` A = A\<close> if \<open>a \<in> A \<longleftrightarrow> b \<in> A\<close>
  using that by (auto simp add: transpose_def [abs_def])

lemma inj_on_transpose [simp]:
  \<open>inj_on (transpose a b) A\<close>
  by rule (drule transpose_eq_imp_eq)

lemma inj_transpose:
  \<open>inj (transpose a b)\<close>
  by (fact inj_on_transpose)

lemma surj_transpose:
  \<open>surj (transpose a b)\<close>
  by simp

lemma bij_betw_transpose_iff [simp]:
  \<open>bij_betw (transpose a b) A A\<close> if \<open>a \<in> A \<longleftrightarrow> b \<in> A\<close>
  using that by (auto simp: bij_betw_def)

lemma bij_transpose [simp]:
  \<open>bij (transpose a b)\<close>
  by (rule bij_betw_transpose_iff) simp

lemma bijection_transpose:
  \<open>bijection (transpose a b)\<close>
  by standard (fact bij_transpose)

lemma inv_transpose_eq [simp]:
  \<open>inv (transpose a b) = transpose a b\<close>
  by (rule inv_unique_comp) simp_all

lemma transpose_apply_commute:
  \<open>transpose a b (f c) = f (transpose (inv f a) (inv f b) c)\<close>
  if \<open>bij f\<close>
proof -
  from that have \<open>surj f\<close>
    by (rule bij_is_surj)
  with that show ?thesis
    by (simp add: transpose_def bij_inv_eq_iff surj_f_inv_f)
qed

lemma transpose_comp_eq:
  \<open>transpose a b \<circ> f = f \<circ> transpose (inv f a) (inv f b)\<close>
  if \<open>bij f\<close>
  using that by (simp add: fun_eq_iff transpose_apply_commute)

lemma in_transpose_image_iff:
  \<open>x \<in> transpose a b ` S \<longleftrightarrow> transpose a b x \<in> S\<close>
  by (auto intro!: image_eqI)

text \<open>Legacy input alias\<close>

setup \<open>Context.theory_map (Name_Space.map_naming (Name_Space.qualified_path true \<^binding>\<open>Fun\<close>))\<close>

abbreviation (input) swap :: \<open>'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b\<close>
  where \<open>swap a b f \<equiv> f \<circ> transpose a b\<close>

lemma swap_def:
  \<open>Fun.swap a b f = f (a := f b, b:= f a)\<close>
  by (simp add: fun_eq_iff)

setup \<open>Context.theory_map (Name_Space.map_naming (Name_Space.parent_path))\<close>

lemma swap_apply:
  "Fun.swap a b f a = f b"
  "Fun.swap a b f b = f a"
  "c \<noteq> a \<Longrightarrow> c \<noteq> b \<Longrightarrow> Fun.swap a b f c = f c"
  by simp_all

lemma swap_self: "Fun.swap a a f = f"
  by simp

lemma swap_commute: "Fun.swap a b f = Fun.swap b a f"
  by (simp add: ac_simps)

lemma swap_nilpotent: "Fun.swap a b (Fun.swap a b f) = f"
  by (simp add: comp_assoc)

lemma swap_comp_involutory: "Fun.swap a b \<circ> Fun.swap a b = id"
  by (simp add: fun_eq_iff)

lemma swap_triple:
  assumes "a \<noteq> c" and "b \<noteq> c"
  shows "Fun.swap a b (Fun.swap b c (Fun.swap a b f)) = Fun.swap a c f"
  using assms transpose_comp_triple [of a c b]
  by (simp add: comp_assoc)

lemma comp_swap: "f \<circ> Fun.swap a b g = Fun.swap a b (f \<circ> g)"
  by (simp add: comp_assoc)

lemma swap_image_eq:
  assumes "a \<in> A" "b \<in> A"
  shows "Fun.swap a b f ` A = f ` A"
  using assms by (metis image_comp transpose_image_eq)

lemma inj_on_imp_inj_on_swap: "inj_on f A \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> inj_on (Fun.swap a b f) A"
  by (simp add: comp_inj_on)

lemma inj_on_swap_iff:
  assumes A: "a \<in> A" "b \<in> A"
  shows "inj_on (Fun.swap a b f) A \<longleftrightarrow> inj_on f A"
  using assms by (metis inj_on_imageI inj_on_imp_inj_on_swap transpose_image_eq)

lemma surj_imp_surj_swap: "surj f \<Longrightarrow> surj (Fun.swap a b f)"
  by (meson comp_surj surj_transpose)

lemma surj_swap_iff: "surj (Fun.swap a b f) \<longleftrightarrow> surj f"
  by (metis fun.set_map surj_transpose)

lemma bij_betw_swap_iff: "x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> bij_betw (Fun.swap x y f) A B \<longleftrightarrow> bij_betw f A B"
  by (meson bij_betw_comp_iff bij_betw_transpose_iff)

lemma bij_swap_iff: "bij (Fun.swap a b f) \<longleftrightarrow> bij f"
  by (simp add: bij_betw_swap_iff)

lemma swap_image:
  \<open>Fun.swap i j f ` A = f ` (A - {i, j}
    \<union> (if i \<in> A then {j} else {}) \<union> (if j \<in> A then {i} else {}))\<close>
  by (auto simp add: Fun.swap_def)

lemma inv_swap_id: "inv (Fun.swap a b id) = Fun.swap a b id"
  by simp

lemma bij_swap_comp:
  assumes "bij p"
  shows "Fun.swap a b id \<circ> p = Fun.swap (inv p a) (inv p b) p"
  using assms by (simp add: transpose_comp_eq)

lemma swap_id_eq: "Fun.swap a b id x = (if x = a then b else if x = b then a else x)"
  by (simp add: Fun.swap_def)

lemma swap_unfold:
  \<open>Fun.swap a b p = p \<circ> Fun.swap a b id\<close>
  by simp

lemma swap_id_idempotent: "Fun.swap a b id \<circ> Fun.swap a b id = id"
  by simp

lemma bij_swap_compose_bij:
  \<open>bij (Fun.swap a b id \<circ> p)\<close> if \<open>bij p\<close>
  using that by (rule bij_comp) simp

end


(*  Title:       Examples of hybrid systems verifications
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

subsection \<open> Examples \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
recently described verification components.\<close>

theory HS_VC_PT_Examples
  imports HS_VC_PT

begin

subsubsection \<open> Pendulum \<close>

text \<open> The ODEs @{text "x' t = y t"} and {text "y' t = - x t"} describe the circular motion of
a mass attached to a string looked from above. We use @{text "s$1"} to represent the x-coordinate
and @{text "s$2"} for the y-coordinate. We prove that this motion remains circular. \<close>

abbreviation fpend :: "real^2 \<Rightarrow> real^2" ("f")
  where "f s \<equiv> (\<chi> i. if i = 1 then s$2 else -s$1)"

abbreviation pend_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i = 1 then s$1 * cos t + s$2 * sin t else - s$1 * sin t + s$2 * cos t)"

\<comment> \<open>Verified by providing the dynamics\<close>

lemma pendulum_dyn: "{s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2} \<le> fb\<^sub>\<F> (EVOL \<phi> G T) {s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2}"
  by force

\<comment> \<open>Verified with differential invariants. \<close>

lemma pendulum_inv: "{s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2} \<le> fb\<^sub>\<F> (x\<acute>= f & G) {s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2}"
  by (auto intro!: diff_invariant_rules poly_derivatives)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_pend: "local_flow f UNIV UNIV \<phi>"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def power2_commute UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma pendulum_flow: "{s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2} \<le> fb\<^sub>\<F> (x\<acute>= f & G) {s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2}"
  by (force simp: local_flow.ffb_g_ode_subset[OF local_flow_pend])

no_notation fpend ("f")
        and pend_flow ("\<phi>")

subsubsection \<open> Bouncing Ball \<close>

text \<open> A ball is dropped from rest at an initial height @{text "h"}. The motion is described with
the free-fall equations @{text "x' t = v t"} and @{text "v' t = g"} where @{text "g"} is the
constant acceleration due to gravity. The bounce is modelled with a variable assignment that
flips the velocity. That is, we model it as a completely elastic collision with the ground. We use
@{text "s$1"} to represent the ball's height and @{text "s$2"} for its velocity. We prove that the
ball remains above ground and below its initial resting position. \<close>

abbreviation fball :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("f")
  where "f g s \<equiv> (\<chi> i. if i = 1 then s$2 else g)"

abbreviation ball_flow :: "real \<Rightarrow> real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> g t s \<equiv> (\<chi> i. if i = 1 then g * t ^ 2/2 + s$2 * t + s$1 else g * t + s$2)"

\<comment> \<open>Verified with differential invariants. \<close>

named_theorems bb_real_arith "real arithmetic properties for the bouncing ball."

lemma inv_imp_pos_le[bb_real_arith]:
  assumes "0 > g" and inv: "2 * g * x - 2 * g * h = v * v"
  shows "(x::real) \<le> h"
proof-
  have "v * v = 2 * g * x - 2 * g * h \<and> 0 > g"
    using inv and \<open>0 > g\<close> by auto
  hence obs:"v * v = 2 * g * (x - h) \<and> 0 > g \<and> v * v \<ge> 0"
    using left_diff_distrib mult.commute by (metis zero_le_square)
  hence "(v * v)/(2 * g) = (x - h)"
    by auto
  also from obs have "(v * v)/(2 * g) \<le> 0"
    using divide_nonneg_neg by fastforce
  ultimately have "h - x \<ge> 0"
    by linarith
  thus ?thesis by auto
qed

lemma bouncing_ball_inv: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  {s. s$1 = h \<and> s$2 = 0} \<le> fb\<^sub>\<F>
  (LOOP (
    (x\<acute>=(f g) & (\<lambda> s. s$1 \<ge> 0) DINV (\<lambda>s. 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and>2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0))
  {s. 0 \<le> s$1 \<and> s$1 \<le> h}"
  apply(rule ffb_loopI, simp_all)
    apply(force, force simp: bb_real_arith)
  apply(rule ffb_g_odei)
  by (auto intro!: diff_invariant_rules poly_derivatives simp: bb_real_arith)

\<comment> \<open>Verified with annotated dynamics. \<close>

lemma inv_conserv_at_ground[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
    and pos: "g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real) = 0"
  shows "2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v)) = 0"
proof-
  from pos have "g * \<tau>\<^sup>2  + 2 * v * \<tau> + 2 * x = 0" by auto
  then have "g\<^sup>2 * \<tau>\<^sup>2  + 2 * g * v * \<tau> + 2 * g * x = 0"
    by (metis (mono_tags) Groups.mult_ac(1,3) mult_zero_right
        monoid_mult_class.power2_eq_square semiring_class.distrib_left)
  hence "g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + v\<^sup>2 + 2 * g * h = 0"
    using invar by (simp add: monoid_mult_class.power2_eq_square)
  hence obs: "(g * \<tau> + v)\<^sup>2 + 2 * g * h = 0"
    apply(subst power2_sum) by (metis (no_types) Groups.add_ac(2, 3)
        Groups.mult_ac(2, 3) monoid_mult_class.power2_eq_square nat_distrib(2))
  thus "2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v)) = 0"
    by (simp add: add.commute distrib_right power2_eq_square)
qed

lemma inv_conserv_at_air[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
  shows "2 * g * (g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real)) =
  2 * g * h + (g * \<tau> + v) * (g * \<tau> + v)" (is "?lhs = ?rhs")
proof-
  have "?lhs = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * x"
    by(auto simp: algebra_simps semiring_normalization_rules(29))
  also have "... = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * h + v * v" (is "... = ?middle")
    by(subst invar, simp)
  finally have "?lhs = ?middle".
  moreover
  {have "?rhs = g * g * (\<tau> * \<tau>) + 2 * g * v * \<tau> + 2 * g * h + v * v"
    by (simp add: Groups.mult_ac(2,3) semiring_class.distrib_left)
  also have "... = ?middle"
    by (simp add: semiring_normalization_rules(29))
  finally have "?rhs = ?middle".}
  ultimately show ?thesis by auto
qed

lemma bouncing_ball_dyn: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  {s. s$1 = h \<and> s$2 = 0} \<le> fb\<^sub>\<F>
  (LOOP (
    (EVOL (\<phi> g) (\<lambda> s. s$1 \<ge> 0) T) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 = 2 * g * h + s$2 * s$2))
  {s. 0 \<le> s$1 \<and> s$1 \<le> h}"
  by (rule ffb_loopI) (auto simp: bb_real_arith)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_ball: "local_flow (f g) UNIV UNIV (\<phi> g)"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma bouncing_ball_flow: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  {s. s$1 = h \<and> s$2 = 0} \<le> fb\<^sub>\<F>
  (LOOP (
    (x\<acute>=(\<lambda>t. f g) & (\<lambda> s. s$1 \<ge> 0) on (\<lambda>s. UNIV) UNIV @ 0) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 = 2 * g * h + s$2 * s$2))
  {s. 0 \<le> s$1 \<and> s$1 \<le> h}"
  by (rule ffb_loopI) (auto simp: bb_real_arith local_flow.ffb_g_ode[OF local_flow_ball])

no_notation fball ("f")
        and ball_flow ("\<phi>")

subsubsection \<open> Thermostat \<close>

text \<open> A thermostat has a chronometer, a thermometer and a switch to turn on and off a heater.
At most every @{text "t"} minutes, it sets its chronometer to @{term "0::real"}, it registers
the room temperature, and it turns the heater on (or off) based on this reading. The temperature
follows the ODE @{text "T' = - a * (T - U)"} where @{text "U"} is @{text "L \<ge> 0"} when the heater
is on, and @{text "0"} when it is off. We use @{term "1::4"} to denote the room's temperature,
@{term "2::4"} is time as measured by the thermostat's chronometer, @{term "3::4"} is the
temperature detected by the thermometer, and @{term "4::4"} states whether the heater is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the thermostat keeps the room's
temperature between @{text "Tmin"} and @{text "Tmax"}. \<close>

abbreviation temp_vec_field :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f a L s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then - a * (s$1 - L) else 0))"

abbreviation temp_flow :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> a L t s \<equiv> (\<chi> i. if i = 1 then - exp(-a * t) * (L - s$1) + L else
  (if i = 2 then t + s$2 else s$i))"

\<comment> \<open>Verified with the flow. \<close>

lemma norm_diff_temp_dyn: "0 < a \<Longrightarrow> \<parallel>f a L s\<^sub>1 - f a L s\<^sub>2\<parallel> = \<bar>a\<bar> * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
proof(simp add: norm_vec_def L2_set_def, unfold UNIV_4, simp)
  assume a1: "0 < a"
  have f2: "\<And>r ra. \<bar>(r::real) + - ra\<bar> = \<bar>ra + - r\<bar>"
    by (metis abs_minus_commute minus_real_def)
  have "\<And>r ra rb. (r::real) * ra + - (r * rb) = r * (ra + - rb)"
    by (metis minus_real_def right_diff_distrib)
  hence "\<bar>a * (s\<^sub>1$1 + - L) + - (a * (s\<^sub>2$1 + - L))\<bar> = a * \<bar>s\<^sub>1$1 + - s\<^sub>2$1\<bar>"
    using a1 by (simp add: abs_mult)
  thus "\<bar>a * (s\<^sub>2$1 - L) - a * (s\<^sub>1$1 - L)\<bar> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
    using f2 minus_real_def by presburger
qed

lemma local_lipschitz_temp_dyn:
  assumes "0 < (a::real)"
  shows "local_lipschitz UNIV UNIV (\<lambda>t::real. f a L)"
  apply(unfold local_lipschitz_def lipschitz_on_def dist_norm)
  apply(clarsimp, rule_tac x=1 in exI, clarsimp, rule_tac x=a in exI)
  using assms
  apply(simp_all add: norm_diff_temp_dyn)
  apply(simp add: norm_vec_def L2_set_def, unfold UNIV_4, clarsimp)
  unfolding real_sqrt_abs[symmetric] by (rule real_le_lsqrt) auto

lemma local_flow_temp: "a > 0 \<Longrightarrow> local_flow (f a L) UNIV UNIV (\<phi> a L)"
  by (unfold_locales, auto intro!: poly_derivatives local_lipschitz_temp_dyn simp: forall_4 vec_eq_iff)

lemma temp_dyn_down_real_arith:
  assumes "a > 0" and Thyps: "0 < Tmin" "Tmin \<le> T" "T \<le> Tmax"
    and thyps: "0 \<le> (t::real)" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln (Tmin / T) / a) "
  shows "Tmin \<le> exp (-a * t) * T" and "exp (-a * t) * T \<le> Tmax"
proof-
  have "0 \<le> t \<and> t \<le> - (ln (Tmin / T) / a)"
    using thyps by auto
  hence "ln (Tmin / T) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "Tmin / T > 0"
    using Thyps by auto
  ultimately have obs: "Tmin / T \<le> exp (-a * t)" "exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less, simp)
  thus "Tmin \<le> exp (-a * t) * T"
    using Thyps by (simp add: pos_divide_le_eq)
  show "exp (-a * t) * T \<le> Tmax"
    using Thyps mult_left_le_one_le[OF _ exp_ge_zero obs(2), of T]
      less_eq_real_def order_trans_rules(23) by blast
qed

lemma temp_dyn_up_real_arith:
  assumes "a > 0" and Thyps: "Tmin \<le> T" "T \<le> Tmax" "Tmax < (L::real)"
    and thyps: "0 \<le> t" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a) "
  shows "L - Tmax \<le> exp (-(a * t)) * (L - T)"
    and "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    and "Tmin \<le> L - exp (-(a * t)) * (L - T)"
proof-
  have "0 \<le> t \<and> t \<le> - (ln ((L - Tmax) / (L - T)) / a)"
    using thyps by auto
  hence "ln ((L - Tmax) / (L - T)) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "(L - Tmax) / (L - T) > 0"
    using Thyps by auto
  ultimately have "(L - Tmax) / (L - T) \<le> exp (-a * t) \<and> exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less)
  moreover have "L - T > 0"
    using Thyps by auto
  ultimately have obs: "(L - Tmax) \<le> exp (-a * t) * (L - T) \<and> exp (-a * t) * (L - T) \<le> (L - T)"
    by (simp add: pos_divide_le_eq)
  thus "(L - Tmax) \<le> exp (-(a * t)) * (L - T)"
    by auto
  thus "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    by auto
  show "Tmin \<le> L - exp (-(a * t)) * (L - T)"
    using Thyps and obs by auto
qed

lemmas ffb_temp_dyn = local_flow.ffb_g_ode_ivl[OF local_flow_temp _ UNIV_I]

lemma thermostat:
  assumes "a > 0" and "0 \<le> t" and "0 < Tmin" and "Tmax < L"
  shows "{s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax \<and> s$4 = 0} \<le> fb\<^sub>\<F>
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::= (\<lambda>s. 0));(3 ::= (\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>=(\<lambda>t. f a 0) & (\<lambda>s. s$2 \<le> - (ln (Tmin/s$3))/a) on (\<lambda>s. {0..t}) UNIV @ 0)
    ELSE (x\<acute>=(\<lambda>t. f a L) & (\<lambda>s. s$2 \<le> - (ln ((L-Tmax)/(L-s$3)))/a) on (\<lambda>s. {0..t}) UNIV @ 0)) )
  INV (\<lambda>s. Tmin \<le>s$1 \<and> s$1 \<le> Tmax \<and> (s$4 = 0 \<or> s$4 = 1)))
  {s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax}"
  apply(rule ffb_loopI, simp_all add: ffb_temp_dyn[OF assms(1,2)] le_fun_def, safe)
  using temp_dyn_up_real_arith[OF assms(1) _ _ assms(4), of Tmin]
    and temp_dyn_down_real_arith[OF assms(1,3), of _ Tmax] by auto

no_notation temp_vec_field ("f")
        and temp_flow ("\<phi>")

subsubsection \<open> Tank \<close>

text \<open> A controller turns a water pump on and off to keep the level of water @{text "h"} in a tank
within an acceptable range @{text "hmin \<le> h \<le> hmax"}. Just like in the previous example, after
each intervention, the controller registers the current level of water and resets its chronometer,
then it changes the status of the water pump accordingly. The level of water grows linearly
@{text "h' = k"} at a rate of @{text "k = c\<^sub>i-c\<^sub>o"} if the pump is on, and at a rate of
@{text "k = -c\<^sub>o"} if the pump is off. We use @{term "1::4"} to denote the tank's level of water,
@{term "2::4"} is time as measured by the controller's chronometer, @{term "3::4"} is the
level of water measured by the chronometer, and @{term "4::4"} states whether the pump is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the controller keeps the level of
water between @{text "hmin"} and @{text "hmax"}. \<close>

abbreviation tank_vec_field :: "real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f k s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then k else 0))"

abbreviation tank_flow :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> k \<tau> s \<equiv> (\<chi> i. if i = 1 then k * \<tau> + s$1 else
  (if i = 2 then \<tau> + s$2 else s$i))"

abbreviation tank_guard :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("G")
  where "G Hm k s \<equiv> s$2 \<le> (Hm - s$3)/k"

abbreviation tank_loop_inv :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("I")
  where "I hmin hmax s \<equiv> hmin \<le> s$1 \<and> s$1 \<le> hmax \<and> (s$4 = 0 \<or> s$4 = 1)"

abbreviation tank_diff_inv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("dI")
  where "dI hmin hmax k s \<equiv> s$1 = k * s$2 + s$3 \<and> 0 \<le> s$2 \<and>
    hmin \<le> s$3 \<and> s$3 \<le> hmax \<and> (s$4 =0 \<or> s$4 = 1)"

lemma local_flow_tank: "local_flow (f k) UNIV UNIV (\<phi> k)"
  apply (unfold_locales, unfold local_lipschitz_def lipschitz_on_def, simp_all, clarsimp)
  apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
  apply(simp add: dist_norm norm_vec_def L2_set_def, unfold UNIV_4)
  by (auto intro!: poly_derivatives simp: vec_eq_iff)

lemma tank_arith:
  assumes "0 \<le> (\<tau>::real)" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> - ((hmin - y) / c\<^sub>o) \<Longrightarrow>  hmin \<le> y - c\<^sub>o * \<tau>"
    and "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> (hmax - y) / (c\<^sub>i - c\<^sub>o) \<Longrightarrow>  (c\<^sub>i - c\<^sub>o) * \<tau> + y \<le> hmax"
    and "hmin \<le> y \<Longrightarrow> hmin \<le> (c\<^sub>i - c\<^sub>o) * \<tau> + y"
    and "y \<le> hmax \<Longrightarrow> y - c\<^sub>o * \<tau> \<le> hmax"
  apply(simp_all add: field_simps le_divide_eq assms)
  using assms apply (meson add_mono less_eq_real_def mult_left_mono)
  using assms by (meson add_increasing2 less_eq_real_def mult_nonneg_nonneg)

lemma tank_flow:
  assumes "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "Collect (I hmin hmax) \<le> fb\<^sub>\<F>
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::=(\<lambda>s.0));(3 ::=(\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> hmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> hmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>= f (c\<^sub>i-c\<^sub>o) & (G hmax (c\<^sub>i-c\<^sub>o)))
     ELSE (x\<acute>= f (-c\<^sub>o) & (G hmin (-c\<^sub>o)))) ) INV I hmin hmax)
  (Collect (I hmin hmax))"
  apply(rule ffb_loopI, simp_all add: le_fun_def)
  apply(clarsimp simp: le_fun_def local_flow.ffb_g_ode_subset[OF local_flow_tank])
  using assms tank_arith[OF _ assms] by auto

no_notation tank_vec_field ("f")
        and tank_flow ("\<phi>")
        and tank_loop_inv ("I")
        and tank_diff_inv ("dI")
        and tank_guard ("G")

end


(* Title: Kleene Algebra
   Author: Peixin You
*)

section \<open>Kleene Algebra\<close>

theory KA
  imports Main

begin

subsection \<open>Monoids\<close>

notation times (infixl "\<cdot>" 70)

class mult_monoid = times + one +
  assumes mult_assoc: "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z"
  and mult_unitl: "1 \<cdot> x = x"
  and mult_unitr: "x \<cdot> 1 = x"

class add_monoid = plus + zero +
  assumes add_assoc: "x + (y + z) = (x + y) + z"
  and add_unitl: "0 + x = x"
  and add_unitr: "x + 0 = x"

class abelian_add_monoid = add_monoid +
  assumes add_comm: "x + y = y + x"

subsection \<open>Semilattices\<close>

class sup_semilattice = comm_monoid_add + ord +
  assumes add_idem: "x + x = x"
  and order_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and strict_order_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"

begin

subclass order
proof unfold_locales
  fix x y z
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    using add_commute order_def strict_order_def by auto
  show "x \<le> x"
    by (simp add: add_idem order_def)
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (metis add_assoc order_def)
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (simp add: add_commute order_def)
qed

lemma zero_least: "0 \<le> x"
proof-
  have "0 + x = x"
    by simp
  thus "0 \<le> x"
    by (simp add: order_def)
qed

lemma add_isor: "x \<le> y \<Longrightarrow> x + z \<le> y + z"
proof-
  assume "x \<le> y"
  hence a: "x + y = y"
    by (simp add: order_def)
  have "x + z + y + z = x + y + z"
    by (metis add_commute local.add_assoc local.add_idem)
  also have "\<dots> = y + z"
    by (simp add: a)
  finally have "x + z + y + z = y + z".
  thus "x + z \<le> y + z"
    by (simp add: add_assoc order_def)
qed

text \<open>This proof shows three things: First you can use the label a: to use a hypothesis/intermediate result
later in a proof (not just in the next step writing hence. In this case in the third step of the proof.
Second you can do textbook style equational reasoning using also have and finally have. Third, you can type  dot after the finally
have to chain the proof steps together.\<close>

lemma add_iso: "x \<le> y \<Longrightarrow> x' \<le> y' \<Longrightarrow> x + x' \<le> y + y'"
proof-
  assume a: "x \<le> y"
  assume b: "x'\<le> y'"
  have c: "x + y = y"
    using a local.order_def by force
  have d: "x' + y' = y'"
    using b local.order_def by force
  have "x + x' + y + y' = y + x' + y'"
    by (metis add_commute c local.add_assoc)
  also have "\<dots> = y + y'"
    by (simp add: d local.add_assoc)
  finally show "x + x' \<le> y + y'"
    by (simp add: local.add_assoc local.order_def)
qed

lemma add_ubl: "x \<le> x + y"
proof-
  have "x + y = x + x + y"
    by (simp add: add_idem)
  thus ?thesis
    by (metis add_assoc order_def)
qed

lemma add_ubr: "y \<le> x + y"
  using add_commute add_ubl by fastforce

lemma add_least: "x \<le> z \<Longrightarrow> y \<le> z \<Longrightarrow> x + y \<le> z"
proof-
  assume "x \<le> z" and "y \<le> z"
  hence "x + z = z" and "y + z = z"
    by (simp add: order_def)+
  hence "x + y + z = z"
    by (simp add: add_assoc)
  thus "x + y \<le> z"
    by (simp add: order_def)
qed

lemma add_lub: "(x + y \<le> z) = (x \<le> z \<and> y \<le> z)"
  using add_least add_ubl add_ubr dual_order.trans by blast

end

subsection \<open>Semirings and Dioids\<close>

class semiring = comm_monoid_add + monoid_mult +
  assumes distl: "x \<cdot> (y + z) = x \<cdot> y + x \<cdot> z"
  and distr: "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"
  and annil [simp]: "0 \<cdot> x = 0"
  and annir [simp]: "x \<cdot> 0 = 0"

class dioid = semiring + sup_semilattice

begin

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
proof-
  assume "x \<le> y"
  hence "x + y = y"
    by (simp add: order_def)
  hence "z \<cdot> (x + y) = z \<cdot> y"
    by simp
  hence "z \<cdot> x + z \<cdot> y = z \<cdot> y"
    by (simp add: distl)
  thus "z \<cdot> x \<le> z \<cdot> y"
    by (simp add: order_def)
qed

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis distr order_def)

lemma mult_iso: "x \<le> y \<Longrightarrow> x' \<le> y' \<Longrightarrow> x \<cdot> x' \<le> y \<cdot> y'"
  using order_trans mult_isol mult_isor by blast

end

subsection \<open>Kleene Algebras\<close>

class kleene_algebra = dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

begin

lemma one_le_star: "1 \<le> x\<^sup>\<star>"
proof-
  have "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: star_unfoldl)
  thus "1 \<le> x\<^sup>\<star>"
    by (simp add: add_lub)
qed

lemma star_unfoldlr: "x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  using add_lub star_unfoldl by simp

lemma star_unfoldrr: "x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  using add_lub star_unfoldr by simp

lemma star_infl: "x \<le> x\<^sup>\<star>"
proof-
  have "x = x \<cdot> 1"
    by simp
  also have "\<dots> \<le> x \<cdot> x\<^sup>\<star>"
    using mult_isol one_le_star by force
  also have "\<dots> \<le> x\<^sup>\<star>"
    by (simp add: star_unfoldlr)
  finally show "x \<le> x\<^sup>\<star>".
qed

lemma star_power: "x ^ i \<le> x\<^sup>\<star>"
proof (induct i)
case 0
  show "x ^ 0 \<le> x\<^sup>\<star>"
    by (simp add: one_le_star)
next
  case (Suc i)
  assume "x ^ i \<le> x\<^sup>\<star>"
  have "x ^ Suc i = x \<cdot> x ^ i"
    by simp
  also have "\<dots> \<le> x \<cdot> x\<^sup>\<star>"
    by (simp add: Suc.hyps mult_isol)
  also have "\<dots>  \<le> x\<^sup>\<star>"
    by (simp add: star_unfoldlr)
  finally show "x ^ Suc i \<le> x\<^sup>\<star>".
qed

lemma star_trans [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
proof (rule antisym)
  have "x\<^sup>\<star> + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: add_least star_unfoldlr)
  thus "x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: star_inductl)
  have "x\<^sup>\<star> = 1 \<cdot> x\<^sup>\<star>"
    by simp
  also have "\<dots> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<star>"
    using mult_isor one_le_star by force
  finally show "x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<star>".
qed

lemma star_idem [simp]: "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"
proof (rule antisym)
  have "1 + x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: add_least one_le_star)
  thus  "(x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star>"
    using star_inductl by fastforce
  show "x\<^sup>\<star> \<le> (x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: star_infl)
qed

lemma star_unfoldl_eq [simp]: "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
proof (rule antisym)
  show le: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: star_unfoldl)
  have "1 + x \<cdot> (1 + x \<cdot> x\<^sup>\<star>) = 1 + x + x \<cdot> x \<cdot> x\<^sup>\<star>"
    by (simp add: add_assoc distl mult_assoc)
  also have "\<dots> \<le> 1 + x \<cdot> x\<^sup>\<star>"
    by (smt calculation le add_assoc distl add_idem order_def)
  finally have "1 + x \<cdot> (1 + x \<cdot> x\<^sup>\<star>) \<le> 1 + x \<cdot> x\<^sup>\<star>".
  thus "x\<^sup>\<star> \<le> 1 + x \<cdot> x\<^sup>\<star>"
    using star_inductl by fastforce
qed

lemma star_unfoldr_eq [simp]: "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
   apply (rule antisym)
   apply (simp add: star_unfoldr)
  by (smt distl distr mult.semigroup_axioms mult_1_left mult_1_right order_refl star_inductl semigroup.assoc star_unfoldl_eq)

lemma star_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
proof-
  assume "x \<le> y"
  hence "1 + x \<cdot> y\<^sup>\<star> \<le> 1 + y \<cdot> y\<^sup>\<star>"
    using add_iso mult_iso by blast
  also have "\<dots> \<le> y\<^sup>\<star>"
    by (simp add: star_unfoldl)
  finally show " x\<^sup>\<star> \<le> y\<^sup>\<star>"
    using star_inductl by fastforce
qed

lemma star_slide: "(x \<cdot> y)\<^sup>\<star> \<cdot> x = x \<cdot> (y \<cdot> x)\<^sup>\<star>"
proof (rule antisym)
  have "1 + y \<cdot> x \<cdot> (y \<cdot> x)\<^sup>\<star> \<le> (y \<cdot> x)\<^sup>\<star>"
    by (simp add: star_unfoldl)
  hence "x + x \<cdot> y \<cdot> x \<cdot> (y \<cdot> x)\<^sup>\<star> \<le> x \<cdot> (y \<cdot> x)\<^sup>\<star>"
    by (metis distl eq_iff mult_1_right mult_assoc star_unfoldl_eq)
  thus "(x \<cdot> y)\<^sup>\<star> \<cdot> x \<le> x \<cdot> (y \<cdot> x)\<^sup>\<star>"
    by (simp add: star_inductl mult_assoc)
  have "1 + (x \<cdot> y)\<^sup>\<star> \<cdot> x \<cdot> y \<le> (x \<cdot> y)\<^sup>\<star>"
    by (simp add: mult_assoc)
  hence "x + (x \<cdot> y)\<^sup>\<star> \<cdot> x \<cdot> y \<cdot> x \<le> (x \<cdot> y)\<^sup>\<star> \<cdot> x"
    by (metis distr eq_refl mult_1_left mult_assoc star_unfoldr_eq)
  thus "x \<cdot> (y \<cdot> x)\<^sup>\<star> \<le> (x \<cdot> y)\<^sup>\<star> \<cdot> x"
    by (simp add: star_inductr mult_assoc)
qed

lemma star_denest: "(x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
proof (rule antisym)
  have a: "1 \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (metis mult_1_right mult_isol order_trans one_le_star)
  have b: "x \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: mult_isor star_unfoldlr)
  have "y \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: star_unfoldlr)
  also have  "\<dots> = 1 \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by simp
  also have "\<dots> \<le>  x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    using mult_isor one_le_star by blast
  finally have "y \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>".
  hence "1 + (x + y) \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: a b add_lub distr)
  thus  "(x + y)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    using mult_assoc star_inductl by fastforce
  have a: "x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by (simp add: add_ubl star_iso)
  have "y \<le> (x + y)\<^sup>\<star>"
    using add_lub star_infl by blast
  hence "(y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> ((x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<star>)\<^sup>\<star>"
    using a mult_iso star_iso by blast
  also have "\<dots> = (x + y)\<^sup>\<star>"
    by simp
  finally have "(y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>".
  hence "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<star>"
    using a mult_iso by blast
  also have "\<dots> \<le> (x + y)\<^sup>\<star>"
    by simp
  finally show "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>".
qed

lemma star_subid: "x \<le> 1 \<Longrightarrow> x\<^sup>\<star> = 1"
proof-
  assume "x \<le> 1"
  hence "1 + x \<cdot> 1 \<le> 1"
    by (simp add: add_least)
  hence "x\<^sup>\<star> \<le> 1"
    using star_inductl by fastforce
  thus " x\<^sup>\<star> = 1"
    by (simp add: antisym one_le_star)
qed

lemma zero_star [simp]: "0\<^sup>\<star> = 1"
  by (simp add: zero_least star_subid)

lemma one_star [simp]: "1\<^sup>\<star> = 1"
  by (simp add: star_subid)

lemma star_sim1: "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y\<^sup>\<star> \<cdot> z"
proof -
  assume "z \<cdot> x \<le> y \<cdot> z"
  hence "z + y\<^sup>\<star> \<cdot> z \<cdot> x \<le> z + y\<^sup>\<star> \<cdot> y \<cdot> z"
    by (simp add: add_iso mult_assoc mult_iso)
  also have  "\<dots> = y\<^sup>\<star> \<cdot> z"
    by (metis distr mult_1_left star_unfoldr_eq)
  finally show ?thesis
    by (simp add: star_inductr)
qed

lemma star_sim2: "x \<cdot> z \<le> z \<cdot> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z  \<le> z \<cdot> y\<^sup>\<star>"
  by (smt add_commute add_assoc distl distr mult_1_right mult_assoc order_def star_inductl one_le_star star_unfoldl_eq)

lemma star_inductl_var: "x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y"
proof-
  assume "x \<cdot> y \<le> y"
  hence "y + x \<cdot> y \<le> y"
    by (simp add: add_lub)
  thus "x\<^sup>\<star> \<cdot> y \<le> y"
    by (simp add: star_inductl)
qed

lemma star_inductr_var: "y \<cdot> x \<le> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"
  by (simp add: add_least star_inductr)

lemma church_rosser: "y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<Longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
proof-
  assume h: "y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  have a: "1 \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (metis dual_order.trans mult_1_right mult_isol one_le_star)
  have b: "x \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (simp add: mult_isor star_unfoldlr)
  have "y \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (simp add: mult_isor star_infl)
  also have "\<dots> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (simp add: h mult_isor)
  finally have "y \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (metis mult_assoc star_trans)
  hence "1 + (x + y) \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (simp add: a b add_lub distr)
  hence c: "(x + y)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    using mult_assoc star_inductl by fastforce
  have "y\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by (simp add: add_ubr star_iso)
  hence "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<star>"
    using add_commute add_ubr mult_iso star_iso by presburger
  hence "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by simp
  thus "(x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    using c by auto
qed

lemma power_sup: "((\<Sum>i=0..n. x^i) \<le> y) = (\<forall>i. 0 \<le> i \<and> i \<le> n \<longrightarrow> x^i \<le> y)"
proof (induct n)
  case 0
  show "(sum ((^) x) {0..0} \<le> y) = (\<forall>i. 0 \<le> i \<and> i \<le> 0 \<longrightarrow> x ^ i \<le> y)"
    by simp
next
  case (Suc n)
  fix n :: nat
  assume "(sum ((^) x) {0..n} \<le> y) = (\<forall>i. 0 \<le> i \<and> i \<le> n \<longrightarrow> x ^ i \<le> y)"
  thus "(sum ((^) x) {0..Suc n} \<le> y) = (\<forall>i. 0 \<le> i \<and> i \<le> Suc n \<longrightarrow> x ^ i \<le> y)"
    using le_Suc_eq local.add_lub by force
qed

lemma power_dist: "(\<Sum>i=0..n. x ^ i) \<cdot> x = (\<Sum>i=0..n. x ^ Suc i)"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  show ?case
    using Suc local.distr local.power_Suc2 local.sum.atLeast0_atMost_Suc by presburger
qed

lemma power_sum: "(\<Sum>i=0..n. x ^ Suc i) = (\<Sum>i=1..n. x ^ i) + x ^ Suc n"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  show ?case
    using Suc.hyps by force
qed

lemma sum_star: "x\<^sup>\<star> = (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=0..n. x ^ i)"
proof (rule antisym)
  have "1 + (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=0..n. x ^ i) \<cdot> x = 1 + (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=0..n. x ^ Suc i)"
    using local.mult_assoc power_dist by presburger
  also have "\<dots> =  1 + (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=1..n. x ^ i) + (x ^ Suc n)\<^sup>\<star> \<cdot> x ^ Suc n"
    using local.add_assoc local.distl local.power_sum by presburger
  also have "\<dots> = (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=1..n. x ^ i) + (x ^ Suc n)\<^sup>\<star>"
    by (metis local.add.left_commute local.add_assoc star_unfoldr_eq)
  also have "\<dots> = (x ^ Suc n)\<^sup>\<star> \<cdot> (1 + (\<Sum>i=1..n. x ^ i))"
    using add_commute local.distl local.mult_1_right by presburger
  also have "\<dots> = (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=0..n. x ^ i)"
    by (simp add: local.sum.atLeast_Suc_atMost)
  finally show "x\<^sup>\<star> \<le> (x ^ Suc n)\<^sup>\<star> \<cdot> sum ((^) x) {0..n}"
    by (metis local.mult_1_left local.order_refl local.star_inductr)
next
  have a: "(x ^ Suc n)\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (metis star_idem star_iso star_power)
  have "(\<Sum>i=0..n. x ^ i) \<le> x\<^sup>\<star>"
    using power_sup star_power by presburger
  thus "(x ^ Suc n)\<^sup>\<star> \<cdot> sum ((^) x) {0..n} \<le> x\<^sup>\<star>"
    by (metis a local.mult_iso star_trans)
qed

end

subsection \<open>Linking Algebras with Models by Instantiation\<close>

instantiation nat :: mult_monoid
begin

instance
proof
  fix x y z :: nat
  show "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z"
    by simp
  show "1 \<cdot> x = x"
    by simp
  show "x \<cdot> 1 = x "
    by simp
qed

end

instantiation nat :: abelian_add_monoid
begin

instance
proof
  fix x y z :: nat
  show "x + (y + z) = (x + y) + z"
    by simp
  show "0 + x = x"
    by simp
  show "x + 0 = x "
    by simp
  show "x + y = y + x"
    by simp
qed

end

typedef 'a endo = "{f::'a \<Rightarrow> 'a . True}"
  by simp

setup_lifting type_definition_endo

instantiation endo :: (type) mult_monoid
begin

lift_definition one_endo :: "'a endo" is
  "Abs_endo id".

lift_definition times_endo :: "'a endo \<Rightarrow> 'a endo \<Rightarrow> 'a endo" is
  "\<lambda>x y. Abs_endo (Rep_endo x \<circ> Rep_endo y)".

instance
proof
  fix x y z :: "'a endo"
  show "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z"
    by transfer (simp add: Abs_endo_inverse fun.map_comp)
  show "1 \<cdot> x = x"
    by transfer (simp add: Abs_endo_inverse Rep_endo_inverse)
  show "x \<cdot> 1 = x "
    by transfer (simp add: Abs_endo_inverse Rep_endo_inverse)
qed

end

instantiation set :: (type) sup_semilattice
begin

definition plus_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "plus_set x y = x \<union> y"

definition zero_set :: "'a set" where
  "zero_set = {}"

instance
proof
  fix x y z :: "'a set"
  show "x + y + z = x + (y + z)"
    by (simp add: KA.plus_set_def sup_assoc)
  show "0 + x = x"
    by (simp add: plus_set_def zero_set_def)
  show "x + x = x"
    by (simp add: KA.plus_set_def)
  show "x + y = y + x"
    by (simp add: KA.plus_set_def sup_commute)
  show "(x \<subseteq> y) = (x + y = y)"
    by (simp add: KA.plus_set_def subset_Un_eq)
  show "(x \<subset> y) = (x \<subseteq> y \<and> x \<noteq> y)"
    by force
qed

end

interpretation inter_sl: sup_semilattice "(\<inter>)" UNIV "(\<supseteq>)" "(\<supset>)"
proof
  fix X Y Z :: "'a set"
  show "X \<inter> Y \<inter> Z = X \<inter> (Y \<inter> Z)"
    by (simp add: Int_assoc)
  show "X \<inter> Y = Y \<inter> X"
    by (simp add: inf_commute)
  show "UNIV \<inter> X = X"
    by simp
  show "X \<inter> X = X"
    by simp
  show "(Y \<subseteq> X) = (X \<inter> Y = Y)"
    by blast
  show "(Y \<subset> X) = (Y \<subseteq> X \<and> X \<noteq> Y)"
    by auto
qed

context dioid
begin

lemma power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x ^ i \<cdot> z \<le> y"
proof (induct i)
  case 0
  have "x ^ 0 \<cdot> z = z"
    by simp
  also have "\<dots> \<le> y"
    using "0.prems" local.add_lub by fastforce
  finally show ?case.
next
  case (Suc i)
  have "x ^ Suc i \<cdot> z = x \<cdot> x ^ i \<cdot> z"
    by simp
  also have "\<dots> \<le> x \<cdot> y"
    by (simp add: Suc.hyps Suc.prems local.mult_assoc local.mult_isol)
  also have "\<dots> \<le> y"
    using Suc.prems local.add_lub by auto
  finally show ?case.
qed

lemma power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ i \<le> y"
proof (induct i)
case 0
  thus ?case
    by (simp add: add_lub)
next
  case (Suc i)
  thus ?case
    by (smt add_lub distr mult_assoc order_def power_Suc2)
qed

end

subsection \<open>Relational Model of Kleene algebra\<close>

notation relcomp (infixl ";" 70)

text \<open>rel is not a type in Isabelle, so we need to do an interpretation statement instead of an
instantiation. That for dioids (Proposition 4.5) is trivial because relations are well supported
in Isabelle.\<close>

interpretation rel_d: dioid "(\<union>)" "{}" Id "(;)" "(\<subseteq>)" "(\<subset>)"
  by unfold_locales auto

lemma power_is_relpow: "rel_d.power R i = R ^^ i"
  by (induct i) (simp_all add: relpow_commute)

lemma rel_star_def: "R\<^sup>* = (\<Union>i. rel_d.power R i)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "R ; S\<^sup>* = (\<Union>i. R ; rel_d.power S i)"
proof-
  have "R ; S\<^sup>* = R ; (\<Union>i. rel_d.power S i)"
    unfolding rel_star_def by simp
  also have "\<dots> = (\<Union>i. R ; rel_d.power S i)"
    by (simp add: relcomp_UNION_distrib)
  finally show ?thesis.
qed

lemma rel_star_contr: "R\<^sup>* ; S = (\<Union>i. (rel_d.power R i) ; S)"
  by (simp add: rel_star_def relcomp_UNION_distrib2)

lemma rel_star_unfoldl: "Id \<union> R ; R\<^sup>* = R\<^sup>*"
proof-
  have "Id \<union> R ; R\<^sup>* = Id \<union> R ; (\<Union>i. rel_d.power R i)"
    by (simp add: rel_star_def)
  also have "\<dots> = Id \<union> (\<Union>i. R ; rel_d.power R i)"
    by (simp add: relcomp_UNION_distrib)
  also have "\<dots> = rel_d.power R 0  \<union> (\<Union>i. rel_d.power R (Suc i))"
    by auto
  also have "\<dots> = (\<Union>i. rel_d.power R i)"
    by (metis calculation r_comp_rtrancl_eq rel_star_def rtrancl_unfold)
  also have "\<dots> = R\<^sup>*"
    by (simp add: rel_star_def)
  finally show ?thesis.
qed

lemma rel_star_unfoldr: "Id \<union> R\<^sup>* ; R = R\<^sup>*"
  using rtrancl_unfold by blast

lemma rel_star_inductl:
  fixes R S T :: "'a rel"
  assumes "T \<union> R ; S \<subseteq> S"
  shows "R\<^sup>* ; T \<subseteq> S"
proof-
  have "\<forall>i. rel_d.power R i ; T \<subseteq> S"
    by (meson assms rel_d.power_inductl)
  hence "(\<Union>i. (rel_d.power R i) ; T) \<subseteq> S"
    by (simp add: SUP_least)
  hence "(\<Union>i. rel_d.power R i) ; T \<subseteq> S"
    by (simp add: relcomp_UNION_distrib2)
  thus ?thesis
    unfolding rel_star_def by simp
qed

lemma rel_star_inductr: "(T::'a rel) \<union> S ; R \<subseteq> S \<Longrightarrow> T ; R\<^sup>* \<subseteq> S"
  unfolding rel_star_def by (simp add: SUP_le_iff rel_d.power_inductr relcomp_UNION_distrib)

interpretation rel_ka: kleene_algebra "(\<union>)" "{}" Id "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl
proof unfold_locales
  fix x y z :: "'a rel"
  show "Id \<union> x ; x\<^sup>* \<subseteq> x\<^sup>*"
    by (simp add: rel_star_unfoldl)
  show "Id \<union> x\<^sup>* ; x \<subseteq> x\<^sup>*"
    by fastforce
  show  "z \<union> x ; y \<subseteq> y \<Longrightarrow> x\<^sup>* ; z \<subseteq> y"
    by (simp add: rel_star_inductl)
  show "z \<union> y ; x \<subseteq> y \<Longrightarrow> z ; x\<^sup>* \<subseteq> y"
    by (simp add: rel_star_inductr)
qed

subsection \<open>State Transformer Model of Kleene Algebra\<close>

type_synonym 'a sta = "'a \<Rightarrow> 'a set"

abbreviation eta :: "'a sta" ("\<eta>") where
  "\<eta> x \<equiv> {x}"

abbreviation nsta :: "'a sta" ("\<nu>") where
  "\<nu> x \<equiv> {}"

definition kcomp :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" (infixl "\<circ>\<^sub>K" 75) where
  "(f \<circ>\<^sub>K g) x = \<Union>{g y |y. y \<in> f x}"

definition kadd :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" (infixl "+\<^sub>K" 65) where
  "(f +\<^sub>K g) x = f x \<union> g x"

definition kleq :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
  "f \<sqsubseteq> g = (\<forall>x. f x \<subseteq> g x)"

definition kle :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> bool" (infix "\<sqsubset>" 50) where
  "f \<sqsubset> g = (f \<sqsubseteq> g \<and> f \<noteq> g)"

lemma sta_iff: "((f::'a sta) = g) = (\<forall>x y. y \<in> f x \<longleftrightarrow> y \<in> g x)"
  unfolding fun_eq_iff by force

lemma kcomp_iff: "y \<in> (f \<circ>\<^sub>K g) x = (\<exists>z. y \<in> g z \<and> z \<in> f x)"
  unfolding kcomp_def by force

lemma kadd_iff: "y \<in> (f +\<^sub>K g) x = (y \<in> f x \<or> y \<in> g x)"
  unfolding kadd_def by simp

lemma kleq_iff: "f \<sqsubseteq> g = (\<forall>x y. y \<in> f x \<longrightarrow> y \<in> g x)"
  unfolding kleq_def by blast

named_theorems sta_unfolds

declare
sta_iff [sta_unfolds]
kcomp_iff [sta_unfolds]
kadd_iff [sta_unfolds]
kleq_iff [sta_unfolds]

lemma kcomp_assoc: "(f \<circ>\<^sub>K g) \<circ>\<^sub>K h = f \<circ>\<^sub>K (g \<circ>\<^sub>K h)"
proof-
  {fix x y
  have "y \<in> ((f \<circ>\<^sub>K g) \<circ>\<^sub>K h) x = (\<exists>v. y \<in> h v \<and> (\<exists>w. v \<in> g w \<and> w \<in> f x))"
    unfolding sta_unfolds by simp
  also have "\<dots> = (\<exists>v w. y \<in> h v \<and> v \<in> g w \<and> w \<in> f x)"
    by blast
  also have "\<dots> = (\<exists>w. (\<exists>v. y \<in> h v \<and> v \<in> g w) \<and> w \<in> f x)"
    by blast
  also have "\<dots> = (y \<in> (f \<circ>\<^sub>K (g \<circ>\<^sub>K h)) x)"
    unfolding sta_unfolds by simp
  finally have "y \<in> ((f \<circ>\<^sub>K g) \<circ>\<^sub>K h) x = (y \<in> (f \<circ>\<^sub>K (g \<circ>\<^sub>K h)) x)".}
  thus ?thesis
    unfolding sta_unfolds by simp
qed

interpretation sta_monm: monoid_mult "\<eta>" "(\<circ>\<^sub>K)"
  by unfold_locales (auto simp: sta_unfolds)

interpretation sta_di: dioid "(+\<^sub>K)" "\<nu>" "\<eta>" "(\<circ>\<^sub>K)" "(\<sqsubseteq>)" "(\<sqsubset>)"
  by unfold_locales (auto simp: sta_unfolds kle_def)

abbreviation "kpow \<equiv> sta_monm.power"

definition kstar :: "'a sta \<Rightarrow> 'a sta" where
  "kstar f x = (\<Union>i. kpow f i x)"

lemma kstar_iff: "y \<in> kstar f x = (\<exists>i. y \<in> kpow f i x)"
  unfolding kstar_def by blast

declare kstar_iff [sta_unfolds]

lemma kstar_unfoldl: "\<eta> +\<^sub>K f \<circ>\<^sub>K kstar f \<sqsubseteq> kstar f"
  by (unfold sta_unfolds, metis (mono_tags) kcomp_iff power.power_eq_if sta_monm.power_Suc)

lemma kstar_unfoldr: "\<eta> +\<^sub>K kstar f \<circ>\<^sub>K f \<sqsubseteq> kstar f"
  by (unfold sta_unfolds, metis (mono_tags, lifting) kcomp_iff power.power.power_0 sta_monm.power_Suc2)

lemma kstar_contl: "(f \<circ>\<^sub>K kstar g) x = (\<Union>i. (f \<circ>\<^sub>K kpow g i) x)"
proof-
  {fix y
  have "y \<in> (f \<circ>\<^sub>K kstar g) x = (\<exists>z. z \<in> f x \<and> (\<exists>i. y \<in> kpow g i z))"
    unfolding sta_unfolds  by auto
  also have "\<dots> = (\<exists>i. (\<exists>z. z \<in> f x \<and> y \<in> kpow g i z))"
    by blast
  also have "\<dots> = (\<exists>i. (y \<in> (f \<circ>\<^sub>K kpow g i) x))"
    by (meson kcomp_iff)
  also have "\<dots> = (y \<in> (\<Union>i. (f \<circ>\<^sub>K kpow g i) x))"
    by blast
  finally have  "y \<in> (f \<circ>\<^sub>K kstar g) x = (y \<in> (\<Union>i. (f \<circ>\<^sub>K kpow g i) x))"
    by blast}
  thus ?thesis
    by blast
qed

lemma kstar_contr: "(kstar f \<circ>\<^sub>K g) x = (\<Union>i. (kpow f i \<circ>\<^sub>K g) x)"
  by (force simp: set_eq_iff sta_unfolds)

lemma kstar_inductl: "h +\<^sub>K f \<circ>\<^sub>K g \<sqsubseteq> g \<Longrightarrow> kstar f \<circ>\<^sub>K h \<sqsubseteq> g"
proof-
  assume "h +\<^sub>K f \<circ>\<^sub>K g \<sqsubseteq> g"
  hence "\<forall>i. kpow f i \<circ>\<^sub>K h \<sqsubseteq> g"
    using sta_di.power_inductl by blast
  thus "kstar f \<circ>\<^sub>K h \<sqsubseteq> g"
    by (unfold sta_unfolds, metis UN_E kstar_contr)
qed

lemma kstar_inductr: "h +\<^sub>K g \<circ>\<^sub>K f \<sqsubseteq> g \<Longrightarrow> h \<circ>\<^sub>K kstar f \<sqsubseteq> g"
proof-
  assume "h +\<^sub>K g \<circ>\<^sub>K f \<sqsubseteq> g"
  hence "\<forall>i. h \<circ>\<^sub>K kpow f i  \<sqsubseteq> g"
    using sta_di.power_inductr by blast
  thus "h \<circ>\<^sub>K kstar f  \<sqsubseteq> g"
    by (unfold sta_unfolds, metis UN_E kstar_contl)
qed

interpretation sta_ka: kleene_algebra "(+\<^sub>K)" "\<nu>" "\<eta>" "(\<circ>\<^sub>K)" "(\<sqsubseteq>)" "(\<sqsubset>)" kstar
  by unfold_locales (simp_all add: kstar_unfoldl kstar_unfoldr kstar_inductl kstar_inductr)

subsection \<open>Isomorphism between the models\<close>

definition r2s :: "'a rel \<Rightarrow> 'a sta" ("\<S>") where
  "\<S> R = Image R \<circ> \<eta>"

definition s2r :: "'a sta \<Rightarrow> 'a rel" ("\<R>") where
  "\<R> f = {(x,y). y \<in> f x}"

lemma r2s_iff: "y \<in> \<S> R x \<longleftrightarrow> (x,y) \<in> R"
  by (simp add: r2s_def)

lemma s2r_iff: "(x,y) \<in> \<R> f \<longleftrightarrow> y \<in> f x"
  by (simp add: s2r_def)

text \<open>The functors form a bijective pair.\<close>

lemma r2s2r_inv1 [simp]: "\<R> \<circ> \<S> = id"
  unfolding s2r_def r2s_def by force

lemma s2r2s_inv2 [simp]: "\<S> \<circ> \<R> = id"
  unfolding s2r_def r2s_def by force

lemma r2s2r_galois: "(\<R> f = R) = (\<S> R = f)"
  by (force simp: s2r_def r2s_def)

lemma r2s_inj: "inj \<S>"
  by (meson inj_on_inverseI r2s2r_galois)

lemma s2r_inj: "inj \<R>"
  unfolding inj_def using r2s2r_galois by metis

lemma r2s_surj: "surj \<S>"
  by (metis r2s2r_galois surj_def)

lemma s2r_surj: "surj \<R>"
  using r2s2r_galois by auto

lemma r2s_bij: "bij \<S>"
  by (simp add: bijI r2s_inj r2s_surj)

lemma s2r_bij: "bij \<R>"
  by (simp add: bij_def s2r_inj s2r_surj)

lemma s2r_comp: "\<S> (R ; S) = \<S> R \<circ>\<^sub>K \<S> S"
  unfolding sta_unfolds r2s_iff by force

lemma r2s_comp: "\<R> (f \<circ>\<^sub>K g) = \<R> f ; \<R> g"
  by (metis s2r_comp r2s2r_galois)

lemma s2r_id: "\<S> Id = \<eta>"
  by (metis empty_iff insert_iff pair_in_Id_conv r2s_iff subsetI subset_singletonD)

lemma r2s_id: "\<R> \<eta> = Id"
  by (metis R_O_Id power.power.power_0 r2s_comp r2s2r_galois rel_d.power_Suc rel_d.power_Suc2 sta_monm.mult_1_right)

lemma s2r_zero: "\<S> {} = \<nu>"
  unfolding r2s_def by force

lemma r2s_zero: "\<R> \<nu> = {}"
  by (simp add: s2r_def)

lemma r2s_add: "\<S> (R \<union> S) = \<S> R +\<^sub>K \<S> S"
  unfolding sta_unfolds r2s_iff by force

lemma s2r_add: "\<R> (f +\<^sub>K g) = \<R> f \<union> \<R> g"
  by (metis r2s_add r2s2r_galois)

lemma s2r_pow: "\<S> (rel_d.power R i) = kpow (\<S> R) i"
proof (induct i)
  case 0
  thus "\<S> (rel_d.power R 0) = kpow (\<S> R) 0"
    by (metis power.power.power_0 r2s2r_galois r2s_id)
next
  case (Suc i)
  assume h: "\<S> (rel_d.power R i) = kpow (\<S> R) i"
  have "\<S> (rel_d.power R (Suc i)) =\<S> R \<circ>\<^sub>K \<S> (rel_d.power R i)"
    by (simp add: s2r_comp)
  also have "... = \<S> R \<circ>\<^sub>K  kpow (\<S> R) i"
    by (simp add: h)
  also have "\<dots> = kpow (\<S> R) (Suc i)"
    by simp
  finally show "\<S> (rel_d.power R (Suc i)) = kpow (\<S> R) (Suc i)"
    by blast
qed

lemma s2r_star: "\<S> (R\<^sup>*) = kstar (\<S> R)"
proof-
  {fix x y
    have "y \<in> \<S> (R\<^sup>*) x = (\<exists>i. (x,y) \<in> rel_d.power R i)"
      by (simp add: power_is_relpow r2s_iff rtrancl_power)
  also have "\<dots> = (y \<in> (\<Union>i. \<S> (rel_d.power R i) x))"
    by (simp add: r2s_iff)
  also have "\<dots> = (y \<in> (\<Union>i. kpow (\<S> R) i x))"
    by (simp add: s2r_pow)
  also have "\<dots> = (y \<in> kstar (\<S> R) x)"
    by (simp add: kstar_iff)
  finally have "y \<in> \<S> (R\<^sup>*) x = (y \<in> kstar (\<S> R) x)".}
  thus ?thesis
    by blast
qed

lemma r2s_pow: "rel_d.power (\<R> f) i = \<R> (kpow f i)"
  by (metis s2r_pow r2s2r_galois)

lemma r2s_star: "\<R> (kstar f) = (\<R> f)\<^sup>*"
  by (metis s2r_star r2s2r_galois)

lemma kcomp_assoc2: "(f \<circ>\<^sub>K g) \<circ>\<^sub>K h = f \<circ>\<^sub>K (g \<circ>\<^sub>K h)"
proof-
  have "(f \<circ>\<^sub>K g) \<circ>\<^sub>K h = \<S> (\<R> ((f \<circ>\<^sub>K g) \<circ>\<^sub>K h))"
    by (metis r2s2r_galois)
  also have "\<dots> = \<S> ((\<R> f ; \<R> g) ; \<R> h)"
    by (simp add: r2s_comp)
  also have "\<dots> = \<S> (\<R> f ; (\<R> g ; \<R> h))"
    by (simp add: rel_d.mult_assoc)
  also have "\<dots> = \<S> (\<R> (f \<circ>\<^sub>K (g \<circ>\<^sub>K h)))"
    by (simp add: r2s_comp)
  also have "\<dots> = f \<circ>\<^sub>K (g \<circ>\<^sub>K h)"
    using r2s2r_galois by blast
  finally show ?thesis.
qed

subsection \<open>Embedding Predicates into State Transformers and Relations\<close>

type_synonym 'a pred = "'a \<Rightarrow> bool"

notation inf (infixl "\<sqinter>" 70)
notation sup (infixl "\<squnion>" 65)

text \<open>First we consider relations.\<close>

definition p2r :: "'a pred \<Rightarrow> 'a rel" ("\<lceil>_\<rceil>\<^sub>r") where
  "\<lceil>P\<rceil>\<^sub>r = {(s,s) |s. P s}"

definition r2p :: "'a rel \<Rightarrow> 'a pred" ("\<lfloor>_\<rfloor>\<^sub>r")where
  "\<lfloor>R\<rfloor>\<^sub>r \<equiv> (\<lambda>s. s \<in> Domain R)"

lemma r2p2r [simp]: "\<lfloor>\<lceil>P\<rceil>\<^sub>r\<rfloor>\<^sub>r = P"
  unfolding p2r_def r2p_def by force

lemma p2r2p: "R \<subseteq> Id \<Longrightarrow> \<lceil>\<lfloor>R\<rfloor>\<^sub>r\<rceil>\<^sub>r = R"
  unfolding p2r_def r2p_def by force

lemma p2r_r2p_galois: "R \<subseteq> Id \<Longrightarrow> (\<lfloor>R\<rfloor>\<^sub>r = P) = (R = \<lceil>P\<rceil>\<^sub>r)"
  using p2r2p by auto

lemma p2r_comp [simp]: "\<lceil>P\<rceil>\<^sub>r ; \<lceil>Q\<rceil>\<^sub>r = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>\<^sub>r"
  unfolding p2r_def by auto

lemma r2p_comp: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> \<lfloor>R ; S\<rfloor>\<^sub>r = (\<lambda>s. \<lfloor>R\<rfloor>\<^sub>r s \<and> \<lfloor>S\<rfloor>\<^sub>r s)"
  unfolding r2p_def by force

lemma p2r_imp [simp]: "\<lceil>P\<rceil>\<^sub>r \<subseteq> \<lceil>Q\<rceil>\<^sub>r = (\<forall>s. P s \<longrightarrow> Q s)"
  unfolding p2r_def by force

text \<open>Next we repeat the development with state transformers.\<close>

definition p2s :: "'a pred \<Rightarrow> 'a sta" ("\<lceil>_\<rceil>\<^sub>s") where
  "\<lceil>P\<rceil>\<^sub>s x \<equiv> if P x then {x} else {}"

definition s2p :: "'a sta \<Rightarrow> 'a pred" ("\<lfloor>_\<rfloor>\<^sub>s")where
  "\<lfloor>f\<rfloor>\<^sub>s s \<equiv> (f s \<noteq> {})"

lemma s2p2s [simp]: "\<lfloor>\<lceil>P\<rceil>\<^sub>s\<rfloor>\<^sub>s = P"
  unfolding p2s_def s2p_def by force

lemma p2s2p: "f \<sqsubseteq> \<eta> \<Longrightarrow> \<lceil>\<lfloor>f\<rfloor>\<^sub>s\<rceil>\<^sub>s = f"
  unfolding p2s_def s2p_def sta_iff kleq_iff by force

lemma p2s_s2p_galois: "f \<sqsubseteq> \<eta> \<Longrightarrow> (\<lfloor>f\<rfloor>\<^sub>s = P) = (f = \<lceil>P\<rceil>\<^sub>s)"
  unfolding p2s_def s2p_def sta_iff kleq_iff by force

lemma p2s_comp [simp]: "\<lceil>P\<rceil>\<^sub>s \<circ>\<^sub>K \<lceil>Q\<rceil>\<^sub>s = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>\<^sub>s"
  unfolding  p2s_def s2p_def sta_iff kcomp_iff by force

lemma s2p_comp: "f \<sqsubseteq> \<eta> \<Longrightarrow> g \<sqsubseteq> \<eta> \<Longrightarrow> \<lfloor>f \<circ>\<^sub>K g\<rfloor>\<^sub>s = (\<lambda>s. \<lfloor>f\<rfloor>\<^sub>s s \<and> \<lfloor>g\<rfloor>\<^sub>s s)"
  unfolding s2p_def kleq_iff kcomp_iff kcomp_def by blast

lemma p2s_imp [simp]: "\<lceil>P\<rceil>\<^sub>s \<sqsubseteq> \<lceil>Q\<rceil>\<^sub>s = (\<forall>s. P s \<longrightarrow> Q s)"
  unfolding  p2s_def s2p_def kleq_iff by simp

lemma p2r2s: "\<lceil>P\<rceil>\<^sub>s = \<S> \<lceil>P\<rceil>\<^sub>r"
  unfolding p2r_def p2s_def sta_iff r2s_iff by simp

lemma p2s2r: "\<lceil>P\<rceil>\<^sub>r = \<R> \<lceil>P\<rceil>\<^sub>s"
  by (metis (no_types) p2r2s r2s2r_galois)

end


(*  Title:      HOL/Library/Subseq_Order.thy
    Author:     Peter Lammich, Uni Muenster <peter.lammich@uni-muenster.de>
    Author:     Florian Haftmann, TU Muenchen
    Author:     Tobias Nipkow, TU Muenchen
*)

section \<open>Subsequence Ordering\<close>

theory Subseq_Order
imports Sublist
begin

text \<open>
  This theory defines subsequence ordering on lists. A list \<open>ys\<close> is a subsequence of a
  list \<open>xs\<close>, iff one obtains \<open>ys\<close> by erasing some elements from \<open>xs\<close>.
\<close>

subsection \<open>Definitions and basic lemmas\<close>

instantiation list :: (type) ord
begin

definition "xs \<le> ys \<longleftrightarrow> subseq xs ys" for xs ys :: "'a list"
definition "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs" for xs ys :: "'a list"

instance ..

end

instance list :: (type) order
proof
  fix xs ys zs :: "'a list"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    unfolding less_list_def ..
  show "xs \<le> xs"
    by (simp add: less_eq_list_def)
  show "xs = ys" if "xs \<le> ys" and "ys \<le> xs"
    using that unfolding less_eq_list_def by (rule subseq_order.antisym)
  show "xs \<le> zs" if "xs \<le> ys" and "ys \<le> zs"
    using that unfolding less_eq_list_def by (rule subseq_order.order_trans)
qed

lemmas less_eq_list_induct [consumes 1, case_names empty drop take] =
  list_emb.induct [of "(=)", folded less_eq_list_def]
lemmas less_eq_list_drop = list_emb.list_emb_Cons [of "(=)", folded less_eq_list_def]
lemmas le_list_Cons2_iff [simp, code] = subseq_Cons2_iff [folded less_eq_list_def]
lemmas le_list_map = subseq_map [folded less_eq_list_def]
lemmas le_list_filter = subseq_filter [folded less_eq_list_def]
lemmas le_list_length = list_emb_length [of "(=)", folded less_eq_list_def]

lemma less_list_length: "xs < ys \<Longrightarrow> length xs < length ys"
  by (metis list_emb_length subseq_same_length le_neq_implies_less less_list_def less_eq_list_def)

lemma less_list_empty [simp]: "[] < xs \<longleftrightarrow> xs \<noteq> []"
  by (metis less_eq_list_def list_emb_Nil order_less_le)

lemma less_list_below_empty [simp]: "xs < [] \<longleftrightarrow> False"
  by (metis list_emb_Nil less_eq_list_def less_list_def)

lemma less_list_drop: "xs < ys \<Longrightarrow> xs < x # ys"
  by (unfold less_le less_eq_list_def) (auto)

lemma less_list_take_iff: "x # xs < x # ys \<longleftrightarrow> xs < ys"
  by (metis subseq_Cons2_iff less_list_def less_eq_list_def)

lemma less_list_drop_many: "xs < ys \<Longrightarrow> xs < zs @ ys"
  by (metis subseq_append_le_same_iff subseq_drop_many order_less_le
      self_append_conv2 less_eq_list_def)

lemma less_list_take_many_iff: "zs @ xs < zs @ ys \<longleftrightarrow> xs < ys"
  by (metis less_list_def less_eq_list_def subseq_append')

lemma less_list_rev_take: "xs @ zs < ys @ zs \<longleftrightarrow> xs < ys"
  by (unfold less_le less_eq_list_def) auto

end