section \<open>Verification Condition Testing\<close>

theory control_flow_total_examples
  imports "../hoare/utp_hoare_total"
begin
text{*In this section we provide a set of examples on the verification
      of programs that uses control flow statements
      with Hoare logic for total correctness.
      The combination of relational algebra, ie. UTP, and lens algebra allows for a semantic based
      framework for the specification of programming languages and their features. It also
      allows a powerful proof tactics for the framework such as @{method rel_auto},
      @{method pred_auto}, etc.*}

text{*
   In the following examples:
      \begin{itemize}
         \<^item> The formal notation @{term "\<lbrace>Pre\<rbrace>prog\<lbrace>Post\<rbrace>\<^sub>D"} represent a hoare triple for total
            correctness.
         \<^item> All variables are represented by lenses and have the type @{typ "'v \<Longrightarrow> 's"}:
           where @{typ "'v"} is the view type of the lens and @{typ "'s"} is the type of the state.
         \<^item> Lens properties such as @{term "weak_lens"}, @{term "mwb_lens"}, @{term "wb_lens"},
           @{term "vwb_lens"}, @{term "ief_lens"}, @{term "bij_lens"}
           are used to semantically express what does not change in the state space. For example
           applying the property @{term "id_lens"}. Informally this means that any change on x will
           appear on all  other variables in the state space.The property @{term "ief_lens"} is
           just the opposite of @{term "id_lens"}.
         \<^item> The formal notation @{term "x \<sharp>\<sharp> P"} is a syntactic sugar for @{term "unrest_relation x P"}:
           informally it is used to semantically express that the variable x does not occur
           in the program P.
         \<^item> The formal notation @{term "x \<Midarrow> v"} is a syntactic sugar for @{term "assigns_c [x \<mapsto>\<^sub>s v]"}:
           informally it represent an assignment of a value v to a variable x.
         \<^item> The formal notation @{term "&x"} is a syntactic sugar for @{term "\<langle>id\<rangle>\<^sub>s x"}:
           informally it represent the content of a variable x.
         \<^item> The formal notation @{term "\<guillemotleft>l\<guillemotright>"} is a syntactic sugar for @{term "lit l"}:
            informally it represent a lifting of an HOL literal l to utp expression.
         \<^item> The formal notation @{term "x \<bowtie> y"} is a syntactic sugar for @{term "lens_indep x y"}:
           informally it is a semantic representation that uses two variables
           to characterise independence between two state space regions.
         \<^item> The tactics @{method rel_auto}, @{method pred_auto}, @{method rel_simp},
           @{method pred_simp}, @{method rel_blast}, @{method pred_blast} are used
           to discharge proofs related to UTP-relations and UTP-predicates.
     \end{itemize}
     *}

subsection {*catch feature*}

text{*The control flow statement @{term "try P catch Q end"} is used to capture state exceptions.
      Combined with the @{term "THROW"} it can be used to capture semantics of @{term return}
      @{term break} and @{term continue}. Informally @{term "try P catch Q end"} will execute
       a program @{term P}. If @{term P} triggers an exception, this exception is handled by
       @{term Q}.*}

text{*Informally @{term "THROW"} statement will transform
      the state from normal, ie. stable state, to an abrupt state. Under the assumption
      that the initial state of a program is stable, any control flow
      statement after @{term "THROW"} is executed will be purged. So, @{term "THROW"}
      is a left zero under the assumption that the initial state is stable.*}

lemma try_throw_zero:
  "Simpl (try THROW catch SKIP end) = SKIP"
  by rel_blast

lemma try_throw_zero_hoare:
      "\<lbrace>\<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>\<rbrace>
         i \<Midarrow> \<guillemotleft>2::int\<guillemotright>;; j \<Midarrow> \<guillemotleft>0::int\<guillemotright>;;
         try THROW;; i \<Midarrow> \<guillemotleft>7::int\<guillemotright>;; j \<Midarrow> \<guillemotleft>8::int\<guillemotright> catch SKIP end
       \<lbrace>&j =\<^sub>u \<guillemotleft>0::int\<guillemotright>\<and> &i =\<^sub>u \<guillemotleft>2::int\<guillemotright>\<rbrace>\<^sub>D"
  by rel_auto

lemma try_not_throw_ignor_catch:
  "Simpl (try \<langle>a\<rangle>\<^sub>C catch \<langle>b\<rangle>\<^sub>C end) = \<langle>a\<rangle>\<^sub>C"
  by rel_blast

lemma try_not_throw_ignor_catch_hoare:
      "\<lbrace>\<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>\<rbrace>
         try i \<Midarrow> \<guillemotleft>2::int\<guillemotright>;; j \<Midarrow> \<guillemotleft>0::int\<guillemotright> catch i \<Midarrow> \<guillemotleft>7::int\<guillemotright>;; j \<Midarrow> \<guillemotleft>8::int\<guillemotright> end
       \<lbrace>&j =\<^sub>u \<guillemotleft>0::int\<guillemotright>\<and> &i =\<^sub>u \<guillemotleft>2::int\<guillemotright>\<rbrace>\<^sub>D"
  by rel_auto

lemma try_throw_zero':
  "Simpl (try (SKIP ;; \<langle>a\<rangle>\<^sub>C;;THROW) catch \<langle>b\<rangle>\<^sub>C end) = (\<langle>a\<rangle>\<^sub>C ;; \<langle>b\<rangle>\<^sub>C)"
  by rel_auto blast +

lemma try_throw_zero'_hoare:
      "\<lbrace>\<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>\<rbrace>
         try SKIP ;; i \<Midarrow> \<guillemotleft>2::int\<guillemotright>;; j \<Midarrow> \<guillemotleft>0::int\<guillemotright>;; THROW
         catch i \<Midarrow> \<guillemotleft>7::int\<guillemotright>;; j \<Midarrow> \<guillemotleft>8::int\<guillemotright>  end
       \<lbrace>&i =\<^sub>u \<guillemotleft>7::int\<guillemotright> \<and> &j =\<^sub>u \<guillemotleft>8::int\<guillemotright> \<rbrace>\<^sub>D"
  by rel_auto

lemma "Simpl (try THROW ;; \<langle>a\<rangle>\<^sub>C catch SKIP end) = SKIP "
  by rel_auto blast +

lemma "Simpl (try (SKIP ;; \<langle>a\<rangle>\<^sub>C) catch SKIP end) =  \<langle>a\<rangle>\<^sub>C"
  by rel_auto blast +

lemma "Simpl (try (SKIP ;; \<langle>a\<rangle>\<^sub>C;;THROW) catch SKIP end) = \<langle>a\<rangle>\<^sub>C"
  by rel_auto blast +

subsection {*block feature*}

text {*block_test1 is a scenario. The scenario represent a program where i is name of the variable
       in the scope of the initial state s. In the scenario, and using the command block,
       we create a new variable with the same name inside the block ie., inside the new scope.
       Now i is a local var for the scope t.
       In that case we can use a restore function on the state s to set the variable to its
       previous value ie.,its value in the scope s, and this before we exit the block.*}

text \<open>The normal restore/return functions were verbose, so it's good to have an abbreviation to use
      to reduce duplicated code. Unfortunately, this does cause some parsing ambiguity, but Isabelle
      resolves that fairly well. It may reduce performance slightly, though.\<close>
abbreviation cp_des where
  "cp_des v s \<equiv> \<guillemotleft>\<lbrakk>v\<rbrakk>\<^sub>e ((cp_vars.more \<circ> des_vars.more) s)\<guillemotright>"

lemma   block_c_test1:
  shows "\<lbrace>\<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>\<rbrace>
          i \<Midarrow> \<guillemotleft>2::int\<guillemotright>;; j \<Midarrow> \<guillemotleft>0::int\<guillemotright>;;
          bob
            INIT j \<Midarrow> 5;; i \<Midarrow> 5
            BODY II
            RESTORE \<lambda> (s, _) _. i \<Midarrow> cp_des &i s;;
                                j \<Midarrow> cp_des &j s
            RETURN \<lambda> _ _. II
          eob
         \<lbrace>&j =\<^sub>u 0 \<and> &i =\<^sub>u 2\<rbrace>\<^sub>D"
  using assms by rel_simp

text {*block_test2 is similar to  block_test1 but the var i is a global var.
       In that case we can use restore function and the state t to set the variable to its
       latest value, ie.,its value in the scope t,probably modified inside the scope of the block.*}

lemma   block_c_test2:
  shows "\<lbrace>\<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>\<rbrace>
          i \<Midarrow> \<guillemotleft>2::int\<guillemotright>;; j \<Midarrow> \<guillemotleft>0::int\<guillemotright>;;
          bob
            INIT j \<Midarrow> 5;; i \<Midarrow> 5
            BODY II
            RESTORE \<lambda> _ (t, _). i \<Midarrow> cp_des &i t;;
                                j \<Midarrow> cp_des &j t
            RETURN \<lambda> _ _. II
          eob
         \<lbrace>&j =\<^sub>u 5\<and> &i =\<^sub>u 5\<rbrace>\<^sub>D"
  unfolding lens_indep_def by rel_simp

lemma  block_c_nested_test1:
  shows "\<lbrace>\<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>\<rbrace>
          i \<Midarrow> \<guillemotleft>2::int\<guillemotright>;; j \<Midarrow> \<guillemotleft>0::int\<guillemotright>;;
          bob
            INIT j \<Midarrow> 5;; i \<Midarrow> 5
            BODY
              bob
                INIT j \<Midarrow> 5;; i \<Midarrow> 5
                BODY II
                RESTORE \<lambda> (s, _) _. i \<Midarrow> cp_des &i s;;
                                    j \<Midarrow> cp_des &j s
                RETURN \<lambda> _ _. II
              eob
            RESTORE \<lambda> _ _. II
            RETURN \<lambda> _ _. II
          eob
         \<lbrace>&j =\<^sub>u 5 \<and> &i =\<^sub>u 5\<rbrace>\<^sub>D"
  unfolding lens_indep_def by rel_simp

lemma  block_c_nested_test2:
  shows "\<lbrace>\<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>\<rbrace>
          i \<Midarrow> \<guillemotleft>2::int\<guillemotright>;; j \<Midarrow> \<guillemotleft>0::int\<guillemotright>;;
          bob
            INIT j \<Midarrow> 5;; i \<Midarrow> 5
            BODY
              bob
                INIT j \<Midarrow> 5;; i \<Midarrow> 5
                BODY II
                RESTORE \<lambda> (s, _) _. i \<Midarrow> cp_des &i s;;
                                    j \<Midarrow> cp_des &j s
                RETURN \<lambda> _ _. II
              eob
            RESTORE \<lambda> (s, _) _. i \<Midarrow> cp_des &i s;;
                                j \<Midarrow> cp_des &j s
            RETURN \<lambda> _ _. II
          eob
         \<lbrace>&j =\<^sub>u 0 \<and> &i =\<^sub>u 2\<rbrace>\<^sub>D"
    by rel_simp
term "fault"
term "SKIP"
term "fault :== v"
term "fault :== v;; (assign_r (f k) \<guillemotleft>val\<guillemotright>) "
term "lens_comp "
term "fault :== v;; (assign_r (add1  ;\<^sub>L field) val) ;; x\<Midarrow> val1"
find_theorems name:".fault"
section {*Separation Algebra by Calcagno*}
subsection {*axioms*}
named_theorems separation_algebra

declare Lens_Laws.lens_indep_sym[separation_algebra] (*x \<sharp>\<sharp> y \<Longrightarrow> y \<sharp>\<sharp> x *)
declare unit_ief_lens[separation_algebra] (*x + 0 = x*)
declare lens_indep.lens_put_comm[separation_algebra] (*x \<sharp>\<sharp> y \<Longrightarrow>x + y = y + x *)
declare lens_indep.lens_put_irr1[separation_algebra]
declare lens_indep.lens_put_irr2[separation_algebra]

lemma [separation_algebra]:"x \<bowtie> 0\<^sub>L" (*x \<sharp>\<sharp> 0*)
  unfolding lens_indep_def
  by rel_auto

lemma [separation_algebra]:
  "\<lbrakk>X \<bowtie> Y; Y \<bowtie> Z; X \<bowtie> Z\<rbrakk>\<Longrightarrow>
   lens_put Z (lens_put X (lens_put Y \<sigma> v) u) i = lens_put X (lens_put Y (lens_put Z \<sigma> i) v) u"
  unfolding lens_indep_def
  by rel_auto

end


(*  Title:      HOL/Library/IArray.thy
    Author:     Tobias Nipkow, TU Muenchen
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section \<open>Immutable Arrays with Code Generation\<close>

theory IArray
imports Main
begin

subsection \<open>Fundamental operations\<close>

text \<open>Immutable arrays are lists wrapped up in an additional constructor.
There are no update operations. Hence code generation can safely implement
this type by efficient target language arrays.  Currently only SML is
provided. Could be extended to other target languages and more operations.\<close>

context
begin

datatype 'a iarray = IArray "'a list"

qualified primrec list_of :: "'a iarray \<Rightarrow> 'a list" where
"list_of (IArray xs) = xs"

qualified definition of_fun :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a iarray" where
[simp]: "of_fun f n = IArray (map f [0..<n])"

qualified definition sub :: "'a iarray \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 100) where
[simp]: "as !! n = IArray.list_of as ! n"

qualified definition length :: "'a iarray \<Rightarrow> nat" where
[simp]: "length as = List.length (IArray.list_of as)"

qualified definition all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a iarray \<Rightarrow> bool" where
[simp]: "all p as \<longleftrightarrow> (\<forall>a \<in> set (list_of as). p a)"

qualified definition exists :: "('a \<Rightarrow> bool) \<Rightarrow> 'a iarray \<Rightarrow> bool" where
[simp]: "exists p as \<longleftrightarrow> (\<exists>a \<in> set (list_of as). p a)"

lemma of_fun_nth:
"IArray.of_fun f n !! i = f i" if "i < n"
using that by (simp add: map_nth)

end

subsection \<open>Generic code equations\<close>

lemma [code]:
  "size_iarray f as = Suc (size_list f (IArray.list_of as))"
  by (cases as) simp

lemma [code]:
  "rec_iarray f as = f (IArray.list_of as)"
  by (cases as) simp

lemma [code]:
  "case_iarray f as = f (IArray.list_of as)"
  by (cases as) simp

lemma [code]:
  "set_iarray as = set (IArray.list_of as)"
  by (cases as) auto

lemma [code]:
  "map_iarray f as = IArray (map f (IArray.list_of as))"
  by (cases as) auto

lemma [code]:
  "rel_iarray r as bs = list_all2 r (IArray.list_of as) (IArray.list_of bs)"
  by (cases as, cases bs) auto

lemma list_of_code [code]:
  "IArray.list_of as = map (\<lambda>n. as !! n) [0 ..< IArray.length as]"
  by (cases as) (simp add: map_nth)

lemma [code]:
  "HOL.equal as bs \<longleftrightarrow> HOL.equal (IArray.list_of as) (IArray.list_of bs)"
  by (cases as, cases bs) (simp add: equal)

lemma [code]:
  "IArray.all p = Not \<circ> IArray.exists (Not \<circ> p)"
  by (simp add: fun_eq_iff)

context
  includes term_syntax
begin

lemma [code]:
  "Code_Evaluation.term_of (as :: 'a::typerep iarray) =
    Code_Evaluation.Const (STR ''IArray.iarray.IArray'') (TYPEREP('a list \<Rightarrow> 'a iarray)) <\<cdot>> (Code_Evaluation.term_of (IArray.list_of as))"
  by (subst term_of_anything) rule

end

subsection \<open>Auxiliary operations for code generation\<close>

context
begin

qualified primrec tabulate :: "integer \<times> (integer \<Rightarrow> 'a) \<Rightarrow> 'a iarray" where
  "tabulate (n, f) = IArray (map (f \<circ> integer_of_nat) [0..<nat_of_integer n])"

lemma [code]:
  "IArray.of_fun f n = IArray.tabulate (integer_of_nat n, f \<circ> nat_of_integer)"
  by simp

qualified primrec sub' :: "'a iarray \<times> integer \<Rightarrow> 'a" where
  "sub' (as, n) = as !! nat_of_integer n"

lemma [code]:
  "IArray.sub' (IArray as, n) = as ! nat_of_integer n"
  by simp

lemma [code]:
  "as !! n = IArray.sub' (as, integer_of_nat n)"
  by simp

qualified definition length' :: "'a iarray \<Rightarrow> integer" where
  [simp]: "length' as = integer_of_nat (List.length (IArray.list_of as))"

lemma [code]:
  "IArray.length' (IArray as) = integer_of_nat (List.length as)"
  by simp

lemma [code]:
  "IArray.length as = nat_of_integer (IArray.length' as)"
  by simp

qualified definition exists_upto :: "('a \<Rightarrow> bool) \<Rightarrow> integer \<Rightarrow> 'a iarray \<Rightarrow> bool" where
  [simp]: "exists_upto p k as \<longleftrightarrow> (\<exists>l. 0 \<le> l \<and> l < k \<and> p (sub' (as, l)))"

lemma exists_upto_of_nat:
  "exists_upto p (of_nat n) as \<longleftrightarrow> (\<exists>m<n. p (as !! m))"
  including integer.lifting by (simp, transfer)
    (metis nat_int nat_less_iff of_nat_0_le_iff)

lemma [code]:
  "exists_upto p k as \<longleftrightarrow> (if k \<le> 0 then False else
    let l = k - 1 in p (sub' (as, l)) \<or> exists_upto p l as)"
proof (cases "k \<ge> 1")
  case False
  then have \<open>k \<le> 0\<close>
    including integer.lifting by transfer simp
  then show ?thesis
    by simp
next
  case True
  then have less: "k \<le> 0 \<longleftrightarrow> False"
    by simp
  define n where "n = nat_of_integer (k - 1)"
  with True have k: "k - 1 = of_nat n" "k = of_nat (Suc n)"
    by simp_all
  show ?thesis unfolding less Let_def k(1) unfolding k(2) exists_upto_of_nat
    using less_Suc_eq by auto
qed

lemma [code]:
  "IArray.exists p as \<longleftrightarrow> exists_upto p (length' as) as"
  including integer.lifting by (simp, transfer)
   (auto, metis in_set_conv_nth less_imp_of_nat_less nat_int of_nat_0_le_iff)

end

subsection \<open>Code Generation for SML\<close>

text \<open>Note that arrays cannot be printed directly but only by turning them into
lists first. Arrays could be converted back into lists for printing if they
were wrapped up in an additional constructor.\<close>

code_reserved SML Vector

code_printing
  type_constructor iarray \<rightharpoonup> (SML) "_ Vector.vector"
| constant IArray \<rightharpoonup> (SML) "Vector.fromList"
| constant IArray.all \<rightharpoonup> (SML) "Vector.all"
| constant IArray.exists \<rightharpoonup> (SML) "Vector.exists"
| constant IArray.tabulate \<rightharpoonup> (SML) "Vector.tabulate"
| constant IArray.sub' \<rightharpoonup> (SML) "Vector.sub"
| constant IArray.length' \<rightharpoonup> (SML) "Vector.length"

subsection \<open>Code Generation for Haskell\<close>

text \<open>We map \<^typ>\<open>'a iarray\<close>s in Isabelle/HOL to \<open>Data.Array.IArray.array\<close>
  in Haskell.  Performance mapping to \<open>Data.Array.Unboxed.Array\<close> and
  \<open>Data.Array.Array\<close> is similar.\<close>

code_printing
  code_module "IArray" \<rightharpoonup> (Haskell) \<open>
module IArray(IArray, tabulate, of_list, sub, length) where {

  import Prelude (Bool(True, False), not, Maybe(Nothing, Just),
    Integer, (+), (-), (<), fromInteger, toInteger, map, seq, (.));
  import qualified Prelude;
  import qualified Data.Array.IArray;
  import qualified Data.Array.Base;
  import qualified Data.Ix;

  newtype IArray e = IArray (Data.Array.IArray.Array Integer e);

  tabulate :: (Integer, (Integer -> e)) -> IArray e;
  tabulate (k, f) = IArray (Data.Array.IArray.array (0, k - 1) (map (\i -> let fi = f i in fi `seq` (i, fi)) [0..k - 1]));

  of_list :: [e] -> IArray e;
  of_list l = IArray (Data.Array.IArray.listArray (0, (toInteger . Prelude.length) l - 1) l);

  sub :: (IArray e, Integer) -> e;
  sub (IArray v, i) = v `Data.Array.Base.unsafeAt` fromInteger i;

  length :: IArray e -> Integer;
  length (IArray v) = toInteger (Data.Ix.rangeSize (Data.Array.IArray.bounds v));

}\<close> for type_constructor iarray constant IArray IArray.tabulate IArray.sub' IArray.length'

code_reserved Haskell IArray_Impl

code_printing
  type_constructor iarray \<rightharpoonup> (Haskell) "IArray.IArray _"
| constant IArray \<rightharpoonup> (Haskell) "IArray.of'_list"
| constant IArray.tabulate \<rightharpoonup> (Haskell) "IArray.tabulate"
| constant IArray.sub' \<rightharpoonup> (Haskell)  "IArray.sub"
| constant IArray.length' \<rightharpoonup> (Haskell) "IArray.length"

end


(*  Title:      HOL/Hahn_Banach/Bounds.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Bounds\<close>

theory Bounds
imports Main "~~/src/HOL/Analysis/Continuum_Not_Denumerable"
begin

locale lub =
  fixes A and x
  assumes least [intro?]: "(\<And>a. a \<in> A \<Longrightarrow> a \<le> b) \<Longrightarrow> x \<le> b"
    and upper [intro?]: "a \<in> A \<Longrightarrow> a \<le> x"

lemmas [elim?] = lub.least lub.upper

definition the_lub :: "'a::order set \<Rightarrow> 'a"  ("\<Squnion>_" [90] 90)
  where "the_lub A = The (lub A)"

lemma the_lub_equality [elim?]:
  assumes "lub A x"
  shows "\<Squnion>A = (x::'a::order)"
proof -
  interpret lub A x by fact
  show ?thesis
  proof (unfold the_lub_def)
    from \<open>lub A x\<close> show "The (lub A) = x"
    proof
      fix x' assume lub': "lub A x'"
      show "x' = x"
      proof (rule order_antisym)
        from lub' show "x' \<le> x"
        proof
          fix a assume "a \<in> A"
          then show "a \<le> x" ..
        qed
        show "x \<le> x'"
        proof
          fix a assume "a \<in> A"
          with lub' show "a \<le> x'" ..
        qed
      qed
    qed
  qed
qed

lemma the_lubI_ex:
  assumes ex: "\<exists>x. lub A x"
  shows "lub A (\<Squnion>A)"
proof -
  from ex obtain x where x: "lub A x" ..
  also from x have [symmetric]: "\<Squnion>A = x" ..
  finally show ?thesis .
qed

lemma real_complete: "\<exists>a::real. a \<in> A \<Longrightarrow> \<exists>y. \<forall>a \<in> A. a \<le> y \<Longrightarrow> \<exists>x. lub A x"
  by (intro exI[of _ "Sup A"]) (auto intro!: cSup_upper cSup_least simp: lub_def)

end


theory nat_alt_mul_same
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

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

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

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

(*hipster plus mult altmul *)

theorem x0 :
  "!! (x :: Nat) . !! (y :: Nat) . (altmul x y) = (mult x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


section \<open> Symmetric Lenses \<close>

theory Lens_Symmetric
  imports Lens_Order
begin

text \<open> A characterisation of Hofmann's ``Symmetric Lenses''~\<^cite>\<open>"Hofmann2011"\<close>, where
  a lens is accompanied by its complement. \<close>

record ('a, 'b, 's) slens =
  view   :: "'a \<Longrightarrow> 's" ("\<V>\<index>") \<comment> \<open> The region characterised \<close>
  coview :: "'b \<Longrightarrow> 's" ("\<C>\<index>") \<comment> \<open> The complement of the region \<close>

type_notation
  slens ("<_, _> \<Longleftrightarrow> _" [0, 0, 0] 0)

declare slens.defs [lens_defs]

definition slens_compl :: "(<'a, 'c> \<Longleftrightarrow> 'b) \<Rightarrow> <'c, 'a> \<Longleftrightarrow> 'b" ("-\<^sub>L _" [81] 80) where
[lens_defs]: "slens_compl a = \<lparr> view = coview a, coview = view a \<rparr>"

lemma view_slens_compl [simp]: "\<V>\<^bsub>-\<^sub>L a\<^esub> =  \<C>\<^bsub>a\<^esub>"
  by (simp add: slens_compl_def)

lemma coview_slens_compl [simp]: "\<C>\<^bsub>-\<^sub>L a\<^esub> =  \<V>\<^bsub>a\<^esub>"
  by (simp add: slens_compl_def)

subsection \<open> Partial Symmetric Lenses \<close>

locale psym_lens =
  fixes S :: "<'a, 'b> \<Longleftrightarrow> 's" (structure)
  assumes
    mwb_region [simp]: "mwb_lens \<V>" and
    mwb_coregion [simp]: "mwb_lens \<C>" and
    indep_region_coregion [simp]: "\<V> \<bowtie> \<C>" and
    pbij_region_coregion [simp]: "pbij_lens (\<V> +\<^sub>L \<C>)"

declare psym_lens.mwb_region [simp]
declare psym_lens.mwb_coregion [simp]
declare psym_lens.indep_region_coregion [simp]

subsection \<open> Symmetric Lenses \<close>

locale sym_lens =
  fixes S :: "<'a, 'b> \<Longleftrightarrow> 's" (structure)
  assumes
    vwb_region: "vwb_lens \<V>" and
    vwb_coregion: "vwb_lens \<C>" and
    indep_region_coregion: "\<V> \<bowtie> \<C>" and
    bij_region_coregion: "bij_lens (\<V> +\<^sub>L \<C>)"
begin

sublocale psym_lens
proof (rule psym_lens.intro)
  show "mwb_lens \<V>"
    by (simp add: vwb_region)
  show "mwb_lens \<C>"
    by (simp add: vwb_coregion)
  show "\<V> \<bowtie> \<C>"
    using indep_region_coregion by blast
  show "pbij_lens (\<V> +\<^sub>L \<C>)"
    by (simp add: bij_region_coregion)
qed

lemma put_region_coregion_cover:
  "put\<^bsub>\<V>\<^esub> (put\<^bsub>\<C>\<^esub> s\<^sub>1 (get\<^bsub>\<C>\<^esub> s\<^sub>2)) (get\<^bsub>\<V>\<^esub> s\<^sub>2) = s\<^sub>2"
proof -
  have "put\<^bsub>\<V>\<^esub> (put\<^bsub>\<C>\<^esub> s\<^sub>1 (get\<^bsub>\<C>\<^esub> s\<^sub>2)) (get\<^bsub>\<V>\<^esub> s\<^sub>2) = put\<^bsub>\<V> +\<^sub>L \<C>\<^esub> s\<^sub>1 (get\<^bsub>\<V> +\<^sub>L \<C>\<^esub> s\<^sub>2)"
    by (simp add: lens_defs)
  also have "... = s\<^sub>2"
    by (simp add: bij_region_coregion)
  finally show ?thesis .
qed

end

declare sym_lens.vwb_region [simp]
declare sym_lens.vwb_coregion [simp]
declare sym_lens.indep_region_coregion [simp]

lemma sym_lens_psym [simp]: "sym_lens x \<Longrightarrow> psym_lens x"
  by (simp add: psym_lens_def sym_lens.bij_region_coregion)

lemma sym_lens_compl [simp]: "sym_lens a \<Longrightarrow> sym_lens (-\<^sub>L a)"
  apply (simp add: slens_compl_def)
  apply (rule sym_lens.intro, simp_all)
  using lens_indep_sym sym_lens.indep_region_coregion apply blast
  using bij_lens_equiv lens_plus_comm sym_lens_def apply blast
  done

end


theory FSM_Refined
  imports FSM
          "HOL-Library.Product_Lexorder"
          HOL.Record
          Deriving.Compare
          Containers.Containers
begin

(* TODO:
  - experiment with common-subexpression elimination
  - read up on AFP entries / userguides for
    - Containers
    - (maybe) Lifting/Transfer
*)

value[code] "{1::nat}"

(* TODO:
  - instantiations for type fsm
    - ceq, ccompare, ...
*)

(* TODO: linear order on FSMs can be created using set_less_aux or similar functions, as all
         contained sets are finite - but this is probably not that efficient/necessary,
         as sets of FSMs only occur at one point in the algorithm (collecting ATCs to append
         after the same path), after which the FSMs are translated to path sets anyway.
         Still, the instantiation can be made later to profile whether it has any positive
         effect on performance.
*)
instantiation fsm :: (ord,ord,ord) ord
begin

fun less_eq_fsm ::  "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) fsm \<Rightarrow> bool" where
  "less_eq_fsm M1 M2 =
    (if initial M1 < initial M2
      then True
      else ((initial M1 = initial M2) \<and> (if set_less_aux (nodes M1)  (nodes M2)
        then True
        else ((nodes M1 = nodes M2) \<and> (if set_less_aux (inputs M1) (inputs M2)
          then True
          else ((inputs M1 = inputs M2) \<and> (if set_less_aux (outputs M1) (outputs M2)
            then True
            else ((outputs M1 = outputs M2) \<and> (set_less_aux (transitions M1) (transitions M2) \<or> (transitions M1) = (transitions M2))))))))))"

fun less_fsm ::  "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) fsm \<Rightarrow> bool" where
  "less_fsm a b = (a \<le> b \<and> a \<noteq> b)"

instance by (intro_classes)
end

instantiation fsm :: (linorder,linorder,linorder) linorder
begin

lemma less_le_not_le_FSM :
  fixes x :: "('a,'b,'c) fsm"
  and   y :: "('a,'b,'c) fsm"
shows "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
proof
  show "x < y \<Longrightarrow> x \<le> y \<and> \<not> y \<le> x"

  proof -
    assume "x < y"
    then show "x \<le> y \<and> \<not> y \<le> x"
    proof (cases "FSM.initial x < FSM.initial y")
      case True
      then show ?thesis unfolding less_fsm.simps less_eq_fsm.simps by auto
    next
      case False
      then have *: "FSM.initial x = FSM.initial y"
        using \<open>x < y\<close> unfolding less_fsm.simps less_eq_fsm.simps by auto

      show ?thesis proof (cases "set_less_aux (FSM.nodes x) (FSM.nodes y)")
        case True
        then show ?thesis
          unfolding less_fsm.simps less_eq_fsm.simps
          using * set_less_aux_antisym by fastforce
      next
        case False
        then have **: "FSM.nodes x = FSM.nodes y"
          using \<open>x < y\<close> * unfolding less_fsm.simps less_eq_fsm.simps by auto

        show ?thesis proof (cases "set_less_aux (FSM.inputs x) (FSM.inputs y)")
          case True
          then show ?thesis
            unfolding less_fsm.simps less_eq_fsm.simps
            using * ** set_less_aux_antisym by fastforce
        next
          case False
          then have ***: "FSM.inputs x = FSM.inputs y"
            using \<open>x < y\<close> * ** unfolding less_fsm.simps less_eq_fsm.simps by (simp add: set_less_def)

          show ?thesis proof (cases "set_less_aux (FSM.outputs x) (FSM.outputs y)")
            case True
            then show ?thesis
              unfolding less_fsm.simps less_eq_fsm.simps
              using * ** *** set_less_aux_antisym by fastforce
          next
            case False
            then have ****: "FSM.outputs x = FSM.outputs y"
              using \<open>x < y\<close> * ** *** unfolding less_fsm.simps less_eq_fsm.simps by (simp add: set_less_def)

            have "x \<noteq> y" using \<open>x < y\<close> by auto
            then have "FSM.transitions x \<noteq> FSM.transitions y"
              using * ** *** **** by (transfer; auto)
            then have *****: "set_less_aux (FSM.transitions x) (FSM.transitions y)"
              using \<open>x < y\<close> * ** *** **** unfolding less_fsm.simps less_eq_fsm.simps by (simp add: set_less_aux_def)

            then have "\<not>(set_less_aux (FSM.transitions y) (FSM.transitions x) \<or> transitions y = transitions x)"
              using \<open>FSM.transitions x \<noteq> FSM.transitions y\<close> fsm_transitions_finite set_less_aux_antisym by auto
            then have "\<not> y \<le> x"
              using * ** *** **** unfolding less_fsm.simps less_eq_fsm.simps
              by (simp add: set_less_def)
            then show ?thesis using \<open>x < y\<close>
              using less_fsm.elims(2) by blast
          qed
        qed
      qed
    qed
  qed

  show "x \<le> y \<and> \<not> y \<le> x \<Longrightarrow> x < y"
    using less_fsm.elims(3) by blast
qed

lemma order_refl_FSM :
  fixes x :: "('a,'b,'c) fsm"
  shows "x \<le> x"
  by auto

lemma order_trans_FSM :
  fixes x :: "('a,'b,'c) fsm"
  fixes y :: "('a,'b,'c) fsm"
  fixes z :: "('a,'b,'c) fsm"
  shows "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
  unfolding less_eq_fsm.simps
  using less_trans[of "initial x" "initial y" "initial z"]
        set_less_aux_trans[of "nodes x" "nodes y" "nodes z"]
        set_less_aux_trans[of "inputs x" "inputs y" "inputs z"]
        set_less_aux_trans[of "outputs x" "outputs y" "outputs z"]
        set_less_aux_trans[of "transitions x" "transitions y" "transitions z"]
  by metis

lemma antisym_FSM :
  fixes x :: "('a,'b,'c) fsm"
  fixes y :: "('a,'b,'c) fsm"
shows "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
  unfolding less_eq_fsm.simps
  using equal_fsm_def[of x y]
  unfolding equal_class.equal
  by (metis order.asym set_less_aux_antisym)

lemma linear_FSM :
  fixes x :: "('a,'b,'c) fsm"
  fixes y :: "('a,'b,'c) fsm"
shows "x \<le> y \<or> y \<le> x"
  unfolding less_eq_fsm.simps
  by (metis fsm_inputs_finite fsm_nodes_finite fsm_outputs_finite fsm_transitions_finite neq_iff set_less_aux_finite_total)

instance
  using less_le_not_le_FSM order_refl_FSM order_trans_FSM antisym_FSM linear_FSM
  by (intro_classes; metis+)
end

instantiation fsm :: (linorder,linorder,linorder) compare
begin
fun compare_fsm :: "('a, 'b, 'c) fsm \<Rightarrow> ('a, 'b, 'c) fsm \<Rightarrow> order" where
  "compare_fsm x y = comparator_of x y"

instance
  using comparator_of compare_fsm.elims
  by (intro_classes; simp add: comparator_def)
end

instantiation fsm :: (linorder,linorder,linorder) ccompare
begin
definition ccompare_fsm :: "(('a, 'b, 'c) fsm \<Rightarrow> ('a, 'b, 'c) fsm \<Rightarrow> order) option" where
  "ccompare_fsm = Some compare"

instance by (intro_classes; simp add: ccompare_fsm_def comparator_compare)
end

subsection \<open>Derive\<close>

derive (eq) ceq fsm
derive (rbt) set_impl fsm
derive (rbt) mapping_impl fsm

value "{m_ex_H,m_ex_H}"
value "{m_ex_H,m_ex_H,m_ex_H}"
value[code] "compare m_ex_H m_ex_H"

subsection \<open>Revisiting h\<close>

subsubsection \<open>New Code Generation for set_as_map\<close>

declare [[code drop: set_as_map]]

lemma set_as_map_code[code] :
  fixes t :: "('a :: ccompare \<times> 'c :: ccompare) set_rbt"
  shows "set_as_map (RBT_set t) = (case ID CCOMPARE(('a \<times> 'c)) of
           Some _ \<Rightarrow> Mapping.lookup (RBT_Set2.fold (\<lambda> (x,z) m . case Mapping.lookup m (x) of
                        None \<Rightarrow> Mapping.update (x) {z} m |
                        Some zs \<Rightarrow> Mapping.update (x) (insert z zs) m)
                      t
                      Mapping.empty) |
           None   \<Rightarrow> Code.abort (STR ''set_as_map RBT_set: ccompare = None'')
                                (\<lambda>_. set_as_map (RBT_set t)))"
proof (cases "ID CCOMPARE(('a \<times> 'c))")
  case None
  then show ?thesis by auto
next
  case (Some a)

  let ?f' = "(\<lambda> t' . (RBT_Set2.fold (\<lambda> (x,z) m . case Mapping.lookup m x of
                                                None \<Rightarrow> Mapping.update x {z} m |
                                                Some zs \<Rightarrow> Mapping.update x (insert z zs) m)
                           t'
                           Mapping.empty))"

  let ?f = "\<lambda> xs . (fold (\<lambda> (x,z) m . case Mapping.lookup m x of
                                                None \<Rightarrow> Mapping.update x {z} m |
                                                Some zs \<Rightarrow> Mapping.update x (insert z zs) m)
                          xs Mapping.empty)"
  have "\<And> xs :: ('a \<times> 'c) list . Mapping.lookup (?f xs) = (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None)"
  proof -
    fix xs :: "('a \<times> 'c) list"
    show "Mapping.lookup (?f xs) = (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None)"
    proof (induction xs rule: rev_induct)
      case Nil
      then show ?case
        by (simp add: Mapping.empty.abs_eq Mapping.lookup.abs_eq)
    next
      case (snoc xz xs)
      then obtain x z where "xz = (x,z)"
        by (metis (mono_tags, hide_lams) surj_pair)

      have *: "(?f (xs@[(x,z)])) = (case Mapping.lookup (?f xs) x of
                                  None \<Rightarrow> Mapping.update x {z} (?f xs) |
                                  Some zs \<Rightarrow> Mapping.update x (insert z zs) (?f xs))"
        by auto

      then show ?case proof (cases "Mapping.lookup (?f xs) x")
        case None
        then have **: "Mapping.lookup (?f (xs@[(x,z)])) = Mapping.lookup (Mapping.update x {z} (?f xs))" using * by auto

        have scheme: "\<And> m k v . Mapping.lookup (Mapping.update k v m) = (\<lambda>k' . if k' = k then Some v else Mapping.lookup m k')"
          by (metis lookup_update')

        have m1: "Mapping.lookup (?f (xs@[(x,z)])) = (\<lambda> x' . if x' = x then Some {z} else Mapping.lookup (?f xs) x')"
          unfolding **
          unfolding scheme by force

        have "(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = None"
        using None snoc by auto
        then have "\<not>(\<exists> z . (x,z) \<in> set xs)"
          by (metis (mono_tags, lifting) option.distinct(1))
        then have "(\<exists> z' . (x,z') \<in> set (xs@[(x,z)]))" and "{z' . (x,z') \<in> set (xs@[(x,z)])} = {z}"
          by fastforce+
        then have m2: "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None)
                     = (\<lambda> x' . if x' = x then Some {z} else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x')"
          by force

        show ?thesis using m1 m2 snoc
          using \<open>xz = (x, z)\<close> by presburger
      next
        case (Some zs)
        then have **: "Mapping.lookup (?f (xs@[(x,z)])) = Mapping.lookup (Mapping.update x (insert z zs) (?f xs))" using * by auto
        have scheme: "\<And> m k v . Mapping.lookup (Mapping.update k v m) = (\<lambda>k' . if k' = k then Some v else Mapping.lookup m k')"
          by (metis lookup_update')

        have m1: "Mapping.lookup (?f (xs@[(x,z)])) = (\<lambda> x' . if x' = x then Some (insert z zs) else Mapping.lookup (?f xs) x')"
          unfolding **
          unfolding scheme by force

        have "(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = Some zs"
          using Some snoc by auto
        then have "(\<exists> z' . (x,z') \<in> set xs)"
          unfolding case_prod_conv using  option.distinct(2) by metis
        then have "(\<exists> z' . (x,z') \<in> set (xs@[(x,z)]))" by fastforce

        have "{z' . (x,z') \<in> set (xs@[(x,z)])} = insert z zs"
        proof -
          have "Some {z . (x,z) \<in> set xs} = Some zs"
            using \<open>(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = Some zs\<close>
            unfolding case_prod_conv using  option.distinct(2) by metis
          then have "{z . (x,z) \<in> set xs} = zs" by auto
          then show ?thesis by auto
        qed

        have "\<And> a  . (\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None) a
                   = (\<lambda> x' . if x' = x then Some (insert z zs) else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x') a"
        proof -
          fix a show "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None) a
                     = (\<lambda> x' . if x' = x then Some (insert z zs) else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x') a"
          using \<open>{z' . (x,z') \<in> set (xs@[(x,z)])} = insert z zs\<close> \<open>(\<exists> z' . (x,z') \<in> set (xs@[(x,z)]))\<close>
          by (cases "a = x"; auto)
        qed

        then have m2: "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None)
                     = (\<lambda> x' . if x' = x then Some (insert z zs) else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x')"
          by auto

        show ?thesis using m1 m2 snoc
          using \<open>xz = (x, z)\<close> by presburger
      qed
    qed
  qed
  then have "Mapping.lookup (?f' t) = (\<lambda> x . if (\<exists> z . (x,z) \<in> set (RBT_Set2.keys t)) then Some {z . (x,z) \<in> set (RBT_Set2.keys t)} else None)"
    unfolding fold_conv_fold_keys by metis
  moreover have "set (RBT_Set2.keys t) = (RBT_set t)"
    using Some by (simp add: RBT_set_conv_keys)
  ultimately have "Mapping.lookup (?f' t) = (\<lambda> x . if (\<exists> z . (x,z) \<in> (RBT_set t)) then Some {z . (x,z) \<in> (RBT_set t)} else None)"
    by force

  then show ?thesis
    using Some unfolding set_as_map_def by simp
qed

declare pretty_sets[code_post del]
value[code] "h (m_ex_H) (1,1)"

value[code] "{1::integer,2,3,4,5}"
value[code] "sorted_list_of_set {1::integer,2,3,4,5}"

declare pretty_sets[code_post]
value[code] "h (m_ex_H) (1,1)"
value[code] "h (m_ex_H) (1,2)"
value[code] "h (m_ex_H) (1,4)"

(* TODO *)
(*
  - write much more efficient alg for calculating reachable nodes (if necessary), maybe using a depth first search
  - (related) maybe lookup efficient graph algorithms in Isabelle
*)

(*code_printing class_instance integer :: mapping_impl \<rightharpoonup> (Haskell)*)
code_deps h

(* TODO: xy is currently only added to force isabelle to export the mapping_impl instantiation of integer
  \<rightarrow> find out how to export instantiations OR
  \<rightarrow> later only export the integer versions of the algorithms *)
definition xy :: "(integer \<times> integer) \<Rightarrow> (integer \<times> integer) set" where "xy = h m_ex_H"
export_code open h m_ex_H FSM.initial mapping_impl xy in Haskell module_name H4

end


(*
Title: 2-Quantales
Author: Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>2-Quantales\<close>

theory Two_Quantale
  imports Modal_Quantale

begin

class quantale0 = complete_lattice + monoid_mult0 +
  assumes Sup_distl0: "x \<cdot>\<^sub>0 \<Squnion>Y = (\<Squnion>y \<in> Y. x \<cdot>\<^sub>0 y)"
  assumes Sup_distr0: "\<Squnion>X \<cdot>\<^sub>0 y = (\<Squnion>x \<in> X. x \<cdot>\<^sub>0 y)"

sublocale quantale0 \<subseteq> q0q: quantale _ _ _ _ _ _ _ _ "1\<^sub>0" "(\<cdot>\<^sub>0)"
  by (unfold_locales, auto simp: local.Sup_distl0 local.Sup_distr0)

definition (in quantale0) "qstar0 = q0q.qstar"

lemma (in quantale0) qstar0_unfold: "qstar0 x = \<Squnion>{mm0.power x i |i. True}"
  unfolding qstar0_def q0q.qstar_def by simp

sublocale quantale0 \<subseteq> dq0s0: dioid0 "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "(\<cdot>\<^sub>0)" "1\<^sub>0"
  by (unfold_locales, simp_all add: q0q.qdual.qd.distr local.q0q.qdual.qd.dd.distr)

sublocale quantale0 \<subseteq> dq0ka0: kleene_algebra0 "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "(\<cdot>\<^sub>0)" "1\<^sub>0" qstar0
  by (unfold_locales, simp_all add: local.qstar0_def q0q.star_inductl q0q.star_inductr)

class domain_quantale0 = quantale0 + dom0_op +
  assumes dom0_absorb: "x \<le> dom\<^sub>0 x \<cdot>\<^sub>0 x"
  and dom0_local: "dom\<^sub>0 (x \<cdot>\<^sub>0 dom\<^sub>0 y) = dom\<^sub>0 (x \<cdot>\<^sub>0 y)"
  and dom0_add: "dom\<^sub>0 (x \<squnion> y) = dom\<^sub>0 x \<squnion> dom\<^sub>0 y"
  and dom0_subid: "dom\<^sub>0 x \<le> 1\<^sub>0"
  and dom0_zero: "dom\<^sub>0 \<bottom> = \<bottom>"

sublocale domain_quantale0 \<subseteq> dq0dq: domain_quantale  "dom\<^sub>0" _ _ _ _ _ _ _ _ "1\<^sub>0" "(\<cdot>\<^sub>0)"
  by (unfold_locales, simp_all add: local.dom0_absorb local.dom0_local local.dom0_add local.dom0_subid dom0_zero)

sublocale domain_quantale0 \<subseteq> dq0ds0: domain_semiring0 "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "(\<cdot>\<^sub>0)" "1\<^sub>0" "dom\<^sub>0"
  by ( unfold_locales, simp_all add: local.dom0_local local.dom0_add local.dom0_subid dom0_zero)

class codomain_quantale0 = quantale0 + cod0_op +
  assumes cod0_absorb: "x \<le> x \<cdot>\<^sub>0 cod\<^sub>0 x"
  and cod0_local: "cod\<^sub>0 (cod\<^sub>0 x \<cdot>\<^sub>0 y) = cod\<^sub>0 (x \<cdot>\<^sub>0 y)"
  and cod0_add: "cod\<^sub>0 (x \<squnion> y) = cod\<^sub>0 x \<squnion> cod\<^sub>0 y"
  and cod0_subid: "cod\<^sub>0 x \<le> 1\<^sub>0"
  and cod0_zero: "cod\<^sub>0 \<bottom> = \<bottom>"

sublocale codomain_quantale0 \<subseteq> cdq0cdq: codomain_quantale "cod\<^sub>0" _ _ _ _ _ _ _ _ "1\<^sub>0" "(\<cdot>\<^sub>0)"
  by (unfold_locales, simp_all add: local.cod0_absorb local.cod0_local local.cod0_add local.cod0_subid cod0_zero)

sublocale codomain_quantale0 \<subseteq> cdq0dcs0: codomain_semiring0  "cod\<^sub>0" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)"  "(\<cdot>\<^sub>0)" "1\<^sub>0"
  by (unfold_locales, simp_all add: local.cod0_absorb local.cod0_local local.cod0_add local.cod0_subid cod0_zero)

class modal_quantale0 = domain_quantale0 + codomain_quantale0 +
  assumes dc_compat: "dom\<^sub>0 (cod\<^sub>0 x) = cod\<^sub>0 x"
  and cd_compat: "cod\<^sub>0 (dom\<^sub>0 x) = dom\<^sub>0 x"

sublocale modal_quantale0 \<subseteq> mq0mq: modal_quantale "cod\<^sub>0" _ _ _ _ _ _ _ _ "1\<^sub>0" "(\<cdot>\<^sub>0)" "dom\<^sub>0"
  by (unfold_locales, simp_all add: dc_compat cd_compat)

sublocale modal_quantale0 \<subseteq> mq0mka: modal_kleene_algebra0 "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "(\<cdot>\<^sub>0)" "1\<^sub>0" qstar0 "cod\<^sub>0" "dom\<^sub>0"
  by unfold_locales simp_all

sublocale modal_quantale0 \<subseteq> mq0dual: modal_quantale0 "dom\<^sub>0" _ _ _ _ _ _ _ _ "\<lambda>x y. y \<cdot>\<^sub>0 x" _ "cod\<^sub>0"
  by ( unfold_locales, simp_all add: local.Sup_distr0 local.Sup_distl0 local.dom0_local local.dom0_add local.dom0_subid local.cod0_local local.cod0_add local.cod0_subid)

class quantale1 = complete_lattice + monoid_mult1 +
  assumes Sup_distl1: "x \<cdot>\<^sub>1 \<Squnion>Y = (\<Squnion>y \<in> Y. x \<cdot>\<^sub>1 y)"
  assumes Sup_distr1: "\<Squnion>X \<cdot>\<^sub>1 y = (\<Squnion>x \<in> X. x \<cdot>\<^sub>1 y)"

sublocale quantale1 \<subseteq> q1q: quantale _ _ _ _ _ _ _ _ "1\<^sub>1" "(\<cdot>\<^sub>1)"
  by (unfold_locales, auto simp: local.Sup_distl1 local.Sup_distr1)

definition (in quantale1) "qstar1 = q1q.qstar"

lemma (in quantale1) qstar1_unfold: "qstar1 x = \<Squnion>{mm1.power x i |i. True}"
  unfolding qstar1_def q1q.qstar_def by simp

sublocale quantale1 \<subseteq> dq1s1: dioid1 "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "(\<cdot>\<^sub>1)" "1\<^sub>1"
  by (unfold_locales, simp_all add: local.q1q.qdual.qd.dd.distl q1q.qdual.qd.distl)

sublocale quantale1 \<subseteq> dq0ka1: kleene_algebra1 "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "(\<cdot>\<^sub>1)" "1\<^sub>1" qstar1
  by (unfold_locales, simp_all add: local.qstar1_def q1q.star_inductl q1q.star_inductr)

class domain_quantale1 = quantale1 + dom1_op +
  assumes dom1_absorb: "x \<le> dom\<^sub>1 x \<cdot>\<^sub>1 x"
  and dom1_local: "dom\<^sub>1 (x \<cdot>\<^sub>1 dom\<^sub>1 y) = dom\<^sub>1 (x \<cdot>\<^sub>1 y)"
  and dom1_add: "dom\<^sub>1 (x \<squnion> y) = dom\<^sub>1 x \<squnion> dom\<^sub>1 y"
  and dom1_subid: "dom\<^sub>1 x \<le> 1\<^sub>1"
  and dom1_zero: "dom\<^sub>1 \<bottom> = \<bottom>"

sublocale domain_quantale1 \<subseteq> dq1dq: domain_quantale "dom\<^sub>1" _ _ _ _ _ _ _ _ "1\<^sub>1" "(\<cdot>\<^sub>1)"
  by (unfold_locales, simp_all add: local.dom1_absorb local.dom1_local local.dom1_add local.dom1_subid dom1_zero)

sublocale domain_quantale1 \<subseteq> dq1ds1: domain_semiring1 "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "(\<cdot>\<^sub>1)" "1\<^sub>1" "dom\<^sub>1"
  by (unfold_locales, simp_all add: local.dom1_local local.dom1_add local.dom1_subid dom1_zero)

class codomain_quantale1 = quantale1 + cod1_op +
  assumes cod1_absorb: "x \<le> x \<cdot>\<^sub>1 cod\<^sub>1 x"
  and cod1_local: "cod\<^sub>1 (cod\<^sub>1 x \<cdot>\<^sub>1 y) = cod\<^sub>1 (x \<cdot>\<^sub>1 y)"
  and cod1_add: "cod\<^sub>1 (x \<squnion> y) = cod\<^sub>1 x \<squnion> cod\<^sub>1 y"
  and cod1_subid: "cod\<^sub>1 x \<le> 1\<^sub>1"
  and cod1_zero: "cod\<^sub>1 \<bottom> = \<bottom>"

sublocale codomain_quantale1 \<subseteq> cdq1cdq: codomain_quantale "cod\<^sub>1" _ _ _ _ _ _ _ _ "1\<^sub>1" "(\<cdot>\<^sub>1)"
  by (unfold_locales, simp_all add: local.cod1_absorb local.cod1_local local.cod1_add local.cod1_subid cod1_zero)

sublocale codomain_quantale1 \<subseteq> cdq1dcs1: codomain_semiring1 "cod\<^sub>1" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)"  "(\<cdot>\<^sub>1)" "1\<^sub>1"
  by (unfold_locales, simp_all add: local.cod1_absorb local.cod1_local local.cod1_add local.cod1_subid cod1_zero)

class modal_quantale1 = domain_quantale1 + codomain_quantale1 +
  assumes dc_compat: "dom\<^sub>1 (cod\<^sub>1 x) = cod\<^sub>1 x"
  and cd_compat: "cod\<^sub>1 (dom\<^sub>1 x) = dom\<^sub>1 x"

sublocale modal_quantale1 \<subseteq> mq1mq: modal_quantale "cod\<^sub>1" _ _ _ _ _ _ _ _ "1\<^sub>1" "(\<cdot>\<^sub>1)" "dom\<^sub>1"
  by (unfold_locales, simp_all add: local.dc_compat local.cd_compat)

sublocale modal_quantale1 \<subseteq> mq1mka: modal_kleene_algebra1  "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "(\<cdot>\<^sub>1)" "1\<^sub>1" qstar1 "cod\<^sub>1" "dom\<^sub>1"
  by unfold_locales simp_all

sublocale modal_quantale1 \<subseteq> mq1dual: modal_quantale1 "dom\<^sub>1" _ _ _ _ _ _ _ _ "\<lambda>x y. y \<cdot>\<^sub>1 x" _ "cod\<^sub>1"
  by (unfold_locales, simp_all add: local.q1q.qdual.Sup_distl local.Sup_distl1 local.dom1_local local.dom1_add local.dom1_subid local.cod1_local local.cod1_add local.cod1_subid local.cd_compat local.dc_compat)

class globular_2_quantale = modal_quantale0 + modal_quantale1 +
  assumes interchange: "(w \<cdot>\<^sub>1 x) \<cdot>\<^sub>0 (y \<cdot>\<^sub>1 z) \<le> (w \<cdot>\<^sub>0 y) \<cdot>\<^sub>1 (x \<cdot>\<^sub>0 z)"
  and d1_hom [simp]: "dom\<^sub>1 (x \<cdot>\<^sub>0 y) = dom\<^sub>1 x \<cdot>\<^sub>0 dom\<^sub>1 y"
  and c1_hom [simp]: "cod\<^sub>1 (x \<cdot>\<^sub>0 y) = cod\<^sub>1 x \<cdot>\<^sub>0 cod\<^sub>1 y"
  and d0_weak_hom: "dom\<^sub>0 (x \<cdot>\<^sub>1 y) \<le> dom\<^sub>0 x \<cdot>\<^sub>1 dom\<^sub>0 y"
  and c0_weak_hom: "cod\<^sub>0 (x \<cdot>\<^sub>1 y) \<le> cod\<^sub>0 x \<cdot>\<^sub>1 cod\<^sub>0 y"
  and d1d0 [simp]: "dom\<^sub>1 (dom\<^sub>0 x) = dom\<^sub>0 x"

sublocale globular_2_quantale \<subseteq> tgqs: globular_2_semiring  "cod\<^sub>0" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "(\<cdot>\<^sub>0)" "1\<^sub>0" "dom\<^sub>0"  "cod\<^sub>1" "(\<cdot>\<^sub>1)" "1\<^sub>1" "dom\<^sub>1"
  by (unfold_locales, simp_all add: local.mq0mq.mqs.msrdual.cd_compat local.mq0mq.mqs.msrdual.dc_compat local.dc_compat local.cd_compat local.interchange local.c0_weak_hom local.c1_hom local.d0_weak_hom local.d1_hom)

sublocale globular_2_quantale \<subseteq> tgqs: globular_2_kleene_algebra "cod\<^sub>0" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "(\<cdot>\<^sub>0)" "1\<^sub>0" "dom\<^sub>0" "cod\<^sub>1" "(\<cdot>\<^sub>1)" "1\<^sub>1" "dom\<^sub>1" qstar0 qstar1..

lemma (in globular_2_quantale) id0_le_id1: "1\<^sub>0 = 1\<^sub>1"
  nitpick (* 3-element counterexample *)
  oops

lemma (in globular_2_quantale) qstar0_aux: "mm0.power (x \<cdot>\<^sub>1 y) i \<le> mm0.power x i \<cdot>\<^sub>1 mm0.power y i"
proof (induct i)
  case 0
  then show ?case by simp
next
  case (Suc i)
  fix i
  assume h: "mm0.power (x \<cdot>\<^sub>1 y) i \<le> mm0.power x i \<cdot>\<^sub>1 mm0.power y i"
  have "mm0.power (x \<cdot>\<^sub>1 y) (Suc i) = (x \<cdot>\<^sub>1 y) \<cdot>\<^sub>0 mm0.power (x \<cdot>\<^sub>1 y) i"
    by simp
  also have "\<dots> \<le> (x \<cdot>\<^sub>1 y) \<cdot>\<^sub>0 (mm0.power x i \<cdot>\<^sub>1 mm0.power y i)"
    by (simp add: h q0q.qdual.qd.mult_isor)
  also have "\<dots> \<le> (x \<cdot>\<^sub>0 mm0.power x i) \<cdot>\<^sub>1 (y \<cdot>\<^sub>0 mm0.power y i)"
    by (simp add: local.interchange)
  also have "\<dots> = mm0.power x (Suc i) \<cdot>\<^sub>1 mm0.power y (Suc i)"
    by simp
  finally show "mm0.power (x \<cdot>\<^sub>1 y) (Suc i) \<le> mm0.power x (Suc i) \<cdot>\<^sub>1 mm0.power y (Suc i)".
qed

lemma (in globular_2_quantale) qstar0_oplax: "qstar0 (x \<cdot>\<^sub>1 y) \<le> qstar0 x \<cdot>\<^sub>1 qstar0 y"
proof-
  have "\<forall>i. mm0.power (x \<cdot>\<^sub>1 y) i \<le> mm0.power x i \<cdot>\<^sub>1 mm0.power y i"
    by (simp add: local.qstar0_aux)
  hence "\<forall>i. mm0.power (x \<cdot>\<^sub>1 y) i \<le> qstar0 x \<cdot>\<^sub>1 qstar0 y"
    by (smt (verit) local.order.trans local.qstar0_def q0q.qk.star_power q1q.qdual.qd.mult_iso)
  hence "\<Squnion>{mm0.power (x \<cdot>\<^sub>1 y) i |i. True} \<le> qstar0 x \<cdot>\<^sub>1 qstar0 y"
    by (smt (verit, ccfv_SIG) local.Sup_least mem_Collect_eq)
  thus ?thesis
    using local.qstar0_unfold by fastforce
qed

lemma (in globular_2_quantale) qstar1_distl0: "x \<cdot>\<^sub>0 (qstar1 y) = \<Squnion>{(x \<cdot>\<^sub>0 mm1.power y i)|i. i \<ge> 0}"
  apply (rule order.antisym)
  unfolding qstar1_def q1q.qstar_def
  apply (smt (verit) local.SUP_least local.Sup_upper mem_Collect_eq q0q.Sup_distl)
  by (smt (verit) local.SUP_upper local.Sup_least mem_Collect_eq q0q.Sup_distl)

lemma (in globular_2_quantale) qstar1_distr0: "(qstar1 x) \<cdot>\<^sub>0 y = \<Squnion>{mm1.power x i \<cdot>\<^sub>0 y|i. i \<ge> 0}"
  apply (rule order.antisym)
  unfolding qstar1_def q1q.qstar_def
  apply (smt (verit) local.SUP_least local.Sup_upper mem_Collect_eq q0q.Sup_distr)
  by (smt (verit) local.Sup_least local.Sup_upper mem_Collect_eq q0q.qdual.qd.mult_isol)

lemma (in globular_2_quantale) qstar0_distl1: "x \<cdot>\<^sub>1 (qstar0 y) = \<Squnion>{(x \<cdot>\<^sub>1 mm0.power y i)|i. i \<ge> 0}"
  apply (rule order.antisym)
  unfolding qstar0_def q0q.qstar_def
  apply (smt (verit) local.SUP_least local.Sup_upper mem_Collect_eq q1q.Sup_distl)
  by (smt (verit) local.SUP_upper local.Sup_least mem_Collect_eq q1q.Sup_distl)

lemma (in globular_2_quantale) qstar0_distr1: "(qstar0 x) \<cdot>\<^sub>1 y = \<Squnion>{mm0.power x i \<cdot>\<^sub>1 y|i. i \<ge> 0}"
  apply (rule order.antisym)
  unfolding qstar0_def q0q.qstar_def
   apply (smt (verit) local.SUP_least local.Sup_upper mem_Collect_eq q1q.Sup_distr)
  by (smt (verit, del_insts) local.Sup_le_iff local.order_refl mem_Collect_eq q1q.qdual.qd.mult_isol)

lemma (in globular_2_quantale) star1_laxl_aux: "dom\<^sub>1 x \<cdot>\<^sub>0 mm1.power y i \<le> mm1.power (dom\<^sub>1 x \<cdot>\<^sub>0 y) i"
proof (induct i)
  case 0
  have "dom\<^sub>1 x \<cdot>\<^sub>0 1\<^sub>1 \<le> 1\<^sub>1 \<cdot>\<^sub>0 1\<^sub>1"
    using local.dom1_subid q0q.qdual.qd.mult_isol by blast
  thus "dom\<^sub>1 x \<cdot>\<^sub>0 mm1.power y 0 \<le> mm1.power (dom\<^sub>1 x \<cdot>\<^sub>0 y) 0"
    by simp
next
  case (Suc i)
  fix i
  assume h: "dom\<^sub>1 x \<cdot>\<^sub>0 mm1.power y i \<le> mm1.power (dom\<^sub>1 x \<cdot>\<^sub>0 y) i"
  have "dom\<^sub>1 x \<cdot>\<^sub>0 mm1.power y (Suc i) = dom\<^sub>1 x \<cdot>\<^sub>0 (y \<cdot>\<^sub>1  mm1.power y i)"
    by simp
  also have "\<dots> = (dom\<^sub>1 x \<cdot>\<^sub>1 dom\<^sub>1 x) \<cdot>\<^sub>0 (y \<cdot>\<^sub>1 mm1.power y i)"
    by simp
  also have "\<dots>  \<le> (dom\<^sub>1 x \<cdot>\<^sub>0 y) \<cdot>\<^sub>1 (dom\<^sub>1 x \<cdot>\<^sub>0 mm1.power y i)"
    using local.interchange by blast
  also have "\<dots>  \<le> (dom\<^sub>1 x \<cdot>\<^sub>0 y) \<cdot>\<^sub>1 mm1.power (dom\<^sub>1 x \<cdot>\<^sub>0 y) i"
    by (simp add: h q1q.qdual.qd.mult_isor)
  finally show "dom\<^sub>1 x \<cdot>\<^sub>0 mm1.power y (Suc i) \<le> mm1.power (dom\<^sub>1 x \<cdot>\<^sub>0 y) (Suc i)"
    by simp
qed

lemma (in globular_2_quantale) star1_laxl: "dom\<^sub>1 x \<cdot>\<^sub>0 qstar1 y \<le> qstar1 (dom\<^sub>1 x \<cdot>\<^sub>0 y)"
proof-
  have "dom\<^sub>1 x \<cdot>\<^sub>0 qstar1 y = \<Squnion>{dom\<^sub>1 x \<cdot>\<^sub>0 mm1.power y i |i. i \<ge> 0}"
    using local.qstar1_distl0 by auto
  also have "\<dots> \<le> \<Squnion>{mm1.power (dom\<^sub>1 x \<cdot>\<^sub>0 y) i |i. i \<ge> 0}"
    apply (rule Sup_least Sup_upper)
    by (simp, metis (mono_tags, lifting) local.Sup_upper2 local.star1_laxl_aux mem_Collect_eq)
  finally show ?thesis
    by (simp add: local.qstar1_unfold)
qed

lemma (in globular_2_quantale) star1_laxl_aux_var: "dom\<^sub>0 x \<cdot>\<^sub>0 mm1.power y i \<le> mm1.power (dom\<^sub>0 x \<cdot>\<^sub>0 y) i"
proof (induct i)
  case 0
  have "dom\<^sub>0 x \<cdot>\<^sub>0 1\<^sub>1 = dom\<^sub>1 (dom\<^sub>0 x) \<cdot>\<^sub>0 1\<^sub>1"
    by simp
  also have "\<dots> \<le> 1\<^sub>1 \<cdot>\<^sub>0 1\<^sub>1"
    using local.dom1_subid q0q.qdual.qd.mult_isol by blast
  finally have "dom\<^sub>0 x \<cdot>\<^sub>0 1\<^sub>1 \<le> 1\<^sub>1"
    by simp
  thus "dom\<^sub>0 x \<cdot>\<^sub>0 mm1.power y 0 \<le> mm1.power (dom\<^sub>0 x \<cdot>\<^sub>0 y) 0"
    by simp
next
  case (Suc i)
  fix i
  assume h: "dom\<^sub>0 x \<cdot>\<^sub>0 mm1.power y i \<le> mm1.power (dom\<^sub>0 x \<cdot>\<^sub>0 y) i"
  have "dom\<^sub>0 x \<cdot>\<^sub>0 mm1.power y (Suc i) = dom\<^sub>0 x \<cdot>\<^sub>0 (y \<cdot>\<^sub>1  mm1.power y i)"
    by simp
  also have "\<dots> = (dom\<^sub>0 x \<cdot>\<^sub>1 dom\<^sub>0 x) \<cdot>\<^sub>0 (y \<cdot>\<^sub>1 mm1.power y i)"
    by simp
  also have "\<dots>  \<le> (dom\<^sub>0 x \<cdot>\<^sub>0 y) \<cdot>\<^sub>1 (dom\<^sub>0 x \<cdot>\<^sub>0 mm1.power y i)"
    using local.interchange by blast
  also have "\<dots>  \<le> (dom\<^sub>0 x \<cdot>\<^sub>0 y) \<cdot>\<^sub>1 mm1.power (dom\<^sub>0 x \<cdot>\<^sub>0 y) i"
    by (simp add: h q1q.qdual.qd.mult_isor)
  finally show "dom\<^sub>0 x \<cdot>\<^sub>0 mm1.power y (Suc i) \<le> mm1.power (dom\<^sub>0 x \<cdot>\<^sub>0 y) (Suc i)"
    by simp
qed

lemma (in globular_2_quantale) star1_laxl_var: "dom\<^sub>0 x \<cdot>\<^sub>0 qstar1 y \<le> qstar1 (dom\<^sub>0 x \<cdot>\<^sub>0 y)"
proof-
  have "dom\<^sub>0 x \<cdot>\<^sub>0 qstar1 y = \<Squnion>{dom\<^sub>0 x \<cdot>\<^sub>0 mm1.power y i |i. i \<ge> 0}"
    using local.qstar1_distl0 by auto
  also have "\<dots> \<le> \<Squnion>{mm1.power (dom\<^sub>0 x \<cdot>\<^sub>0 y) i |i. i \<ge> 0}"
    apply (rule Sup_least Sup_upper)
    by (simp, metis (mono_tags, lifting) local.Sup_upper2 local.star1_laxl_aux_var mem_Collect_eq)
  finally show ?thesis
    by (simp add: local.qstar1_unfold)
qed

lemma (in globular_2_quantale) star1_laxr_aux: "mm1.power x i \<cdot>\<^sub>0 cod\<^sub>1 y \<le> mm1.power (x \<cdot>\<^sub>0 cod\<^sub>1 y) i"
  apply (induct i)
   apply (metis local.cod1_subid local.mm1.power.power_0 local.tgqs.tgsdual.id1_comp0_eq q0q.qdual.qd.mult_isor)
  by (smt (verit, best) local.dual_order.trans local.mm1.power.power_Suc local.tgqs.tgsdual.d1_comp1 q1q.qdual.qd.mult_isor)

lemma (in globular_2_quantale) qstar1_laxr: "qstar1 x \<cdot>\<^sub>0 cod\<^sub>1 y \<le> qstar1 (x \<cdot>\<^sub>0 cod\<^sub>1 y)"
proof-
  have "qstar1 x \<cdot>\<^sub>0 cod\<^sub>1 y = \<Squnion>{mm1.power x i \<cdot>\<^sub>0 cod\<^sub>1 y |i. i \<ge> 0}"
    using local.qstar1_distr0 by auto
  also have "\<dots> \<le> \<Squnion>{mm1.power (x \<cdot>\<^sub>0 cod\<^sub>1 y) i |i. i \<ge> 0}"
    apply (rule Sup_least Sup_upper)
    by (simp, metis (mono_tags, lifting) local.Sup_upper2 local.star1_laxr_aux mem_Collect_eq)
  finally show ?thesis
    by (simp add: local.qstar1_unfold)
qed

lemma (in globular_2_quantale) star1_laxr_aux_var: "mm1.power x i \<cdot>\<^sub>0 cod\<^sub>0 y \<le> mm1.power (x \<cdot>\<^sub>0 cod\<^sub>0 y) i"
proof (induct i)
  case 0 show ?case
    by (metis local.cod1_subid local.mm1.power.power_0 local.tgqs.tgsdual.d1d0 local.tgqs.tgsdual.id1_comp0_eq q0q.qdual.qd.mult_isor)
next
  case (Suc i)
  fix i
  assume h: "mm1.power x i \<cdot>\<^sub>0 cod\<^sub>0 y \<le> mm1.power (x \<cdot>\<^sub>0 cod\<^sub>0 y) i"
  have "mm1.power x (Suc i) \<cdot>\<^sub>0 cod\<^sub>0 y = (x \<cdot>\<^sub>1 mm1.power x i ) \<cdot>\<^sub>0 (cod\<^sub>0 y \<cdot>\<^sub>1 cod\<^sub>0 y)"
    by simp
  also have "\<dots>  \<le> (x \<cdot>\<^sub>0 cod\<^sub>0 y) \<cdot>\<^sub>1 (mm1.power x i \<cdot>\<^sub>0 cod\<^sub>0 y)"
    by (simp add: local.tgqs.tgsdual.d0_comp1)
  finally show "mm1.power x (Suc i) \<cdot>\<^sub>0 cod\<^sub>0 y \<le> mm1.power (x \<cdot>\<^sub>0 cod\<^sub>0 y) (Suc i)"
    by (simp add: h local.order_trans q1q.qdual.qd.mult_isor)
qed

lemma (in globular_2_quantale) qstar1_laxr_var: "qstar1 x \<cdot>\<^sub>0 cod\<^sub>0 y \<le> qstar1 (x \<cdot>\<^sub>0 cod\<^sub>0 y)"
proof-
  have "qstar1 x \<cdot>\<^sub>0 cod\<^sub>0 y = \<Squnion>{mm1.power x i \<cdot>\<^sub>0 cod\<^sub>0 y |i. i \<ge> 0}"
    using local.qstar1_distr0 by auto
  also have "\<dots> \<le> \<Squnion>{mm1.power (x \<cdot>\<^sub>0 cod\<^sub>0 y) i |i. i \<ge> 0}"
    apply (rule Sup_least Sup_upper)
    by (simp, metis (mono_tags, lifting) local.Sup_upper2 local.star1_laxr_aux_var mem_Collect_eq)
  finally show ?thesis
    by (simp add: local.qstar1_unfold)
qed

lemma (in globular_2_quantale) qstar1_aux: "mm1.power x i \<cdot>\<^sub>0 mm1.power y i \<le> mm1.power (x \<cdot>\<^sub>0 y) i"
proof (induct i)
  case 0
  then show ?case by simp
next
  case (Suc i)
 fix i
  assume h: "mm1.power x i \<cdot>\<^sub>0 mm1.power y i \<le> mm1.power (x \<cdot>\<^sub>0 y) i"
  have "mm1.power x (Suc i) \<cdot>\<^sub>0 mm1.power y (Suc i) = (x \<cdot>\<^sub>1 mm1.power x i) \<cdot>\<^sub>0 (y \<cdot>\<^sub>1 mm1.power y i)"
    by simp
  also have "\<dots> \<le> (x \<cdot>\<^sub>0 y) \<cdot>\<^sub>1 (mm1.power x i \<cdot>\<^sub>0 mm1.power y i)"
    using local.interchange by force
  also have "\<dots> \<le> (x \<cdot>\<^sub>0 y) \<cdot>\<^sub>1 mm1.power (x \<cdot>\<^sub>0 y) i"
    using h q1q.qdual.qd.mult_isor by blast
  also have "\<dots> = mm1.power (x \<cdot>\<^sub>0 y) (Suc i)"
    by simp
  finally show "mm1.power x (Suc i) \<cdot>\<^sub>0 mm1.power y (Suc i) \<le> mm1.power (x \<cdot>\<^sub>0 y) (Suc i)".
qed

lemma (in globular_2_quantale) "qstar1 x \<cdot>\<^sub>0 qstar1 y = \<Squnion>{mm1.power x i \<cdot>\<^sub>0 mm1.power y j |i j. i \<ge> 0 \<and> j \<ge> 0}"
proof-
  have "qstar1 x \<cdot>\<^sub>0 qstar1 y = \<Squnion>{mm1.power x i |i. i \<ge> 0} \<cdot>\<^sub>0 \<Squnion>{mm1.power y i |i. i \<ge> 0}"
    by (simp add: local.qstar1_def q1q.qstar_def)
  also have "\<dots> = \<Squnion>{mm1.power x i \<cdot>\<^sub>0 \<Squnion>{mm1.power y j |j. j \<ge> 0} |i. i \<ge> 0}"
    using local.qstar1_def local.qstar1_distr0 q1q.qstar_def by force
  also have "\<dots> = \<Squnion>{\<Squnion>{mm1.power x i \<cdot>\<^sub>0 mm1.power y j |j. j \<ge> 0} |i. i \<ge> 0}"
    using local.qstar1_def local.qstar1_distl0 q1q.qstar_def by auto
  also have "\<dots> = \<Squnion>{mm1.power x i \<cdot>\<^sub>0 mm1.power y j |i j. i \<ge> 0 \<and> j \<ge> 0}"
    apply (rule order.antisym)
     apply (rule Sup_least)
     apply simp
     apply (metis (no_types, lifting) local.Sup_least local.Sup_upper mem_Collect_eq)
    apply (rule Sup_least)
    apply safe
    by (metis calculation dq0ka1.k1.star_power q0q.qdual.qd.mult_iso)
  finally show ?thesis.
qed

lemma (in globular_2_quantale) "qstar1 x \<cdot>\<^sub>0 qstar1 y \<le> qstar0 (x \<cdot>\<^sub>1 y)"
  unfolding qstar1_def qstar0_def
  oops

lemma (in globular_2_quantale) "qstar1 x \<cdot>\<^sub>0 qstar1 y \<le> qstar1 (x \<cdot>\<^sub>1 y)"
  nitpick (* no proof, no counterexample *)
  oops

lemma (in globular_2_quantale) "qstar1 (x \<cdot>\<^sub>1 y) \<le> qstar1 x \<cdot>\<^sub>0 qstar1 y"
  nitpick (* no proof, no counterexample *)
  oops

lemma (in globular_2_quantale) "qstar1 x \<cdot>\<^sub>0 qstar1 y \<le> qstar1 (x \<cdot>\<^sub>0 y)"
  nitpick (* no proof, no counterexample *)
  oops

lemma (in globular_2_quantale) "qstar1 (x \<cdot>\<^sub>0 y) \<le> qstar1 x \<cdot>\<^sub>0 qstar1 y"
  nitpick (* no proof, no counterexample *)
  oops

lemma (in globular_2_quantale) "qstar0 x \<cdot>\<^sub>1 qstar0 y \<le> qstar0 (x \<cdot>\<^sub>0 y)"
  nitpick (* no proof, no counterexample *)
  oops

lemma (in globular_2_kleene_algebra) "qstar0 x \<cdot>\<^sub>1 qstar0 y \<le> qstar0 (x \<cdot>\<^sub>1 y)"
  nitpick (* no proof, no counterexample *)
  oops

lemma (in globular_2_kleene_algebra) "qstar0 (x \<cdot>\<^sub>1 y) \<le> qstar0 x \<cdot>\<^sub>1 qstar0 y"
  nitpick (* no proof, no counterexample *)
  oops

end


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

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun map :: "('a => 'b) => 'a list => 'b list" where
"map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

theorem property0 :
  "((elem y (map f xs)) ==>
      (? (x :: 'a) . (((f x) = y) & (elem y xs))))"
  oops

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun reverse :: "'a list => 'a list" where
  "reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun elem :: "'a => 'a list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge1sort2 :: "int list => int list"
  and nstoogesort :: "int list => int list"
  and nstooge1sort1 :: "int list => int list" where
  "nstooge1sort2 y =
   (case splitAt (third (length y)) (reverse y) of
      pair2 ys2 zs2 => x (nstoogesort zs2) (reverse ys2))"
| "nstoogesort (nil2) = nil2"
| "nstoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge1sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort zs1))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (nstoogesort xs) xs"
  oops

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun pairs :: "'t list => (('t, 't) pair) list" where
  "pairs (nil2) = nil2"
| "pairs (cons2 y (nil2)) = nil2"
| "pairs (cons2 y (cons2 y2 xs)) = cons2 (pair2 y y2) (pairs xs)"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

function evens :: "'a list => 'a list"
  and odds :: "'a list => 'a list" where
  "evens (nil2) = nil2"
| "evens (cons2 y xs) = cons2 y (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 y xs) = evens xs"
  by pat_completeness auto

theorem property0 :
  "((let eta :: int = length xs
     in ((let md :: int = eta mod 2
          in (if
                (((if (eta = 0) then 0 else (if eta <= 0 then 0 - 1 else 1)) =
                    (if 2 <= 0 then 0 - (0 - 1) else 0 - 1)) &
                   (md ~= 0))
                then
                md - 2
                else
                md)) =
           0)) ==>
      ((map
          (% (x :: ('a, 'a) pair) => (case x of pair2 y z => y))
          (pairs xs)) =
         (evens xs)))"
  oops

end


(*  Title:      HOL/Auth/Message.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Datatypes of agents and messages;
Inductive relations "parts", "analz" and "synth"
*)

section{*Theory of Agents and Messages for Security Protocols*}

theory Message
imports Main
begin

(*Needed occasionally with spy_analz_tac, e.g. in analz_insert_Key_newK*)
lemma [simp] : "A \<union> (B \<union> A) = B \<union> A"
by blast

type_synonym
  key = nat

consts
  all_symmetric :: bool        --{*true if all keys are symmetric*}
  invKey        :: "key=>key"  --{*inverse of a symmetric key*}

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric --> invKey = id"
    by (rule exI [of _ id], auto)

text{*The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa*}

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"

datatype  --{*We allow any number of friendly agents*}
  agent = Server | Friend nat | Spy

datatype
     msg = Agent  agent     --{*Agent names*}
         | Number nat       --{*Ordinary integers, timestamps, ...*}
         | Nonce  nat       --{*Unguessable nonces*}
         | Key    key       --{*Crypto keys*}
         | Hash   msg       --{*Hashing*}
         | MPair  msg msg   --{*Compound messages*}
         | Crypt  key msg   --{*Encryption, public- or shared-key*}

text{*Concrete syntax: messages appear as {|A,B,NA|}, etc...*}
syntax
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2{|_,/ _|})")

syntax (xsymbols)
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2\<lbrace>_,/ _\<rbrace>)")

translations
  "{|x, y, z|}"   == "{|x, {|y, z|}|}"
  "{|x, y|}"      == "CONST MPair x y"

definition HPair :: "[msg,msg] => msg" ("(4Hash[_] /_)" [0, 1000]) where
    --{*Message Y paired with a MAC computed with the help of X*}
    "Hash[X] Y == {| Hash{|X,Y|}, Y|}"

definition keysFor :: "msg set => key set" where
    --{*Keys useful to decrypt elements of a message set*}
  "keysFor H == invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsubsection{*Inductive Definition of All Parts" of a Message*}

inductive_set
  parts :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro]:               "X \<in> H ==> X \<in> parts H"
  | Fst:         "{|X,Y|}   \<in> parts H ==> X \<in> parts H"
  | Snd:         "{|X,Y|}   \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

text{*Monotonicity*}
lemma parts_mono: "G \<subseteq> H ==> parts(G) \<subseteq> parts(H)"
apply auto
apply (erule parts.induct)
apply (blast dest: parts.Fst parts.Snd parts.Body)+
done

text{*Equations hold because constructors are injective.*}
lemma Friend_image_eq [simp]: "(Friend x \<in> Friend`A) = (x:A)"
by auto

lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
by auto

lemma Nonce_Key_image_eq [simp]: "(Nonce x \<notin> Key`A)"
by auto

subsubsection{*Inverse of keys *}

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K=K')"
by (metis invKey)

subsection{*keysFor operator*}

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

text{*Monotonicity*}
lemma keysFor_mono: "G \<subseteq> H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert {|X,Y|} H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection{*Inductive relation "parts"*}

lemma MPair_parts:
     "[| {|X,Y|} \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!]  parts.Body [dest!]
text{*NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  @{text MPair_parts} is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.*}

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct, blast+)
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

text{*WARNING: loops if H = {Y}, therefore must not be repeated!*}
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
by (erule parts.induct, fast+)

subsubsection{*Unions *}

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
by (metis insert_is_Un parts_Un)

text{*TWO inserts to avoid looping.  This rewrite is better than nothing.
  But its behaviour can be strange.*}
lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
by (metis Un_commute Un_empty_right Un_insert_right insert_is_Un parts_Un)

lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)

lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_UN [simp]: "parts(\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts(H x))"
by (intro equalityI parts_UN_subset1 parts_UN_subset2)

text{*Added to simplify arguments to parts, analz and synth.
  NOTE: the UN versions are no longer used!*}

text{*This allows @{text blast} to simplify occurrences of
  @{term "parts(G\<union>H)"} in the assumption.*}
lemmas in_parts_UnE = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]
declare in_parts_UnE [elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection{*Idempotence and transitivity *}

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_subset_iff [simp]: "(parts G \<subseteq> parts H) = (G \<subseteq> parts H)"
by (metis parts_idem parts_increasing parts_mono subset_trans)

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (metis parts_subset_iff set_mp)

text{*Cut*}
lemma parts_cut:
     "[| Y\<in> parts (insert X G);  X\<in> parts H |] ==> Y\<in> parts (G \<union> H)"
by (blast intro: parts_trans)

lemma parts_cut_eq [simp]: "X\<in> parts H ==> parts (insert X H) = parts H"
by (metis insert_absorb parts_idem parts_insert)

subsubsection{*Rewrite rules for pulling out atomic messages *}

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Number [simp]:
     "parts (insert (Number N) H) = insert (Number N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Hash [simp]:
     "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) = insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Body)
done

lemma parts_insert_MPair [simp]:
     "parts (insert {|X,Y|} H) =
          insert {|X,Y|} (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
apply auto
apply (erule parts.induct, auto)
done

text{*In any message, there is an upper bound N on its greatest nonce.*}
lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n --> Nonce n \<notin> parts {msg}"
proof (induct msg)
  case (Nonce n)
    show ?case
      by simp (metis Suc_n_not_le_n)
next
  case (MPair X Y)
    then show ?case --{*metis works out the necessary sum itself!*}
      by (simp add: parts_insert2) (metis le_trans nat_le_linear)
qed auto

subsection{*Inductive relation "analz"*}

text{*Inductive definition of "analz" -- what can be broken down from a set of
    messages, including keys.  A form of downward closure.  Pairs can
    be taken apart; messages decrypted with known keys.  *}

inductive_set
  analz :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] :    "X \<in> H ==> X \<in> analz H"
  | Fst:     "{|X,Y|} \<in> analz H ==> X \<in> analz H"
  | Snd:     "{|X,Y|} \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "[|Crypt K X \<in> analz H; Key(invKey K): analz H|] ==> X \<in> analz H"

text{*Monotonicity; Lemma 1 of Lowe's paper*}
lemma analz_mono: "G\<subseteq>H ==> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd)
done

text{*Making it safe speeds up proofs*}
lemma MPair_analz [elim!]:
     "[| {|X,Y|} \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
by (metis analz_increasing analz_subset_parts equalityI parts_mono parts_subset_iff)

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection{*General equational properties *}

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

text{*Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other*}
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection{*Rewrite rules for pulling out atomic messages *}

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Number [simp]:
     "analz (insert (Number N) H) = insert (Number N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Hash [simp]:
     "analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

text{*Can only pull out Keys if they are not needed to decrypt the rest*}
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert {|X,Y|} H) =
          insert {|X,Y|} (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

text{*Can pull out enCrypted message if the Key is not known*}
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)

done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

text{*Case analysis: either the message is secure, or it is not! Effective,
but can cause subgoals to blow up! Use with @{text "split_if"}; apparently
@{text "split_tac"} does not cope with patterns such as @{term"analz (insert
(Crypt K X) H)"} *}
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

text{*This rule supposes "for the sake of argument" that we have the key.*}
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

subsubsection{*Idempotence and transitivity *}

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_subset_iff [simp]: "(analz G \<subseteq> analz H) = (G \<subseteq> analz H)"
by (metis analz_idem analz_increasing analz_mono subset_trans)

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

text{*Cut; Lemma 2 of Lowe*}
lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (erule analz_trans, blast)

(*Cut can be proved easily by induction on
   "Y: analz (insert X H) ==> X: analz H --> Y: analz H"
*)

text{*This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated. *}
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (metis analz_cut analz_insert_eq_I insert_absorb)

text{*A congruence rule for "analz" *}

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H' |]
      ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
by (metis Un_mono analz_Un analz_subset_iff subset_trans)

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H' |]
      ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

text{*If there are no pairs or encryptions then analz does nothing*}
lemma analz_trivial:
     "[| \<forall>X Y. {|X,Y|} \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

text{*These two are obsolete (with a single Spy) but cost little to prove...*}
lemma analz_UN_analz_lemma:
     "X\<in> analz (\<Union>i\<in>A. analz (H i)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
done

lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])

subsection{*Inductive relation "synth"*}

text{*Inductive definition of "synth" -- what can be built up from a set of
    messages.  A form of upward closure.  Pairs can be built, messages
    encrypted with known keys.  Agent names are public domain.
    Numbers can be guessed, but Nonces cannot be.  *}

inductive_set
  synth :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | Number [intro]:   "Number n  \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H ==> Hash X \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> {|X,Y|} \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

text{*Monotonicity*}
lemma synth_mono: "G\<subseteq>H ==> synth(G) \<subseteq> synth(H)"
  by (auto, erule synth.induct, auto)

text{*NO @{text Agent_synth}, as any Agent name can be synthesized.
  The same holds for @{term Number}*}

inductive_simps synth_simps [iff]:
 "Nonce n \<in> synth H"
 "Key K \<in> synth H"
 "Hash X \<in> synth H"
 "{|X,Y|} \<in> synth H"
 "Crypt K X \<in> synth H"

lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection{*Unions *}

text{*Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.*}
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])

subsubsection{*Idempotence and transitivity *}

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, auto)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_subset_iff [simp]: "(synth G \<subseteq> synth H) = (G \<subseteq> synth H)"
by (metis subset_trans synth_idem synth_increasing synth_mono)

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

text{*Cut; Lemma 2 of Lowe*}
lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (erule synth_trans, blast)

lemma Crypt_synth_eq [simp]:
     "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection{*Combinations of parts, analz and synth *}

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD]
                    parts.Fst parts.Snd parts.Body)+
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
prefer 5 apply (blast intro: analz_mono [THEN [2] rev_subsetD])
apply (blast intro: analz.Fst analz.Snd analz.Decrypt)+
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
by (metis Un_empty_right analz_synth_Un)

subsubsection{*For reasoning about the Fake rule in traces *}

lemma parts_insert_subset_Un: "X\<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (metis UnCI Un_upper2 insert_subset parts_Un parts_mono)

text{*More specifically for Fake. See also @{text Fake_parts_sing} below *}
lemma Fake_parts_insert:
     "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
by (metis Un_commute analz_increasing insert_subset parts_analz parts_mono
          parts_synth synth_mono synth_subset_iff)

lemma Fake_parts_insert_in_Un:
     "[|Z \<in> parts (insert X H);  X: synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (metis Fake_parts_insert set_mp)

text{*@{term H} is sometimes @{term"Key ` KK \<union> spies evs"}, so can't put
  @{term "G=H"}.*}
lemma Fake_analz_insert:
     "X\<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H)", force)
apply (blast intro: analz_mono [THEN [2] rev_subsetD] analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
done

lemma analz_conj_parts [simp]:
     "(X \<in> analz H & X \<in> parts H) = (X \<in> analz H)"
by (blast intro: analz_subset_parts [THEN subsetD])

lemma analz_disj_parts [simp]:
     "(X \<in> analz H | X \<in> parts H) = (X \<in> parts H)"
by (blast intro: analz_subset_parts [THEN subsetD])

text{*Without this equation, other rules for synth and analz would yield
  redundant cases*}
lemma MPair_synth_analz [iff]:
     "({|X,Y|} \<in> synth (analz H)) =
      (X \<in> synth (analz H) & Y \<in> synth (analz H))"
by blast

lemma Crypt_synth_analz:
     "[| Key K \<in> analz H;  Key (invKey K) \<in> analz H |]
       ==> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast

lemma Hash_synth_analz [simp]:
     "X \<notin> synth (analz H)
      ==> (Hash{|X,Y|} \<in> synth (analz H)) = (Hash{|X,Y|} \<in> analz H)"
by blast

subsection{*HPair: a combination of Hash and MPair*}

subsubsection{*Freeness *}

lemma Agent_neq_HPair: "Agent A ~= Hash[X] Y"
  unfolding HPair_def by simp

lemma Nonce_neq_HPair: "Nonce N ~= Hash[X] Y"
  unfolding HPair_def by simp

lemma Number_neq_HPair: "Number N ~= Hash[X] Y"
  unfolding HPair_def by simp

lemma Key_neq_HPair: "Key K ~= Hash[X] Y"
  unfolding HPair_def by simp

lemma Hash_neq_HPair: "Hash Z ~= Hash[X] Y"
  unfolding HPair_def by simp

lemma Crypt_neq_HPair: "Crypt K X' ~= Hash[X] Y"
  unfolding HPair_def by simp

lemmas HPair_neqs = Agent_neq_HPair Nonce_neq_HPair Number_neq_HPair
                    Key_neq_HPair Hash_neq_HPair Crypt_neq_HPair

declare HPair_neqs [iff]
declare HPair_neqs [symmetric, iff]

lemma HPair_eq [iff]: "(Hash[X'] Y' = Hash[X] Y) = (X' = X & Y'=Y)"
by (simp add: HPair_def)

lemma MPair_eq_HPair [iff]:
     "({|X',Y'|} = Hash[X] Y) = (X' = Hash{|X,Y|} & Y'=Y)"
by (simp add: HPair_def)

lemma HPair_eq_MPair [iff]:
     "(Hash[X] Y = {|X',Y'|}) = (X' = Hash{|X,Y|} & Y'=Y)"
by (auto simp add: HPair_def)

subsubsection{*Specialized laws, proved in terms of those for Hash and MPair *}

lemma keysFor_insert_HPair [simp]: "keysFor (insert (Hash[X] Y) H) = keysFor H"
by (simp add: HPair_def)

lemma parts_insert_HPair [simp]:
    "parts (insert (Hash[X] Y) H) =
     insert (Hash[X] Y) (insert (Hash{|X,Y|}) (parts (insert Y H)))"
by (simp add: HPair_def)

lemma analz_insert_HPair [simp]:
    "analz (insert (Hash[X] Y) H) =
     insert (Hash[X] Y) (insert (Hash{|X,Y|}) (analz (insert Y H)))"
by (simp add: HPair_def)

lemma HPair_synth_analz [simp]:
     "X \<notin> synth (analz H)
    ==> (Hash[X] Y \<in> synth (analz H)) =
        (Hash {|X, Y|} \<in> analz H & Y \<in> synth (analz H))"
by (auto simp add: HPair_def)

text{*We do NOT want Crypt... messages broken up in protocols!!*}
declare parts.Body [rule del]

text{*Rewrites to push in Key and Crypt messages, so that other messages can
    be pulled out using the @{text analz_insert} rules*}

lemmas pushKeys =
  insert_commute [of "Key K" "Agent C"]
  insert_commute [of "Key K" "Nonce N"]
  insert_commute [of "Key K" "Number N"]
  insert_commute [of "Key K" "Hash X"]
  insert_commute [of "Key K" "MPair X Y"]
  insert_commute [of "Key K" "Crypt X K'"]
  for K C N X Y K'

lemmas pushCrypts =
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Nonce N"]
  insert_commute [of "Crypt X K" "Number N"]
  insert_commute [of "Crypt X K" "Hash X'"]
  insert_commute [of "Crypt X K" "MPair X' Y"]
  for X K C N X' Y

text{*Cannot be added with @{text "[simp]"} -- messages should not always be
  re-ordered. *}
lemmas pushes = pushKeys pushCrypts

subsection{*The set of key-free messages*}

(*Note that even the encryption of a key-free message remains key-free.
  This concept is valuable because of the theorem analz_keyfree_into_Un, proved below. *)

inductive_set
  keyfree :: "msg set"
  where
    Agent:  "Agent A \<in> keyfree"
  | Number: "Number N \<in> keyfree"
  | Nonce:  "Nonce N \<in> keyfree"
  | Hash:   "Hash X \<in> keyfree"
  | MPair:  "[|X \<in> keyfree;  Y \<in> keyfree|] ==> {|X,Y|} \<in> keyfree"
  | Crypt:  "[|X \<in> keyfree|] ==> Crypt K X \<in> keyfree"

declare keyfree.intros [intro]

inductive_cases keyfree_KeyE: "Key K \<in> keyfree"
inductive_cases keyfree_MPairE: "{|X,Y|} \<in> keyfree"
inductive_cases keyfree_CryptE: "Crypt K X \<in> keyfree"

lemma parts_keyfree: "parts (keyfree) \<subseteq> keyfree"
  by (clarify, erule parts.induct, auto elim!: keyfree_KeyE keyfree_MPairE keyfree_CryptE)

(*The key-free part of a set of messages can be removed from the scope of the analz operator.*)
lemma analz_keyfree_into_Un: "\<lbrakk>X \<in> analz (G \<union> H); G \<subseteq> keyfree\<rbrakk> \<Longrightarrow> X \<in> parts G \<union> analz H"
apply (erule analz.induct, auto dest: parts.Body)
apply (metis Un_absorb2 keyfree_KeyE parts_Un parts_keyfree UnI2)
done

subsection{*Tactics useful for many protocol proofs*}
ML
{*
(*Analysis of Fake cases.  Also works for messages that forward unknown parts,
  but this application is no longer necessary if analz_insert_eq is used.
  DEPENDS UPON "X" REFERRING TO THE FRADULENT MESSAGE *)

fun impOfSubs th = th RSN (2, @{thm rev_subsetD})

(*Apply rules to break down assumptions of the form
  Y \<in> parts(insert X H)  and  Y \<in> analz(insert X H)
*)
val Fake_insert_tac =
    dresolve_tac [impOfSubs @{thm Fake_analz_insert},
                  impOfSubs @{thm Fake_parts_insert}] THEN'
    eresolve_tac [asm_rl, @{thm synth.Inj}];

fun Fake_insert_simp_tac ctxt i =
  REPEAT (Fake_insert_tac i) THEN asm_full_simp_tac ctxt i;

fun atomic_spy_analz_tac ctxt =
  SELECT_GOAL
   (Fake_insert_simp_tac ctxt 1 THEN
    IF_UNSOLVED
      (Blast.depth_tac
        (ctxt addIs [@{thm analz_insertI}, impOfSubs @{thm analz_subset_parts}]) 4 1));

fun spy_analz_tac ctxt i =
  DETERM
   (SELECT_GOAL
     (EVERY
      [  (*push in occurrences of X...*)
       (REPEAT o CHANGED)
           (res_inst_tac ctxt [(("x", 1), "X")] (insert_commute RS ssubst) 1),
       (*...allowing further simplifications*)
       simp_tac ctxt 1,
       REPEAT (FIRSTGOAL (resolve_tac [allI,impI,notI,conjI,iffI])),
       DEPTH_SOLVE (atomic_spy_analz_tac ctxt 1)]) i);
*}

text{*By default only @{text o_apply} is built-in.  But in the presence of
eta-expansion this means that some terms displayed as @{term "f o g"} will be
rewritten, and others will not!*}
declare o_def [simp]

lemma Crypt_notin_image_Key [simp]: "Crypt K X \<notin> Key ` A"
by auto

lemma Hash_notin_image_Key [simp] :"Hash X \<notin> Key ` A"
by auto

lemma synth_analz_mono: "G\<subseteq>H ==> synth (analz(G)) \<subseteq> synth (analz(H))"
by (iprover intro: synth_mono analz_mono)

lemma Fake_analz_eq [simp]:
     "X \<in> synth(analz H) ==> synth (analz (insert X H)) = synth (analz H)"
by (metis Fake_analz_insert Un_absorb Un_absorb1 Un_commute
          subset_insertI synth_analz_mono synth_increasing synth_subset_iff)

text{*Two generalizations of @{text analz_insert_eq}*}
lemma gen_analz_insert_eq [rule_format]:
     "X \<in> analz H ==> ALL G. H \<subseteq> G --> analz (insert X G) = analz G"
by (blast intro: analz_cut analz_insertI analz_mono [THEN [2] rev_subsetD])

lemma synth_analz_insert_eq [rule_format]:
     "X \<in> synth (analz H)
      ==> ALL G. H \<subseteq> G --> (Key K \<in> analz (insert X G)) = (Key K \<in> analz G)"
apply (erule synth.induct)
apply (simp_all add: gen_analz_insert_eq subset_trans [OF _ subset_insertI])
done

lemma Fake_parts_sing:
     "X \<in> synth (analz H) ==> parts{X} \<subseteq> synth (analz H) \<union> parts H"
by (metis Fake_parts_insert empty_subsetI insert_mono parts_mono subset_trans)

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

method_setup spy_analz = {*
    Scan.succeed (SIMPLE_METHOD' o spy_analz_tac) *}
    "for proving the Fake case when analz is involved"

method_setup atomic_spy_analz = {*
    Scan.succeed (SIMPLE_METHOD' o atomic_spy_analz_tac) *}
    "for debugging spy_analz"

method_setup Fake_insert_simp = {*
    Scan.succeed (SIMPLE_METHOD' o Fake_insert_simp_tac) *}
    "for debugging spy_analz"

end