subsection\<open>Application to Cohen posets\label{sec:cohen}\<close>

theory Cohen_Posets
  imports
    Delta_System

begin

text\<open>We end this session by applying DSL to the combinatorics of
finite function posets. We first define some basic concepts; we take
a different approach from \<^cite>\<open>"2020arXiv200109715G"\<close>, in that the
order relation is presented as a predicate (of type @{typ \<open>[i,i] \<Rightarrow> o\<close>}).

Two elements of a poset are \<^emph>\<open>compatible\<close> if they have a common lower
bound.\<close>

definition compat_in :: "[i,[i,i]\<Rightarrow>o,i,i]\<Rightarrow>o" where
  "compat_in(A,r,p,q) \<equiv> \<exists>d\<in>A . r(d,p) \<and> r(d,q)"

text\<open>An \<^emph>\<open>antichain\<close> is a subset of pairwise incompatible members.\<close>

definition
  antichain :: "[i,[i,i]\<Rightarrow>o,i]\<Rightarrow>o" where
  "antichain(P,leq,A) \<equiv> A\<subseteq>P \<and> (\<forall>p\<in>A. \<forall>q\<in>A.
                p\<noteq>q \<longrightarrow> \<not>compat_in(P,leq,p,q))"

text\<open>A poset has the  \<^emph>\<open>countable chain condition\<close> (ccc) if all of its
antichains are countable.\<close>

definition
  ccc :: "[i,[i,i]\<Rightarrow>o]\<Rightarrow>o" where
  "ccc(P,leq) \<equiv> \<forall>A. antichain(P,leq,A) \<longrightarrow> countable(A)"

text\<open>Finally, the \<^emph>\<open>Cohen poset\<close> is the set of finite partial functions
between two sets with the order of reverse inclusion.\<close>

definition
  Fn :: "[i,i] \<Rightarrow> i" where
  "Fn(I,J) \<equiv> \<Union>{(d\<rightarrow>J) . d \<in> {x \<in> Pow(I).  Finite(x)}}"

abbreviation
  Supset :: "i \<Rightarrow> i \<Rightarrow> o" (infixl \<open>\<supseteq>\<close> 50) where
  "f \<supseteq> g \<equiv> g \<subseteq> f"

lemma FnI[intro]:
  assumes "p : d \<rightarrow> J" "d \<subseteq> I" "Finite(d)"
  shows "p \<in> Fn(I,J)"
  using assms unfolding Fn_def by auto

lemma FnD[dest]:
  assumes "p \<in> Fn(I,J)"
  shows "\<exists>d. p : d \<rightarrow> J \<and> d \<subseteq> I \<and> Finite(d)"
  using assms unfolding Fn_def by auto

lemma Fn_is_function: "p \<in> Fn(I,J) \<Longrightarrow> function(p)"
  unfolding Fn_def using fun_is_function by auto

lemma restrict_eq_imp_compat:
  assumes "f \<in> Fn(I, J)" "g \<in> Fn(I, J)"
    "restrict(f, domain(f) \<inter> domain(g)) = restrict(g, domain(f) \<inter> domain(g))"
  shows "f \<union> g \<in> Fn(I, J)"
proof -
  from assms
  obtain d1 d2 where "f : d1 \<rightarrow> J" "d1 \<in> Pow(I)" "Finite(d1)"
    "g : d2 \<rightarrow> J" "d2 \<in> Pow(I)" "Finite(d2)"
    by blast
  with assms
  show ?thesis
    using domain_of_fun
      restrict_eq_imp_Un_into_Pi[of f d1 "\<lambda>_. J" g d2 "\<lambda>_. J"]
    by auto
qed

text\<open>We finally arrive to our application of DSL.\<close>

lemma ccc_Fn_2: "ccc(Fn(I,2), (\<supseteq>))"
proof -
  {
    fix A
    assume "\<not> countable(A)"
    assume "A \<subseteq> Fn(I, 2)"
    moreover from this
    have "countable({p\<in>A. domain(p) = d})" for d
    proof (cases "Finite(d) \<and> d \<subseteq> I")
      case True
      with \<open>A \<subseteq> Fn(I, 2)\<close>
      have "{p \<in> A . domain(p) = d} \<subseteq> d \<rightarrow> 2"
        using domain_of_fun by fastforce
      moreover from True
      have "Finite(d \<rightarrow> 2)"
        using Finite_Pi lesspoll_nat_is_Finite by auto
      ultimately
      show ?thesis using subset_Finite[of _ "d\<rightarrow>2" ] Finite_imp_countable
        by auto
    next
      case False
      with \<open>A \<subseteq> Fn(I, 2)\<close>
      have "{p \<in> A . domain(p) = d} = 0"
        by (intro equalityI) (auto dest!: domain_of_fun)
      then
      show ?thesis using empty_lepollI by auto
    qed
    moreover
    have "uncountable({domain(p) . p \<in> A})"
    proof
      from \<open>A \<subseteq> Fn(I, 2)\<close>
      have "A = (\<Union>d\<in>{domain(p) . p \<in> A}. {p\<in>A. domain(p) = d})"
        by auto
      moreover
      assume "countable({domain(p) . p \<in> A})"
      moreover
      note \<open>\<And>d. countable({p\<in>A. domain(p) = d})\<close> \<open>\<not>countable(A)\<close>
      ultimately
      show "False"
        using countable_imp_countable_UN[of "{domain(p). p\<in>A}"
            "\<lambda>d. {p \<in> A. domain(p) = d }"]
        by auto
    qed
    moreover from \<open>A \<subseteq> Fn(I, 2)\<close>
    have "p \<in> A \<Longrightarrow> Finite(domain(p))" for p
      using lesspoll_nat_is_Finite[of "domain(p)"]
        domain_of_fun[of p _ "\<lambda>_. 2"] by auto
    ultimately
    obtain D where "delta_system(D)" "D \<subseteq> {domain(p) . p \<in> A}" "D \<approx> \<aleph>\<^bsub>1\<^esub>"
      using delta_system_uncountable[of "{domain(p) . p \<in> A}"] by auto
    then
    have delta:"\<forall>d1\<in>D. \<forall>d2\<in>D. d1 \<noteq> d2 \<longrightarrow> d1 \<inter> d2 = \<Inter>D"
      using delta_system_root_eq_Inter
      by simp
    moreover from \<open>D \<approx> \<aleph>\<^bsub>1\<^esub>\<close>
    have "uncountable(D)"
      using uncountable_iff_subset_eqpoll_Aleph1 by auto
    moreover from this and \<open>D \<subseteq> {domain(p) . p \<in> A}\<close>
    obtain p1 where "p1 \<in> A" "domain(p1) \<in> D"
      using uncountable_not_empty[of D] by blast
    moreover from this and \<open>p1 \<in> A \<Longrightarrow> Finite(domain(p1))\<close>
    have "Finite(domain(p1))" using Finite_domain by simp
    moreover
    define r where "r \<equiv> \<Inter>D"
    ultimately
    have "Finite(r)" using subset_Finite[of "r" "domain(p1)"] by auto
    have "countable({restrict(p,r) . p\<in>A})"
    proof -
      have "f \<in> Fn(I, 2) \<Longrightarrow> restrict(f,r) \<in> Pow(r \<times> 2)" for f
        using restrict_subset_Sigma[of f _ "\<lambda>_. 2" r]
        by (force simp: Pi_def)
      with \<open>A \<subseteq> Fn(I, 2)\<close>
      have "{restrict(f,r) . f \<in> A } \<subseteq> Pow(r \<times> 2)"
        by fast
      with \<open>Finite(r)\<close>
      show ?thesis
        using Finite_Sigma[THEN Finite_Pow, of r "\<lambda>_. 2"]
        by (intro Finite_imp_countable) (auto intro:subset_Finite)
    qed
    moreover
    have "uncountable({p\<in>A. domain(p) \<in> D})" (is "uncountable(?X)")
    proof
      from \<open>D \<subseteq> {domain(p) . p \<in> A}\<close>
      have "(\<lambda>p\<in>?X. domain(p)) \<in> surj(?X, D)"
        using lam_type unfolding surj_def by auto
      moreover
      assume "countable(?X)"
      moreover
      note \<open>uncountable(D)\<close>
      ultimately
      show False
        using surj_countable by auto
    qed
    moreover
    have "D = (\<Union>f\<in>Pow(r\<times>2) . {domain(p) . p\<in>{ x\<in>A. restrict(x,r) = f \<and> domain(x) \<in> D}})"
    proof -
      {
        fix z
        assume "z \<in> D"
        with \<open>D \<subseteq> _\<close>
        obtain p  where "domain(p) = z" "p \<in> A"
          by auto
        moreover from \<open>A \<subseteq> Fn(I, 2)\<close> and this
        have "p : z \<rightarrow> 2"
          using domain_of_fun by force
        moreover from this
        have "restrict(p,r) \<subseteq> r \<times> 2"
          using function_restrictI[of p r] fun_is_function[of p z "\<lambda>_. 2"]
            restrict_subset_Sigma[of p z "\<lambda>_. 2" r]
          by (auto simp:Pi_def)
        ultimately
        have "\<exists>p\<in>A.  restrict(p,r) \<in> Pow(r\<times>2) \<and> domain(p) = z" by auto
      }
      then
      show ?thesis
        by (intro equalityI) (force)+
    qed
    obtain f where "uncountable({domain(p) . p\<in>{x\<in>A. restrict(x,r) = f \<and> domain(x) \<in> D}})"
      (is "uncountable(?Y(f))")
    proof -
      {
        from \<open>Finite(r)\<close>
        have "countable(Pow(r\<times>2))"
          using Finite_Sigma[THEN Finite_Pow, THEN Finite_imp_countable]
          by simp
        moreover
        assume "countable(?Y(f))" for f
        moreover
        note \<open>D = (\<Union>f\<in>Pow(r\<times>2) .?Y(f))\<close>
        moreover
        note \<open>uncountable(D)\<close>
        ultimately
        have "False"
          using countable_imp_countable_UN[of "Pow(r\<times>2)" ?Y] by auto
      }
      with that
      show ?thesis by auto
    qed
    then
    obtain j where "j \<in> inj(nat, ?Y(f))"
      using uncountable_iff_nat_lt_cardinal[THEN iffD1, THEN leI,
          THEN cardinal_le_imp_lepoll, THEN lepollD]
      by auto
    then
    have "j`0 \<noteq> j`1" "j`0 \<in> ?Y(f)" "j`1 \<in> ?Y(f)"
      using inj_is_fun[THEN apply_type, of j nat "?Y(f)"]
      unfolding inj_def by auto
    then
    obtain p q where "domain(p) \<noteq> domain(q)" "p \<in> A" "q \<in> A"
      "domain(p) \<in> D" "domain(q) \<in> D"
      "restrict(p,r) = restrict(q,r)" by auto
    moreover from this and delta
    have "domain(p) \<inter> domain(q) = r" unfolding r_def by simp
    moreover
    note \<open>A \<subseteq> Fn(I, 2)\<close>
    moreover from calculation
    have "p \<union> q \<in> Fn(I, 2)"
      by (rule_tac restrict_eq_imp_compat) auto
    ultimately
    have "\<exists>p\<in>A. \<exists>q\<in>A. p \<noteq> q \<and> compat_in(Fn(I, 2), (\<supseteq>), p, q)"
      unfolding compat_in_def
      by (rule_tac bexI[of _ p], rule_tac bexI[of _ q]) blast
  }
  then
  show ?thesis unfolding ccc_def antichain_def by auto
qed

text\<open>The fact that a poset $P$ has the ccc has useful consequences for the
theory of forcing, since it implies that cardinals from the original
model are exactly the cardinals in any generic extension by $P$
\<^cite>\<open>\<open>Chap.~IV\<close> in "kunen2011set"\<close>.\<close>

end


(*
   Title: Theory  inout.thy
   Author:    Maria Spichkova <maria.spichkova at rmit.edu.au>, 2014
*)

section \<open>Correctness of the relations between sets of Input/Output channels\<close>

theory  inout
imports Secrecy_types
begin

consts
  subcomponents ::  "specID \<Rightarrow> specID set"

\<comment> \<open>Mappings, defining sets of input, local, and output channels\<close>
\<comment> \<open>of a component\<close>
consts
  ins :: "specID \<Rightarrow> chanID set"
  loc :: "specID \<Rightarrow> chanID set"
  out :: "specID \<Rightarrow> chanID set"

\<comment> \<open>Predicate insuring the correct mapping from the component identifier\<close>
\<comment> \<open>to the set of input channels of a component\<close>
definition
  inStream :: "specID \<Rightarrow> chanID set \<Rightarrow> bool"
where
  "inStream x y  \<equiv> (ins x = y)"

\<comment> \<open>Predicate insuring the correct mapping from the component identifier\<close>
\<comment> \<open>to the set of local channels of a component\<close>
definition
  locStream :: "specID \<Rightarrow> chanID set \<Rightarrow> bool"
where
  "locStream x y \<equiv> (loc x = y)"

\<comment> \<open>Predicate insuring the correct mapping from the component identifier\<close>
\<comment> \<open>to the set of output channels of a component\<close>
definition
  outStream :: "specID \<Rightarrow> chanID set \<Rightarrow> bool"
where
  "outStream x y \<equiv> (out x = y)"

\<comment> \<open>Predicate insuring the correct relations between\<close>
\<comment> \<open>to the set of input, output and local channels of a component\<close>
definition
  correctInOutLoc :: "specID \<Rightarrow> bool"
where
  "correctInOutLoc x \<equiv>
   (ins x) \<inter> (out x) = {}
    \<and> (ins x) \<inter> (loc x) = {}
    \<and> (loc x) \<inter> (out x) = {} "

\<comment> \<open>Predicate insuring the correct relations between\<close>
\<comment> \<open>sets of input channels within a composed component\<close>
definition
  correctCompositionIn :: "specID \<Rightarrow> bool"
where
  "correctCompositionIn x \<equiv>
  (ins x) = (\<Union> (ins ` (subcomponents x)) - (loc x))
  \<and> (ins x) \<inter> (\<Union> (out ` (subcomponents x))) = {}"

\<comment> \<open>Predicate insuring the correct relations between\<close>
\<comment> \<open>sets of output channels within a composed component\<close>
definition
  correctCompositionOut :: "specID \<Rightarrow> bool"
where
  "correctCompositionOut x \<equiv>
  (out x) = (\<Union> (out ` (subcomponents x))- (loc x))
  \<and> (out x) \<inter> (\<Union> (ins ` (subcomponents x))) = {} "

\<comment> \<open>Predicate insuring the correct relations between\<close>
\<comment> \<open>sets of local channels within a composed component\<close>
definition
  correctCompositionLoc :: "specID \<Rightarrow> bool"
where
  "correctCompositionLoc x \<equiv>
   (loc x) = \<Union> (ins ` (subcomponents x))
           \<inter> \<Union> (out ` (subcomponents x))"

\<comment> \<open>If a component is an elementary one (has no subcomponents)\<close>
\<comment> \<open>its set of local channels should be empty\<close>
lemma subcomponents_loc:
assumes "correctCompositionLoc x"
       and "subcomponents x = {}"
shows "loc x = {}"
using assms by (simp add: correctCompositionLoc_def)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
   A general calculus of refinement in Isabelle.
*)

chapter "Refinement"

theory Simulation
imports Main
begin

text \<open>
  A data type is a collection of three functions on three basic types.
  The three basic types are the private state space @{typ 'a}, the observable
  state space @{typ 'b} and the operations @{typ 'j}.

  The three functions are the initialisation @{term "Init"} which (potentially
  nondeterministically) produces a private state space from an observable one,
  the finalisation @{term Fin} which projects the observable part of
  the state space out of the private one, and finally @{term Step} that gives
  the (potentially nondeterministic) transition relation on the private state
  space for each operation in @{typ 'j}.

  In the simple case, the private state space is something like a
  tuple @{typ "'a \<times> 'b"} fully containing the observable part such
  that @{term Fin} just becomes the projection @{term snd}, and @{term
  "Init s"} constructs an additional private part, e.g. just
  @{term "{(f x, x)}"}.

  Hoare triples on the system and refinement are defined over the observable
  part of the state.
\<close>

record ('a,'b,'j) data_type =
  Init :: "'b \<Rightarrow> 'a set"
  Fin :: "'a \<Rightarrow> 'b"
  Step :: "'j \<Rightarrow> ('a \<times> 'a) set"

text \<open>
  A sequence of operations over a transition relation @{term \<delta>} is executed
  by applying the relation repeatedly.
\<close>
definition
  steps :: "('j \<Rightarrow> ('a \<times> 'a) set) \<Rightarrow> 'a set \<Rightarrow> 'j list \<Rightarrow> 'a set" where
  "steps \<delta> \<equiv> foldl (\<lambda>S j. \<delta> j `` S)"

text \<open>
  The sequence of operations in the data type is then executed
  in an initial state by initialising the private state, executing
  the transition relation over this private state, and finally
  projecting back out the set of final, observable states.
\<close>
definition
   execution :: "('a,'b,'j) data_type \<Rightarrow> 'b \<Rightarrow> 'j list \<Rightarrow> 'b set" where
  "execution A s js \<equiv> Fin A ` steps (Step A) (Init A s) js"

text \<open>
  A Hoare triple over a list of operations in the data type is
  the usual: given a state in the pre-condition, all resulting states
  of the execution must be in the post-condition:
\<close>
definition
  hoare_triple :: "('a,'b,'j) data_type \<Rightarrow> 'b set \<Rightarrow> 'j list \<Rightarrow> 'b set \<Rightarrow> bool"
where
  "hoare_triple A P js Q \<equiv> \<forall>s \<in> P. execution A s js \<subseteq> Q"

text \<open>
  Refinement is defined by saying that all concrete behaviours are contained in
  their corresponding abstract ones. Only the private state spaces of the
  data type may differ.
\<close>
definition
  refines :: "('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool" (infix "\<sqsubseteq>" 60)
where
  "C \<sqsubseteq> A \<equiv> \<forall>js s. execution C s js \<subseteq> execution A s js"

text \<open>
  Alternatively, one may say that all Hoare triples proved on the abstract data
  type are true for the concrete one.
\<close>
lemma hoare_triple_refinement:
  "C \<sqsubseteq> A = (\<forall>P Q js. hoare_triple A P js Q \<longrightarrow> hoare_triple C P js Q)"
  by (simp add: refines_def hoare_triple_def) blast

\<comment> \<open>composing two relations\<close>
definition
  rel_semi :: "('a \<times> 'b) set \<Rightarrow> ('b \<times> 'c) set \<Rightarrow> ('a \<times> 'c) set" (infixl ";;;" 65)
where
  "A ;;; B \<equiv> A O B"

text \<open>
  Refinement is a global property over all executions and/or all
  hoare triples. As this is hard to show, we define the weaker concept
  of forward simulation.
\<close>
definition
  fw_sim :: "('a \<times> 'c) set \<Rightarrow> ('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool"
where
  "fw_sim R C A \<equiv> (\<forall>s. Init C s \<subseteq> R `` Init A s) \<and>
                  (\<forall>j. R ;;; Step C j \<subseteq> Step A j ;;; R) \<and>
                  (\<forall>s s'. (s,s') \<in> R \<longrightarrow> Fin C s' = Fin A s)"

definition
  fw_simulates :: "('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool" (infixl "\<sqsubseteq>\<^sub>F" 50)
where
  "C \<sqsubseteq>\<^sub>F A \<equiv> \<exists>R. fw_sim R C A"

lemma fw_sim_steps:
  assumes steps: "t' \<in> steps (Step C) S' js" "S' \<subseteq> R `` S"
  assumes sim: "fw_sim R C A"
  shows "\<exists>t \<in> steps (Step A) S js. (t,t') \<in> R" using steps
proof (induct js arbitrary: S' S)
  case Nil
  thus ?case by (simp add: steps_def) blast
next
  case (Cons j js)
  hence "t' \<in> steps (Step C) (Step C j `` S') js"
    by (clarsimp simp: steps_def)
  moreover {
    from Cons.prems
    have "S' \<subseteq> R `` S" by simp
    moreover
    from sim
    have "R ;;; Step C j \<subseteq> Step A j ;;; R" by (simp add: fw_sim_def)
    ultimately
    have "Step C j `` S' \<subseteq> R `` (Step A j `` S)"
      by (simp add: rel_semi_def) blast
  }
  ultimately
  show ?case using Cons.hyps
    by (auto simp: steps_def)
qed

lemma sim_imp_refines:
  "C \<sqsubseteq>\<^sub>F A \<Longrightarrow> C \<sqsubseteq> A"
  apply (clarsimp simp: refines_def execution_def fw_simulates_def)
  apply (rename_tac t)
  apply (drule fw_sim_steps)
    prefer 2
    apply assumption
   apply (simp add: fw_sim_def)
   apply blast
  apply clarsimp
  apply (erule rev_image_eqI)
  apply (simp add: fw_sim_def)
  done

text \<open>
  To further aid proofs, we define (private) invariants on data types.
  Private invariants are properties that are true throughout execution
  on the private state space of the state type. The purpose is to exploit
  these properties while showing forward simulation.
\<close>
definition
  invariant_holds :: "('a,'b,'j) data_type \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<Turnstile>" 60)
where
  "D \<Turnstile> I \<equiv> (\<forall>s. Init D s \<subseteq> I) \<and> (\<forall>j. Step D j `` I \<subseteq> I)"

lemma invariant_T [iff]: "D \<Turnstile> UNIV"
  by (simp add: invariant_holds_def)

lemma invariantI:
  "\<lbrakk> \<forall>s. Init D s \<subseteq> I; \<forall>j. Step D j `` I \<subseteq> I \<rbrakk> \<Longrightarrow> D \<Turnstile> I"
  by (simp add: invariant_holds_def)

lemma invariant_CollectI [intro?]:
  assumes init: "\<And>s a. s \<in> Init D a \<Longrightarrow> I s"
  assumes step: "\<And>j s s'. \<lbrakk> I s; (s,s') \<in> Step D j \<rbrakk> \<Longrightarrow> I s'"
  shows "D \<Turnstile> Collect I"
proof (rule invariantI)
  show "\<forall>a. Init D a \<subseteq> Collect I" by (fast intro: init)
next
  show "\<forall>j. Step D j `` Collect I \<subseteq> Collect I"
    by (auto simp add: Image_def intro: step)
qed

lemma invariant_conjI:
  "D \<Turnstile> P \<Longrightarrow> D \<Turnstile> Q  \<Longrightarrow> D \<Turnstile> P \<inter> Q"
  by (simp add: invariant_holds_def) blast

lemma invariant_conjI2:
  "\<lbrakk> D \<Turnstile> I; \<And>s. Init D s \<subseteq> I \<Longrightarrow> Init D s \<subseteq> J;
    \<forall>j. Step D j `` (I \<inter> J) \<subseteq> J \<rbrakk> \<Longrightarrow> D \<Turnstile> I \<inter> J"
  by (simp add: invariant_holds_def) blast

text \<open>
  We can now define forward simulation with an invariant. The proof
  obligation for the step and final case in the correspondence proof
  can now assume that the invariant holds. The invariant itself can be
  shown separately.
\<close>
definition
  LI :: "('a,'b,'j) data_type \<Rightarrow> ('c,'b,'j) data_type \<Rightarrow> ('a \<times> 'c) set \<Rightarrow> ('a \<times> 'c) set \<Rightarrow> bool"
where
  "LI A C R I \<equiv> (\<forall>s. Init C s \<subseteq> R `` Init A s) \<and>
                (\<forall>j. (R \<inter> I) ;;; Step C j \<subseteq> Step A j ;;; R) \<and>
                (\<forall>s s'. (s,s') \<in> R \<inter> I \<longrightarrow> Fin C s' = Fin A s)"

lemma LI_fw_sim:
  assumes  ia: "A \<Turnstile> I\<^sub>a" and ic: "C \<Turnstile> I\<^sub>c" and li: "LI A C r (I\<^sub>a \<times> I\<^sub>c)"
  shows "fw_sim (r \<inter> I\<^sub>a \<times> I\<^sub>c) C A"
proof -
  from li have
    init: "\<forall>s. Init C s \<subseteq> r `` Init A s" and
    step: "\<forall>j. (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) ;;; Step C j \<subseteq> Step A j ;;; r" and
    fin: "(\<forall>s s'. (s,s') \<in> r \<inter> (I\<^sub>a \<times> I\<^sub>c) \<longrightarrow> Fin C s' = Fin A s)"
    by (auto simp: LI_def)
  from ia have  "\<forall>s. (r \<inter> (UNIV \<times> I\<^sub>c) ) `` Init A s = (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) `` Init A s"
    by (simp add: invariant_holds_def, blast)
  moreover from init ic have "\<forall>s. Init C s \<subseteq> (r \<inter> (UNIV \<times> I\<^sub>c)) `` Init A s"
    by (simp add: invariant_holds_def, blast)
  ultimately have initI: "\<forall>s. Init C s \<subseteq> (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) `` Init A s" by simp
  moreover {
    fix j
    from step have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) ;;; Step C j \<subseteq> Step A j ;;; r"..
    also
    have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) = ((UNIV \<times> I\<^sub>a) \<inter> Id) ;;; r ;;; ((I\<^sub>c \<times> UNIV) \<inter> Id)"
      (is "_ = ?I\<^sub>a ;;; r ;;; ?I\<^sub>c")
      by (simp add: rel_semi_def, blast)
    finally
    have "?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j \<subseteq> ?I\<^sub>a ;;; Step A j ;;; r"
      by (simp add: rel_semi_def, blast)
    also
    from ia have "\<dots> \<subseteq> Step A j ;;; ?I\<^sub>a ;;; r"
      by (simp add: invariant_holds_def rel_semi_def, blast)
    finally
    have "?I\<^sub>a ;;;  r ;;; ?I\<^sub>c ;;; Step C j;;; ?I\<^sub>c \<subseteq>  Step A j ;;; ?I\<^sub>a ;;; r ;;; ?I\<^sub>c"
      by (simp add: rel_semi_def, blast)
    also
    from ic
    have "?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j;;; ?I\<^sub>c =  ?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j"
      by (simp add: invariant_holds_def rel_semi_def, blast)
    finally
    have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) ;;; Step C j \<subseteq> Step A j ;;; r \<inter> (I\<^sub>a \<times> I\<^sub>c)"
      by (simp add: rel_semi_def, blast)
  }
  ultimately show "fw_sim (r \<inter> I\<^sub>a \<times> I\<^sub>c) C A" using fin
    by (simp add: fw_sim_def)
qed

lemma weaken_LI:
  assumes LI: "LI A C R I'" and weaker: "I \<subseteq> I'" shows "LI A C R I"
proof -
  from weaker have step: "\<And>j. R \<inter> I ;;; Step C j \<subseteq> R \<inter> I' ;;; Step C j"
    by (fastforce simp: rel_semi_def relcomp_def)
  from weaker have fin: "\<And>S. S \<in> R \<inter> I \<Longrightarrow> S \<in> R \<inter> I'" by fastforce
  from subset_trans[OF step] fin LI show ?thesis  by (clarsimp simp: LI_def)
qed

lemma fw_sim_eq_LI: "fw_sim r C A = LI A C r UNIV"
  by (simp add: fw_sim_def LI_def)

lemma fw_sim_LI: "fw_sim r C A \<Longrightarrow> LI A C r I"
  by (simp add: fw_sim_eq_LI weaken_LI[where I'=UNIV])

lemma L_invariantI:
  assumes  "A \<Turnstile> I\<^sub>a" and "C \<Turnstile> I\<^sub>c" and "LI A C r (I\<^sub>a \<times> I\<^sub>c)"
  shows "C \<sqsubseteq>\<^sub>F A"
  using assms
  by (simp add: fw_simulates_def, rule_tac x="r \<inter> I\<^sub>a \<times> I\<^sub>c" in exI,
      simp add: LI_fw_sim)

lemma refinement_refl[simp]:
  "A \<sqsubseteq> A"
  by (simp add: refines_def)

lemma refinement_trans [trans]:
  "\<lbrakk>C \<sqsubseteq> B; B \<sqsubseteq> A\<rbrakk> \<Longrightarrow> C \<sqsubseteq> A"
  by (simp add: refines_def) blast

lemma fw_inv_transport:
  "\<lbrakk> A \<Turnstile> I\<^sub>a; C \<Turnstile> I\<^sub>c; LI A C R (I\<^sub>a \<times> I\<^sub>c) \<rbrakk> \<Longrightarrow> C \<Turnstile> {s'. \<exists>s. (s,s') \<in> R \<and> s \<in> I\<^sub>a \<and> s' \<in> I\<^sub>c}"
  apply (clarsimp simp: LI_def invariant_holds_def)
  apply (rule conjI)
   apply (rule allI)
   apply clarsimp
   apply (subgoal_tac "x \<in> (R `` Init A s)")
    prefer 2
    apply fastforce
   apply blast
  apply clarsimp
  apply (erule_tac x=j in allE)+
  apply (clarsimp simp: rel_semi_def)
  apply (subgoal_tac "(s,x) \<in> Step A j O R")
   prefer 2
   apply blast
  apply blast
  done

lemma fw_sim_refl:
  "fw_sim Id A A"
  apply (simp add: fw_sim_def rel_semi_def)
  done

lemma fw_simulates_refl[simp]:
  "A \<sqsubseteq>\<^sub>F A"
  apply (simp add: fw_simulates_def fw_sim_refl exI[where x="Id"])
  done

lemma fw_sim_trans:
  "\<lbrakk>fw_sim Q C B; fw_sim R B A\<rbrakk> \<Longrightarrow> fw_sim (R O Q) C A"
  by (auto simp: fw_sim_def rel_semi_def; blast)

lemma fw_simulates_trans:
  "\<lbrakk>C \<sqsubseteq>\<^sub>F B; B \<sqsubseteq>\<^sub>F A\<rbrakk> \<Longrightarrow> C \<sqsubseteq>\<^sub>F A"
  apply (auto simp: fw_simulates_def dest: fw_sim_trans)
  done

end


subsection "Overall General VS Proofs"
theory DNFUni
  imports QE InfinitesimalsUni
begin

fun DNFUni :: "atomUni fmUni \<Rightarrow> atomUni list list" where
  "DNFUni (AtomUni a) = [[a]]"|
  "DNFUni (TrueFUni) = [[]]" |
  "DNFUni (FalseFUni) = []"|
  "DNFUni (AndUni A B) = [A' @ B'. A' \<leftarrow> DNFUni A, B' \<leftarrow> DNFUni B]"|
  "DNFUni (OrUni A B) = DNFUni A @ DNFUni B"

lemma eval_DNFUni : "evalUni F x = evalUni (list_disj_Uni(map (list_conj_Uni o (map AtomUni)) (DNFUni F))) x"
proof(induction F)
  case TrueFUni
  then show ?case by auto
next
  case FalseFUni
  then show ?case by auto
next
  case (AtomUni x)
  then show ?case by auto
next
  case (AndUni F1 F2)
  show ?case unfolding DNFUni.simps eval_list_disj_Uni evalUni.simps AndUni List.map_concat List.set_concat apply simp
    unfolding eval_list_conj_Uni_append
    by blast
next
  case (OrUni F1 F2)
  then show ?case  unfolding DNFUni.simps List.map_append eval_list_disj_Uni List.set_append evalUni.simps
    by blast
qed

fun elimVarUni_atom :: "atomUni list \<Rightarrow> atomUni \<Rightarrow> atomUni fmUni" where
  "elimVarUni_atom F (EqUni (a,b,c)) =
(OrUni
  (AndUni
    (AndUni (AtomUni (EqUni (0,0,a))) (AtomUni (NeqUni (0,0,b))))
      (list_conj_Uni (map (linearSubstitutionUni b c) F)))
    (AndUni (AtomUni (NeqUni (0,0,a))) (AndUni (AtomUni(LeqUni (0,0,-(b^2)+4*a*c)))
      (OrUni
        (list_conj_Uni (map (quadraticSubUni (-b) 1 (b^2-4*a*c) (2*a)) F))
        (list_conj_Uni (map (quadraticSubUni (-b) (-1) (b^2-4*a*c) (2*a)) F))
      )
    )
  )
)
" |
  "elimVarUni_atom F (LeqUni (a,b,c)) =
(OrUni
  (AndUni
    (AndUni (AtomUni (EqUni (0,0,a))) (AtomUni (NeqUni (0,0,b))))
      (list_conj_Uni (map (linearSubstitutionUni b c) F)))
    (AndUni (AtomUni (NeqUni (0,0,a))) (AndUni (AtomUni(LeqUni (0,0,-(b^2)+4*a*c)))
      (OrUni
        (list_conj_Uni (map (quadraticSubUni (-b) 1 (b^2-4*a*c) (2*a)) F))
        (list_conj_Uni (map (quadraticSubUni (-b) (-1) (b^2-4*a*c) (2*a)) F))
      )
    )
  )
)
" |
  "elimVarUni_atom F (LessUni (a,b,c)) =
(OrUni
  (AndUni
    (AndUni (AtomUni (EqUni (0,0,a))) (AtomUni (NeqUni (0,0,b))))
      (list_conj_Uni (map (substInfinitesimalLinearUni b c) F)))
    (AndUni (AtomUni (NeqUni (0,0,a))) (AndUni (AtomUni(LeqUni (0,0,-(b^2)+4*a*c)))
      (OrUni
        (list_conj_Uni (map(substInfinitesimalQuadraticUni (-b) 1 (b^2-4*a*c) (2*a)) F))
        (list_conj_Uni (map(substInfinitesimalQuadraticUni (-b) (-1) (b^2-4*a*c) (2*a)) F))
      )
    )
  )
)
"|
  "elimVarUni_atom F (NeqUni (a,b,c)) =
(OrUni
  (AndUni
    (AndUni (AtomUni (EqUni (0,0,a))) (AtomUni (NeqUni (0,0,b))))
      (list_conj_Uni (map (substInfinitesimalLinearUni b c) F)))
    (AndUni (AtomUni (NeqUni (0,0,a))) (AndUni (AtomUni(LeqUni (0,0,-(b^2)+4*a*c)))
      (OrUni
        (list_conj_Uni (map(substInfinitesimalQuadraticUni (-b) 1 (b^2-4*a*c) (2*a)) F))
        (list_conj_Uni (map(substInfinitesimalQuadraticUni (-b) (-1) (b^2-4*a*c) (2*a)) F))
      )
    )
  )
)
"

fun generalVS_DNF :: "atomUni list \<Rightarrow> atomUni fmUni" where
  "generalVS_DNF L  = list_disj_Uni (list_conj_Uni(map substNegInfinityUni L) # (map (\<lambda>A. elimVarUni_atom L A) L))"

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_Interleave
imports "../../Test_Base"
begin

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

(*fun did not finish the proof.*)
function interleave :: "'a list => 'a list => 'a list" where
"interleave (nil2) y = y"
| "interleave (cons2 z xs) y = cons2 z (interleave y xs)"
  by pat_completeness auto

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 :
  "((interleave (evens xs) (odds xs)) = xs)"
  oops

end


theory Tree_Demo
imports Main
begin

datatype 'a tree = Leaf | Node "'a tree" 'a "'a tree"

lemma "Leaf ~= Node l x r"
apply auto
done

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Leaf = Leaf" |
"mirror (Node l x r) = Node (mirror r) x (mirror l)"

value "mirror(Node (Node Leaf a Leaf) b t)"

lemma mirror_mirror[simp]: "mirror(mirror t) = t"
apply(induction t)
apply auto
done

text{* An example of fun: beyond one equation per constructor *}

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a [] = []" |
"sep a [x] = [x]" |
"sep a (x#y#zs) = x # a # sep a (y#zs)"

value "sep a [x,y,z]"

end


theory RelyGuarantee
  imports Language
begin

datatype ('a, 'b) stmt =
    Atom 'a
  | Choice "('a, 'b) stmt" "('a, 'b) stmt"
  | Seq "('a, 'b) stmt" "('a, 'b) stmt" (infixr ";" 60)
  | Par "('a, 'b) stmt" "('a, 'b) stmt"
  | Star "('a, 'b) stmt"
  | Fail
  | Skip

datatype 'a act = Act "'a \<Rightarrow> 'a set"

primrec runAct :: "'a act \<Rightarrow> 'a \<Rightarrow> 'a set" where
  "runAct (Act f) = f"

lemma st_ext [intro]: "(\<And>x. runAct f x = runAct g x) \<Longrightarrow> f = g"
  apply (rule act.exhaust[of f])
  apply (rule act.exhaust[of g])
  by auto

instantiation act :: (type) monoid_add
begin
  definition zero_act :: "'a act" where
    "zero_act = Act (\<lambda>x. {x})"

  definition plus_act :: "'a act \<Rightarrow> 'a act \<Rightarrow> 'a act" where
    "plus_act f g \<equiv> Act (\<lambda>\<sigma>. \<Union>{runAct g \<sigma>'|\<sigma>'. \<sigma>' \<in> runAct f \<sigma>})"

  instance
    apply default
    apply (simp_all add: zero_act_def plus_act_def)
    apply (rule ext)
    apply auto
    apply (rule st_ext)
    by auto
end

primrec semantics :: "('a \<Rightarrow> 'b act) \<Rightarrow> ('a, 'b) stmt \<Rightarrow> 'b act lan" where
  "semantics f (Atom a) = {f a # []}"
| "semantics f (Choice x y) = semantics f x \<union> semantics f y"
| "semantics f (Seq x y) = semantics f x \<cdot> semantics f y"
| "semantics f (Par x y) = semantics f x \<parallel> semantics f y"
| "semantics f (Star x) = (semantics f x)\<^sup>*"
| "semantics f Fail = {}"
| "semantics f Skip = {[]}"

definition eval_word :: "'a act list \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "eval_word xs H = \<Union>{runAct (listsum xs) h|h. h \<in> H}"

lemma eval_empty_word [simp]: "eval_word [] h = h"
  by (auto simp add: eval_word_def zero_act_def)

lemma eval_cons_word [simp]: "eval_word (x # xs) h = eval_word xs (\<Union>runAct x ` h)"
  by (auto simp add: eval_word_def plus_act_def)

lemma eval_append_word: "eval_word (xs @ ys) h = eval_word ys (eval_word xs h)"
  by (induct xs arbitrary: h) simp_all

definition module :: "'a act lan \<Rightarrow> 'a set \<Rightarrow> 'a set" (infix "\<Colon>" 60) where
  "x \<Colon> h \<equiv> \<Union>{eval_word w h|w. w \<in> x}"

lemma eval_word_continuous: "eval_word w (\<Union>X) = \<Union>eval_word w ` X"
  by (induct w arbitrary: X) (auto simp add: image_def)

lemma mod_mult: "x\<cdot>y \<Colon> h = y \<Colon> (x \<Colon> h)"
proof -
  have "x\<cdot>y \<Colon> h = \<Union>{eval_word w h|w. w \<in> x\<cdot>y}"
    by (simp add: module_def)
  also have "... = \<Union>{eval_word (xw @ yw) h|xw yw. xw \<in> x \<and> yw \<in> y}"
    by (auto simp add: l_prod_def complex_product_def)
  also have "... = \<Union>{eval_word yw (eval_word xw h)|xw yw. xw \<in> x \<and> yw \<in> y}"
    by (simp add: eval_append_word)
  also have "... = \<Union>{\<Union>{eval_word yw (eval_word xw h)|xw. xw \<in> x}|yw. yw \<in> y}"
    by blast
  also have "... = \<Union>{eval_word yw (\<Union>{eval_word xw h|xw. xw \<in> x})|yw. yw \<in> y}"
    by (subst eval_word_continuous) (auto simp add: image_def)
  also have "... = \<Union>{eval_word yw (x \<Colon> h)|yw. yw \<in> y}"
    by (simp add: module_def)
  also have "... = y \<Colon> (x \<Colon> h)"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_one [simp]: "{[]} \<Colon> h = h"
  by (simp add: module_def)

lemma mod_zero [simp]: "{} \<Colon> h = {}"
  by (simp add: module_def)

lemma mod_empty [simp]: "x \<Colon> {} = {}"
  by (simp add: module_def eval_word_def)

lemma mod_distl: "(x \<union> y) \<Colon> h = (x \<Colon> h) \<union> (y \<Colon> h)"
proof -
  have "(x \<union> y) \<Colon> h = \<Union>{eval_word w h|w. w \<in> x \<union> y}"
    by (simp add: module_def)
  also have "... = \<Union>{eval_word w h|w. w \<in> x \<or> w \<in> y}"
    by blast
  also have "... = \<Union>{eval_word w h|w. w \<in> x} \<union> \<Union>{eval_word w h|w. w \<in> y}"
    by blast
  also have "... = (x \<Colon> h) \<union> (y \<Colon> h)"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_distr: "x \<Colon> (h \<union> g) = (x \<Colon> h) \<union> (x \<Colon> g)"
proof -
  have "x \<Colon> (h \<union> g) = \<Union>{eval_word w (h \<union> g)|w. w \<in> x}"
    by (simp add: module_def)
  also have "... = \<Union>{eval_word w h \<union> eval_word w g|w. w \<in> x}"
    by (simp add: eval_word_def) blast
  also have "... = \<Union>{eval_word w h|w. w \<in> x} \<union> \<Union>{eval_word w g|w. w \<in> x}"
    by blast
  also have "... = (x \<Colon> h) \<union> (x \<Colon> g)"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_isol: "x \<subseteq> y \<Longrightarrow> x \<Colon> p \<subseteq> y \<Colon> p"
  by (auto simp add: module_def)

lemma mod_isor: "p \<subseteq> q \<Longrightarrow> x \<Colon> p \<subseteq> x \<Colon> q"
  by (metis mod_distr subset_Un_eq)

lemma mod_continuous: "\<Union>X \<Colon> p = \<Union>{x \<Colon> p|x. x \<in> X}"
  by (simp add: module_def) blast

lemma mod_continuous_var: "\<Union>{f x|x. P x} \<Colon> p = \<Union>{f x \<Colon> p|x. P x}"
  by (simp add: mod_continuous) blast

definition mod_test :: "('a set) \<Rightarrow> 'a act lan" ("_?" [101] 100) where
  "p? \<equiv> {[Act (\<lambda>x. {x} \<inter> p)]}"

lemma mod_test: "p? \<Colon> q = p \<inter> q"
  by (auto simp add: module_def mod_test_def)

lemma test_true: "q \<subseteq> p \<Longrightarrow> p? \<Colon> q = q"
  by (metis Int_absorb1 mod_test)

lemma test_false: "q \<subseteq> -p \<Longrightarrow> p? \<Colon> q = {}"
  by (metis Int_commute disjoint_eq_subset_Compl mod_test)

lemma l_prod_distr: "(X \<union> Y) \<cdot> Z = X \<cdot> Z \<union> Y \<cdot> Z"
  by (insert l_prod_inf_distr[of "{X, Y}" Z]) auto

lemma l_prod_distl: "X \<cdot> (Y \<union> Z) = X \<cdot> Y \<union> X \<cdot> Z"
  by (insert l_prod_inf_distl[of "X" "{Y, Z}"]) auto

no_notation
  Transitive_Closure.trancl ("(_\<^sup>+)" [1000] 999)

definition l_plus :: "'a lan \<Rightarrow> 'a lan" ("_\<^sup>+" [101] 100) where
  "X\<^sup>+ = X\<cdot>X\<^sup>*"

lemma l_plus_unfold: "X\<^sup>+ = X \<union> X\<^sup>+"
  sorry

lemma "q \<subseteq> p \<Longrightarrow> (p?)\<^sup>+\<cdot>x \<Colon> q = (x \<Colon> q) \<union> ((p?)\<^sup>+\<cdot>x \<Colon> q)"
  by (smt l_plus_unfold l_prod_distr mod_distl mod_mult test_true)

lemma "(p?)\<^sup>+\<cdot>x \<Colon> q = (x \<Colon> q \<inter> p) \<union> ((p?)\<^sup>+\<cdot>x \<Colon> q)"
  by (metis inf.commute l_plus_unfold mod_distl mod_distr mod_mult mod_test)

lemma "q \<subseteq> p \<Longrightarrow> (p?)\<^sup>+\<cdot>x \<Colon> q = (x \<Colon> q)"
  nitpick

lemma "p?\<cdot>x \<Colon> q = x\<cdot>q"

lemma "q \<subseteq> -p \<Longrightarrow> p? \<Colon> q = {}"
  by (metis Int_commute disjoint_eq_subset_Compl mod_test)

lemma image_InL [simp]: "map \<langle>id,id\<rangle> ` op # (InL x) ` X = op # x ` map \<langle>id,id\<rangle> ` X"
  by (auto simp add: image_def)

lemma image_InR [simp]: "map \<langle>id,id\<rangle> ` op # (InR x) ` X = op # x ` map \<langle>id,id\<rangle> ` X"
  by (auto simp add: image_def)

lemma image_singleton: "op # x ` X = {[x]} \<cdot> X"
  by (auto simp add: image_def l_prod_def complex_product_def)

lemma tshuffle_await_cons:
  "q \<subseteq> - p \<Longrightarrow> map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # ys) \<sha> (x # xs)) \<Colon> q = op # x ` (map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # ys) \<sha> xs)) \<Colon> q"
  apply (subst tshuffle_ind)
  apply (simp add: mod_distl)
  apply (simp add: image_singleton mod_mult)
  apply (subst module_def) back
  apply (subgoal_tac "q \<inter> p = {}")
  apply simp
  by blast

definition to_rel :: "('a \<Rightarrow> 'a set) \<Rightarrow> 'a rel" where
  "to_rel f = {(x, y)|x y. y \<in> f x}"

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

lemma rel_fun_inv [simp]: "to_rel (to_fun R) = R"
  by (auto simp add: to_fun_def to_rel_def)

lemma fun_rel_inv [simp]: "to_fun (to_rel f) = f"
  by (auto simp add: to_fun_def to_rel_def)

lemma [simp]: "to_fun {} = (\<lambda>x. {})"
  apply (rule ext)
  by (simp add: to_fun_def)

definition \<iota> :: "'a act lan \<Rightarrow> 'a rel" where
  "\<iota> X = \<Union>{to_rel (runAct x)|x. x \<in> symbols X}"

definition \<rho> :: "'a rel \<Rightarrow> 'a act lan" where
  "\<rho> R = pow_inv {Act (to_fun S)|S. S \<subseteq> R}"

lemma \<iota>_iso: "X \<subseteq> Y \<Longrightarrow> \<iota> X \<subseteq> \<iota> Y"
  apply (simp add: \<iota>_def symbols_def)
  by blast

lemma \<rho>_iso: "X \<subseteq> Y \<Longrightarrow> \<rho> X \<subseteq> \<rho> Y"
  apply (simp add: \<rho>_def)
  apply (rule pow_inv_iso)
  by blast

lemma [simp]: "symbols (pow_inv Z) = Z"
proof -
  {
    fix x
    assume "x \<in> Z"
    hence "[x] \<in> pow_inv Z"
      by (metis pow_inv.pinv_cons pow_inv.pinv_empty)
    hence "x \<in> symbols (pow_inv Z)"
      by (metis symbol_cons)
  }
  moreover
  have "symbols (pow_inv Z) \<subseteq> Z"
  proof (auto simp add: symbols_def)
    fix x xs
    assume "xs \<in> pow_inv Z" and "x \<in> set xs"
    thus "x \<in> Z"
      by (induct xs rule: pow_inv.induct) auto
  qed
  ultimately show ?thesis
    by auto
qed

lemma [simp]: "\<Union>{to_rel (runAct xa)|xa. \<exists>S. xa = Act (to_fun S) \<and> S \<subseteq> x} = \<Union>{S|S. S \<subseteq> x}"
  apply (rule arg_cong) back
  apply auto
  apply (rule_tac x = "Act (to_fun xa)" in exI)
  apply simp
  apply (rule_tac x = "xa" in exI)
  by auto

lemma \<iota>_\<rho>_eq: "\<iota> (\<rho> x) = x"
  by (simp add: \<iota>_def \<rho>_def, auto)

lemma \<rho>_\<iota>_eq: "x \<subseteq> \<rho> (\<iota> x)"
  apply (simp add: \<iota>_def \<rho>_def)
  apply (rule order_trans[of _ "pow_inv (symbols x)"])
  apply (metis inv_sym_extensive)
  apply (rule pow_inv_iso)
  apply auto
  apply (rule_tac x = "to_rel (runAct xa)" in exI)
  by auto

lemma galois_connection: "\<iota> x \<subseteq> y \<longleftrightarrow> x \<subseteq> \<rho> y"
  apply default
  apply (metis \<rho>_\<iota>_eq \<rho>_iso subset_trans)
  by (metis \<iota>_\<rho>_eq \<iota>_iso)

definition "preserves b \<equiv> {(\<sigma>,\<sigma>'). \<sigma> \<in> b \<longrightarrow> \<sigma>' \<in> b}"

lemma \<iota>_tl: "\<iota> {x # xs} \<subseteq> preserves p \<Longrightarrow> \<iota> {xs} \<subseteq> preserves p"
  by (auto simp add: preserves_def \<iota>_def symbols_def)

lemma \<iota>_hd: "\<iota> {x # xs} \<subseteq> preserves p \<Longrightarrow> \<iota> {[x]} \<subseteq> preserves p"
  by (auto simp add: preserves_def \<iota>_def symbols_def)

lemma \<iota>_member: "\<iota> x \<subseteq> preserves p \<Longrightarrow> xw \<in> x \<Longrightarrow> \<iota> {xw} \<subseteq> preserves p"
  by (auto simp add: preserves_def \<iota>_def symbols_def Sup_le_iff)

lemma \<iota>_singleton_preserves: "\<iota> {[x]} \<subseteq> preserves p \<longleftrightarrow> (\<forall>q. q \<subseteq> p \<longrightarrow> {[x]} \<Colon> q \<subseteq> p)"
  by (auto simp add: preserves_def module_def \<iota>_def symbols_def to_rel_def)

lemma tshuffle_await_append:
  "\<iota> {xs} \<subseteq> preserves (- p) \<Longrightarrow>
  q \<subseteq> -p \<Longrightarrow>
  map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> (xs @ ys)) \<Colon> q = op @ xs ` (map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ys)) \<Colon> q"
proof (induct xs arbitrary: q)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  assume ih: "\<And>q. \<iota> {xs} \<subseteq> preserves (- p) \<Longrightarrow>
                  q \<subseteq> - p \<Longrightarrow>
                  map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> (xs @ ys)) \<Colon> q = op @ xs ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ys) \<Colon> q"
  and x_xs_preserves_not_p: "\<iota> {x # xs} \<subseteq> preserves (- p)"
  and not_p: "q \<subseteq> - p"

  hence not_p': "{[x]} \<Colon> q \<subseteq> -p"
    by (metis (hide_lams, no_types) \<iota>_hd \<iota>_singleton_preserves)

  have "map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ((x # xs) @ ys)) \<Colon> q = map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> (x # xs @ ys)) \<Colon> q"
    by simp
  also have "... = op # x ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> (xs @ ys)) \<Colon> q"
    by (simp only: tshuffle_await_cons[OF not_p])
  also have "... =  map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> (xs @ ys)) \<Colon> ({[x]} \<Colon> q)"
    by (simp only: image_singleton mod_mult)
  also have "... = op @ xs ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ys) \<Colon> ({[x]} \<Colon> q)"
    by (simp only: ih[OF \<iota>_tl[OF x_xs_preserves_not_p] not_p'])
  also have "... = op # x ` op @ xs ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ys) \<Colon> q"
    by (simp only: mod_mult[symmetric] image_singleton[symmetric])
  also have "... = op @ (x # xs) ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zs) \<sha> ys) \<Colon> q"
    by (simp only: image_compose[symmetric] o_def append.simps)
  finally show ?case .
qed

lemma set_comp_3_eq: "(\<And>x y z. Q x y z \<Longrightarrow> P x y z = P' x y z) \<Longrightarrow> {P x y z|x y z. Q x y z} = {P' x y z|x y z. Q x y z}"
  by auto metis+

lemma helper: "\<Union>{{xw} \<cdot> P y z|y xw z. Q y z \<and> xw \<in> x \<and> Q y z} = \<Union>{x \<cdot> P y z|y z. Q y z}"
  by (auto simp add: l_prod_def complex_product_def)

lemma image_append: "op @ xs ` X = {xs} \<cdot> X"
  by (auto simp add: l_prod_def complex_product_def)

lemma await_par:
  assumes x_preserves_not_p: "\<iota> x \<subseteq> preserves (- p)"
  and not_p: "q \<subseteq> -p"
  shows "p?\<cdot>z \<parallel> x\<cdot>y \<Colon> q = x\<cdot>(p?\<cdot>z \<parallel> y) \<Colon> q"
proof -
  have "p?\<cdot>z \<parallel> x\<cdot>y \<Colon> q = \<Union>{map \<langle>id,id\<rangle> ` (pzw \<sha> xyw)|pzw xyw. pzw \<in> p? \<cdot> z \<and> xyw \<in> x \<cdot> y} \<Colon> q"
    by (simp add: shuffle_def)
  also have "... = \<Union>{map \<langle>id,id\<rangle> ` (pzw \<sha> xyw) \<Colon> q|pzw xyw. pzw \<in> p? \<cdot> z \<and> xyw \<in> x \<cdot> y}"
    by (subst mod_continuous) blast
  also have "... = \<Union>{map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> (xw @ yw)) \<Colon> q|zw xw yw. zw \<in> z \<and> xw \<in> x \<and> yw \<in> y}"
    by (simp add: l_prod_def complex_product_def mod_test_def, rule arg_cong, blast)
  also have "... = \<Union>{op @ xw ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> yw) \<Colon> q|zw xw yw. zw \<in> z \<and> xw \<in> x \<and> yw \<in> y}"
    apply (rule arg_cong) back
    apply (rule set_comp_3_eq)
    apply (subst tshuffle_await_append)
    apply (metis \<iota>_member x_preserves_not_p)
    apply (metis not_p)
    by simp
  also have "... = \<Union>{op @ xw ` map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> yw)|zw xw yw. zw \<in> z \<and> xw \<in> x \<and> yw \<in> y} \<Colon> q"
    by (subst mod_continuous) blast
  also have "... = \<Union>{{xw} \<cdot> map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> yw)|zw xw yw. zw \<in> z \<and> xw \<in> x \<and> yw \<in> y} \<Colon> q"
    by (simp only: image_append)
  also have "... = \<Union>{x \<cdot> map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> yw)|zw yw. zw \<in> z \<and> yw \<in> y} \<Colon> q"
    by (rule arg_cong, auto simp add: l_prod_def complex_product_def)
  also have "... = x \<cdot> \<Union>{map \<langle>id,id\<rangle> ` ((Act (\<lambda>x. {x} \<inter> p) # zw) \<sha> yw)|zw yw. zw \<in> z \<and> yw \<in> y} \<Colon> q"
    by (subst l_prod_inf_distl, rule arg_cong, blast)
  also have "... = x \<cdot> \<Union>{map \<langle>id,id\<rangle> ` (pzw \<sha> yw)|pzw yw. pzw \<in> p? \<cdot> z \<and> yw \<in> y} \<Colon> q"
    by (simp add: l_prod_def complex_product_def mod_test_def, rule arg_cong, blast)
  also have "... = x\<cdot>(p?\<cdot>z \<parallel> y) \<Colon> q"
    by (simp add: shuffle_def)
  finally show ?thesis .
qed

(*
primrec splittings_ind :: "'a list \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list) set" where
  "splittings_ind ys [] = {(ys, [])}"
| "splittings_ind ys (x#xs) = {(ys, x#xs)} \<union> (splittings_ind (ys @ [x]) xs)"

definition splittings where "splittings xs = {(ys,zs). ys @ zs = xs}"

definition add_first where "add_first xs X = (\<lambda>x. (xs @ fst x, snd x)) ` X"

lemma afs: "add_first ws (splittings xs) = {(ws @ ys,zs)|ys zs. ys @ zs = xs}"
  by (auto simp add: add_first_def splittings_def image_def)

lemma l1: "splittings_ind ys xs = add_first ys (splittings xs)"
  apply (simp add: afs)
  apply (induct xs arbitrary: ys)
  apply simp
  apply auto
  apply (metis Cons_eq_append_conv)
  by (metis (hide_lams, no_types) append_eq_Cons_conv)

lemma [simp]: "add_first [] (splittings xs) = splittings xs"
  by (simp add: splittings_def add_first_def)

lemma l2: "splittings_ind [] xs = splittings xs"
  by (insert l1[of "[]"], simp)
*)

type_synonym mem = "nat \<Rightarrow> nat option"

datatype atoms =
    Assign nat nat
  | Pred "mem set"

primrec atoms_interp :: "atoms \<Rightarrow> mem act" where
  "atoms_interp (Assign x v) = Act (\<lambda>mem. {\<lambda>y. if x = y then Some v else mem y})"
| "atoms_interp (Pred p) = Act (\<lambda>mem. if mem \<in> p then {mem} else {})"

definition domain :: "mem \<Rightarrow> nat set" where
  "domain f \<equiv> {x. f x \<noteq> None}"

definition disjoint :: "mem \<Rightarrow> mem \<Rightarrow> bool" where
  "disjoint f g \<equiv> domain f \<inter> domain g = {}"

definition merge :: "mem \<Rightarrow> mem \<Rightarrow> mem" where
  "merge \<sigma> \<sigma>' = (\<lambda>v. if \<sigma> v = None then \<sigma>' v else \<sigma> v)"

definition sep_conj :: "mem set \<Rightarrow> mem set \<Rightarrow> mem set" (infixr "**" 45) where
  "p ** q \<equiv> {\<sigma>''. \<exists>\<sigma> \<sigma>'. disjoint \<sigma> \<sigma>' \<and> \<sigma>'' = merge \<sigma> \<sigma>' \<and> \<sigma> \<in> p \<and> \<sigma>' \<in> q}"

definition quintuple :: "'b rel \<Rightarrow> 'b rel \<Rightarrow> ('a \<Rightarrow> 'b act) \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) stmt \<Rightarrow> 'b set \<Rightarrow> bool"
  ("_, _ \<turnstile>\<^bsub>_\<^esub> \<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>" [20,20,0,20,20,20] 100) where
  "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<equiv> (\<rho> r \<parallel> semantics \<Gamma> c \<Colon> p \<subseteq> q) \<and> (\<iota> (semantics \<Gamma> c) \<subseteq> g)"

definition stable :: "'b rel \<Rightarrow> 'b set \<Rightarrow> bool" where
  "stable r p \<equiv> \<rho> r \<Colon> p \<subseteq> p"

lemma SKIP: "stable r p \<Longrightarrow> r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Skip \<lbrace>p\<rbrace>"
  by (simp add: quintuple_def \<iota>_def symbols_def stable_def)

lemma inv_exchange: "\<rho> r \<parallel> x \<cdot> y = (\<rho> r \<parallel> x) \<cdot> (\<rho> r \<parallel> y)"
  sorry

lemma inv_join: "\<iota>(x \<parallel> y) = \<iota> x \<union> \<iota> y"
  sorry

lemma SEQ:
  assumes "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> C1 \<lbrace>q\<rbrace>" and "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>q\<rbrace> C2 \<lbrace>s\<rbrace>"
  shows "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> C1; C2 \<lbrace>s\<rbrace>"
  using assms
  apply (simp add: quintuple_def inv_exchange mod_mult)
  apply (intro conjI)
  apply (metis mod_isor order_trans)
  by (metis Un_upper2 \<iota>_iso empty_subsetI inv_join shuffle_zerol subset_antisym)

lemma rely_dup: "\<rho> r = \<rho> r \<parallel> \<rho> r"
  by (metis (full_types) \<iota>_\<rho>_eq empty_subsetI galois_connection inv_join inv_shuffle inv_sym_extensive shuffle_zeror sup_top_left top_unique)

lemma shuffle_isor: "X \<subseteq> Y \<Longrightarrow> Z \<parallel> X \<subseteq> Z \<parallel> Y"
  by (metis shuffle_comm shuffle_iso)

lemma PAR:
  assumes "g1 \<subseteq> r2" and "r1, g1 \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1\<rbrace> C1 \<lbrace>q1\<rbrace>"
  and "g2 \<subseteq> r1" and "r2, g2 \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p2\<rbrace> C2 \<lbrace>q2\<rbrace>"
  shows "(r1 \<inter> r2), (g1 \<union> g2) \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1 \<inter> p2\<rbrace> Par C1 C2 \<lbrace>q1 \<inter> q2\<rbrace>"
proof (simp add: quintuple_def, intro conjI)
  let ?c1 = "semantics \<Gamma> C1"
  let ?c2 = "semantics \<Gamma> C2"

  have "\<rho> (r1 \<inter> r2) \<parallel> (?c1 \<parallel> ?c2) \<Colon> p1 \<inter> p2 = (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<Colon> p1 \<inter> p2"
    by (smt rely_dup shuffle_assoc shuffle_comm)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<Colon> p1"
    by (metis Int_lower1 mod_isor)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> \<rho> (\<iota> ?c2)) \<Colon> p1"
    by (intro mod_isol shuffle_isor) (metis \<rho>_\<iota>_eq)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> \<rho> g2) \<Colon> p1"
    by (intro mod_isol shuffle_isor) (metis \<rho>_iso assms(4) quintuple_def)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<parallel> \<rho> (r1 \<inter> r2) \<Colon> p1"
    by (intro mod_isol shuffle_isor) (metis empty_subsetI galois_connection inf_absorb2 inv_join le_inf_iff shuffle_zeror sup_ge1)
  also have "... \<subseteq> (\<rho> r1 \<parallel> ?c1) \<parallel> \<rho> r1 \<Colon> p1"
    by (metis \<iota>_\<rho>_eq galois_connection inf_le1 mod_isol rely_dup shuffle_assoc shuffle_comm shuffle_iso)
  also have "... = \<rho> r1 \<parallel> ?c1 \<Colon> p1"
    by (metis rely_dup shuffle_assoc shuffle_comm)
  also have "... \<subseteq> q1"
    by (metis assms(2) quintuple_def)
  finally show "\<rho> (r1 \<inter> r2) \<parallel> (semantics \<Gamma> C1 \<parallel> semantics \<Gamma> C2) \<Colon> p1 \<inter> p2 \<subseteq> q1" .

  have "\<rho> (r1 \<inter> r2) \<parallel> (?c1 \<parallel> ?c2) \<Colon> p1 \<inter> p2 = \<rho> (r1 \<inter> r2) \<parallel> (?c2 \<parallel> ?c1) \<Colon> p1 \<inter> p2"
    by (metis shuffle_comm)
  also have "... = (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<Colon> p1 \<inter> p2"
    by (smt rely_dup shuffle_assoc shuffle_comm)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> ?c1) \<Colon> p2"
    by (metis Int_lower2 mod_isor)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> \<rho> (\<iota> ?c1)) \<Colon> p2"
    by (intro mod_isol shuffle_isor) (metis \<rho>_\<iota>_eq)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<parallel> (\<rho> (r1 \<inter> r2) \<parallel> \<rho> g1) \<Colon> p2"
    by (intro mod_isol shuffle_isor) (metis \<rho>_iso assms(2) quintuple_def)
  also have "... \<subseteq> (\<rho> (r1 \<inter> r2) \<parallel> ?c2) \<parallel> \<rho> (r1 \<inter> r2) \<Colon> p2"
    by (intro mod_isol shuffle_isor) (metis empty_subsetI galois_connection inf_absorb2 inv_join shuffle_zeror sup_inf_absorb)
  also have "... \<subseteq> (\<rho> r2 \<parallel> ?c2) \<parallel> \<rho> r2 \<Colon> p2"
    by (metis \<rho>_iso inf_le2 mod_isol rely_dup shuffle_assoc shuffle_comm shuffle_iso)
  also have "... = \<rho> r2 \<parallel> ?c2 \<Colon> p2"
    by (metis rely_dup shuffle_assoc shuffle_comm)
  also have "... \<subseteq> q2"
    by (metis assms(4) quintuple_def)
  finally show "\<rho> (r1 \<inter> r2) \<parallel> (semantics \<Gamma> C1 \<parallel> semantics \<Gamma> C2) \<Colon> p1 \<inter> p2 \<subseteq> q2" .

  show "\<iota> (?c1 \<parallel> ?c2) \<subseteq> g1 \<union> g2"
    by (metis assms(2) assms(4) inv_join quintuple_def sup_mono)
qed

lemma CHOICE:
  assumes "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> C1 \<lbrace>q\<rbrace>" and "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> C2 \<lbrace>q\<rbrace>"
  shows "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Choice C1 C2 \<lbrace>q\<rbrace>"
  using assms
  apply (simp add: quintuple_def)
  apply (intro conjI)
  apply (metis le_sup_iff mod_distl shuffle_distl)
  by (metis galois_connection le_sup_iff)

definition Await :: "mem set \<Rightarrow> (atoms, mem) stmt \<Rightarrow> (atoms, mem) stmt" where
  "Await b C = Seq (Atom (Pred b)) C"

lemma helper2: "x \<subseteq> y \<Longrightarrow> y \<union> z \<subseteq> w \<Longrightarrow> x \<union> z \<subseteq> w"
  by (metis le_sup_iff order_trans)

lemma helper3: "x \<subseteq> y \<Longrightarrow> x \<union> y \<subseteq> y"
  by (metis le_sup_iff order_refl)

lemma test: "{(\<sigma>, \<sigma>'). \<sigma>' \<in> runAct a \<sigma>} \<subseteq> {(\<sigma>, \<sigma>'). \<sigma> \<in> p \<longrightarrow> \<sigma>' \<in> p} \<Longrightarrow> \<sigma> \<in> p \<longrightarrow> runAct a \<sigma> \<subseteq> p"
  by auto

lemma test_comm: "\<iota> {[x]} \<subseteq> preserves p \<Longrightarrow> {[Act (\<lambda>x. {x} \<inter> p)]} \<cdot> {[x]} \<Colon> q \<subseteq> {[x]} \<cdot> {[Act (\<lambda>x. {x} \<inter> p)]} \<Colon> q"
  by (auto simp add: l_prod_def complex_product_def module_def preserves_def \<iota>_def symbols_def to_rel_def)

lemma tshuffle_left_leq: "{[x]} \<cdot> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<subseteq> map \<langle>id,id\<rangle> ` ((x # xs) \<sha> ys)"
  apply (induct ys)
  apply (simp add: l_prod_def complex_product_def)
  apply (simp only: tshuffle_ind image_Un image_InL)
  apply (simp only: image_singleton)
  by (metis Un_upper1)

lemma tshuffle_right_leq: "{[y]} \<cdot> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<subseteq> map \<langle>id,id\<rangle> ` (xs \<sha> (y # ys))"
  by (metis (hide_lams, no_types) tshuffle_left_leq tshuffle_words_comm)

lemma mod_isol_var: "z \<subseteq> y \<Longrightarrow> x \<Colon> p \<subseteq> z \<Colon> p \<Longrightarrow> x \<Colon> p \<subseteq> y \<Colon> p"
  by (metis mod_isol subset_trans)

lemma preserve_test_tshuffle:
  "\<iota> {xs} \<subseteq> preserves p \<Longrightarrow> map \<langle>id,id\<rangle> ` (xs \<sha> (Act (\<lambda>x. {x} \<inter> p) # ys)) \<Colon> q = {[Act (\<lambda>x. {x} \<inter> p)]} \<cdot> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<Colon> q"
  apply default
  defer
  apply (rule mod_isol)
  apply (rule tshuffle_right_leq)
proof (induct xs arbitrary: q)
  case Nil
  show ?case by (simp add: l_prod_def complex_product_def)
next
  case (Cons x xs)
  assume "\<And>q. \<iota> {xs} \<subseteq> preserves p \<Longrightarrow>
              map \<langle>id,id\<rangle> ` (xs \<sha> (Act (\<lambda>x. {x} \<inter> p) # ys)) \<Colon> q \<subseteq> {[Act (\<lambda>x. {x} \<inter> p)]} \<cdot> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<Colon> q"
  and x_xs_preserves_p: "\<iota> {x # xs} \<subseteq> preserves p"
  note ih = this(1)[OF \<iota>_tl[OF this(2)]]

  show ?case
    apply (simp only: tshuffle_ind image_Un image_InL image_InR mod_distl)
    apply (simp only: image_singleton)
    apply (subst mod_mult)
    apply (rule helper2[OF ih])
    apply (subst mod_mult[symmetric])
    apply (rule helper3)
    apply (subst l_prod_assoc[symmetric])
    apply (rule mod_isol_var[OF l_prod_isor[OF tshuffle_left_leq]])
    apply (subst l_prod_assoc[symmetric])
    apply (subst mod_mult)
    apply (subst mod_mult) back
    apply (rule mod_isor)
    apply (subst mod_mult)
    apply (subst test_comm[OF q_satisfies_p \<iota>_hd[OF x_xs_preserves_p]])
    apply (subst mod_mult[symmetric])
    apply (subst l_prod_assoc)
    apply (rule mod_isol)
    apply (rule l_prod_isor)
    by (rule tshuffle_left_leq)
qed
*)

lemma preserve_test:
  assumes "r \<subseteq> preserves s" and "q \<subseteq> p"
  shows "(\<rho> r \<parallel> p? \<cdot> x) \<Colon> q = p? \<cdot> (\<rho> r \<parallel> x) \<Colon> q"
  sorry

lemma AWAIT1: "r \<subseteq> preserves s \<Longrightarrow> p \<subseteq> s \<Longrightarrow> r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>s\<rbrace> C \<lbrace>q\<rbrace> \<Longrightarrow> r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Await s C \<lbrace>q\<rbrace>" sorry

lemma AWAIT:
  assumes "g1 \<subseteq> r2" and "r1, g1 \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1 \<inter> t\<rbrace> C1 \<lbrace>q1\<rbrace>"
  and "g2 \<subseteq> r1" and "r2, g2 \<inter> preserves t \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p2\<rbrace> C2 \<lbrace>t \<inter> q2\<rbrace>"
  shows "(r1 \<inter> r2), (g1 \<union> g2) \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1 \<inter> p2\<rbrace> Par (Await t C1) C2 \<lbrace>q1 \<inter> q2\<rbrace>"
  apply (rule PAR)
  sorry

lemma Sup_image_le_iff: "(\<Union>{f x|x. P x} \<subseteq> Y) \<longleftrightarrow> (\<forall>x. P x \<longrightarrow> f x \<subseteq> Y)"
  by blast

lemma mod_forall: "X \<Colon> p \<subseteq> q \<longleftrightarrow> (\<forall>x\<in>X. {x} \<Colon> p \<subseteq> q)"
  by (auto simp add: module_def)

lemma pow_inv_singleton: "x \<in> X \<Longrightarrow> [x] \<in> pow_inv X"
  by (metis pow_inv.pinv_cons pow_inv.pinv_empty)

lemma stable_forall: "stable r p \<longleftrightarrow> (\<forall>xs\<in>(pow_inv {Act (to_fun S) |S. S \<subseteq> r}). {xs} \<Colon> p \<subseteq> p)"
  apply (simp add: stable_def \<rho>_def)
  apply (subst mod_forall)
  by simp

lemma singleton_stable: "stable r p \<Longrightarrow> x \<in> {Act (to_fun S) |S. S \<subseteq> r} \<Longrightarrow> {[x]} \<Colon> p \<subseteq> p"
  apply (simp only: stable_forall \<rho>_def)
  apply (drule pow_inv_singleton)
  by auto

lemma mod_cons: "op # x ` X \<Colon> p = {[x]} \<cdot> X \<Colon> p"
  by (simp add: image_def complex_product_def l_prod_def, rule arg_cong, blast)

lemma [simp]: "map \<langle>id,id\<rangle> ` op # (InL x) ` X = op # x ` map \<langle>id,id\<rangle> ` X"
  by (auto simp add: image_def)

lemma mod_cons_var: "{x # xs} \<Colon> p = {[x]} \<cdot> {xs} \<Colon> p"
  by (auto simp add: l_prod_def complex_product_def)

lemma ATOM:
  assumes atom: "\<forall>\<sigma>\<in>p. runAct (\<Gamma> a) \<sigma> \<subseteq> q"
  and p_stable: "stable r p"
  and q_stable: "stable r q"
  shows "r, {(\<sigma>,\<sigma>'). \<sigma>' \<in> runAct (\<Gamma> a) \<sigma>}  \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Atom a \<lbrace>q\<rbrace>"
proof -
  from assms have atom': "({[\<Gamma> a]} \<Colon> p) \<subseteq> q"
    by (auto simp add: module_def)

  {
    fix xs
    assume "xs \<in> pow_inv {Act (to_fun S) |S. S \<subseteq> r}"
    hence "map \<langle>id,id\<rangle> ` (xs \<sha> [\<Gamma> a]) \<Colon> p \<subseteq> q"
    proof (induct xs, simp add: atom')
      fix x and xs
      assume x_set: "x \<in> {Act (to_fun S) |S. S \<subseteq> r}"
      and xs_set: "xs \<in> pow_inv {Act (to_fun S) |S. S \<subseteq> r}"
      and ih: "map \<langle>id,id\<rangle> ` (xs \<sha> [\<Gamma> a]) \<Colon> p \<subseteq> q"

      have "{[x]} \<Colon> p \<subseteq> p"
        by (rule singleton_stable[OF p_stable x_set])

      hence x_first: "op # x ` map \<langle>id,id\<rangle> ` (xs \<sha> [\<Gamma> a]) \<Colon> p \<subseteq> q"
        by (simp add: mod_cons mod_mult) (metis (hide_lams, no_types) ih mod_isor subset_trans)

      have "x # xs \<in> pow_inv {Act (to_fun S) |S. S \<subseteq> r}"
        by (smt pow_inv.pinv_cons x_set xs_set)
      hence "{x#xs} \<Colon> q \<subseteq> q"
        by (metis \<rho>_def mod_forall q_stable stable_def)

      from x_first and this show "map \<langle>id,id\<rangle> ` ((x # xs) \<sha> [\<Gamma> a]) \<Colon> p \<subseteq> q"
        apply (simp only: tshuffle_ind image_Un mod_distl, simp, subst mod_cons_var, subst mod_mult)
        by (metis atom' mod_isor subset_trans)
    qed
  }

  thus "r, {(\<sigma>,\<sigma>'). \<sigma>' \<in> runAct (\<Gamma> a) \<sigma>}  \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Atom a \<lbrace>q\<rbrace>"
    apply (simp add: quintuple_def)
    apply (intro conjI)
    apply (insert p_stable)
    defer
    apply (simp add: to_rel_def \<iota>_def symbols_def)
    apply (simp add: stable_def)
    apply (simp add: \<rho>_def shuffle_def)
    apply (subst mod_continuous_var)
    apply (subst Sup_image_le_iff)
    by auto
qed

lemma WEAKEN: "r' \<subseteq> r \<Longrightarrow> g \<subseteq> g' \<Longrightarrow> p' \<subseteq> p \<Longrightarrow> q \<subseteq> q' \<Longrightarrow> r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> C \<lbrace>q\<rbrace> \<Longrightarrow> r', g' \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p'\<rbrace> C \<lbrace>q'\<rbrace>"
  apply (simp add: quintuple_def)
  by (metis \<rho>_iso mod_isol mod_isor order_trans shuffle_iso)

lemmas WEAKEN_RELY = WEAKEN[OF _ subset_refl subset_refl subset_refl]
  and STRENGTHEN_GUAR = WEAKEN[OF subset_refl _ subset_refl subset_refl]
  and WEAKEN_PRE = WEAKEN[OF subset_refl subset_refl _ subset_refl]
  and STRENGTHEN_POST = WEAKEN[OF subset_refl subset_refl subset_refl _]

lemma ATOM_VAR:
  assumes atom: "\<forall>\<sigma>\<in>p. runAct (\<Gamma> a) \<sigma> \<subseteq> q"
  and p_stable: "stable r p"
  and q_stable: "stable r q"
  and guar: "{(\<sigma>,\<sigma>'). \<sigma>' \<in> runAct (\<Gamma> a) \<sigma>} \<subseteq> g"
  shows "r, g  \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p\<rbrace> Atom a \<lbrace>q\<rbrace>"
  apply (rule STRENGTHEN_GUAR[OF guar])
  apply (rule ATOM)
  apply (metis atom)
  apply (metis p_stable)
  by (metis q_stable)

abbreviation quintuple' :: "mem rel \<Rightarrow> mem rel \<Rightarrow> mem set \<Rightarrow> (atoms, mem) stmt \<Rightarrow> mem set \<Rightarrow> bool"
  ("_, _ \<turnstile>// \<lbrace>_\<rbrace>// _// \<lbrace>_\<rbrace>" [20,20,20,20,20] 100) where
  "r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<equiv> r, g \<turnstile>\<^bsub>atoms_interp\<^esub> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace>"

definition maps_to :: "nat \<Rightarrow> nat \<Rightarrow> mem set" (infix "\<mapsto>" 95) where
  "v \<mapsto> n \<equiv> {\<sigma>. \<sigma> v = Some n}"

definition maps_to_any :: "nat \<Rightarrow> mem set" ("_ \<mapsto> -" [96] 95) where
  "v \<mapsto> - = {\<sigma>. \<exists>n. \<sigma> v = Some n}"

abbreviation assignment :: "nat \<Rightarrow> nat \<Rightarrow> (atoms, mem) stmt" (infix ":=" 95) where
  "assignment v n \<equiv> Atom (Assign v n)"

abbreviation Test :: "mem set \<Rightarrow> (atoms, mem) stmt" where "Test t \<equiv> Atom (Pred t)"

lemma [simp]: "semantics atoms_interp (Test t) \<Colon> h = h \<inter> t"
  by (auto simp add: module_def)

definition Await :: "mem set \<Rightarrow> (atoms, mem) stmt \<Rightarrow> (atoms, mem) stmt" where
  "Await b C = Seq (Test b) C"

definition "unchanged V \<equiv> {(\<sigma>,\<sigma>'). \<forall>v\<in>V. \<sigma> v = \<sigma>' v}"

definition "preserves b \<equiv> {(\<sigma>,\<sigma>'). \<sigma> \<in> b \<longrightarrow> \<sigma>' \<in> b}"

lemma AWAIT:
  assumes "\<exists>C11 C12 C13."
  shows "r, g \<turnstile> \<lbrace>p\<rbrace> Par C1 (Await b C2) \<lbrace>q1 \<inter> q2\<rbrace>"

lemma ASSIGN:
  shows "unchanged {v}, {(\<sigma>,\<sigma>'). \<sigma>' v = Some n \<and> (\<forall>v'. v' \<noteq> v \<longrightarrow> \<sigma> v' = \<sigma>' v')} \<turnstile> \<lbrace>v \<mapsto> -\<rbrace> v := n \<lbrace>v \<mapsto> n\<rbrace>"
  sorry

abbreviation K :: "bool \<Rightarrow> 'a set" where "K t \<equiv> {s. t}"

lemma disj1: "(x \<mapsto> - ** y \<mapsto> -) = (K (x \<noteq> y) \<inter> x \<mapsto> - ** K (x \<noteq> y) \<inter> y \<mapsto> -)"
  by (auto simp add: sep_conj_def maps_to_any_def disjoint_def domain_def)

lemma empty_mod: "x \<Colon> {} = {}"
  by (simp add: module_def eval_word_def)

lemma CONST: "(p' \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> C1 \<lbrace>q\<rbrace>) \<Longrightarrow> r, g \<turnstile> \<lbrace>K p' \<inter> p\<rbrace> C1 \<lbrace>q\<rbrace>"
  apply (simp add: quintuple_def empty_mod)
  by (metis Un_empty_left empty_subsetI galois_connection inv_join shuffle_zerol subset_empty)

lemma "x \<mapsto> n \<subseteq> x \<mapsto> -"
  by (auto simp add: maps_to_def maps_to_any_def)

lemma empty_rely1: "\<rho> {} \<Colon> p \<subseteq> p"
proof (auto simp add: \<rho>_def module_def eval_word_def)
  fix w x \<sigma>
  assume "w \<in> pow_inv {Act (\<lambda>x. {})}" and "x \<in> runAct (listsum w) \<sigma>"
  and "\<sigma> \<in> p"
  thus "x \<in> p"
    by (induct w rule: pow_inv.induct) (simp_all add: zero_act_def plus_act_def)
qed

lemma empty_rely2: "p \<subseteq> \<rho> {} \<Colon> p"
  apply (simp add: \<rho>_def module_def eval_word_def)
  apply auto
  apply (rule_tac x = p in exI)
  apply (intro conjI)
  apply auto
  apply (rule_tac x = "[]" in exI)
  by (auto simp add: zero_act_def)

lemma empty_rely [simp]: "\<rho> {} \<Colon> p = p"
  by (metis empty_rely1 empty_rely2 subset_antisym)

lemma "{}, UNIV \<turnstile> \<lbrace>x \<mapsto> n\<rbrace> Skip \<lbrace>x \<mapsto> -\<rbrace>"
  by (auto simp add: quintuple_def maps_to_any_def maps_to_def)

datatype ('a, 'b) rg_block =
    RGPar "('a, 'b) stmt" "('a, 'b) rg_block"
  | RGEnd "('a, 'b) stmt"

definition rg_block :: "'b rel \<Rightarrow> ('a, 'b) stmt \<Rightarrow> 'b rel \<Rightarrow> ('a, 'b) rg_block \<Rightarrow> ('a, 'b) rg_block" ("//  RELY _//    DO _//  GUAR _; _" [31,31,31,30] 30) where
  "RELY r DO C GUAR g; prog \<equiv> RGPar C prog"

definition rg_block_end :: "'b rel \<Rightarrow> ('a, 'b) stmt \<Rightarrow> 'b rel \<Rightarrow> ('a, 'b) rg_block" ("//  RELY _//    DO _//  GUAR _//COEND" [31,31,31] 30) where
  "RELY r DO C GUAR g COEND \<equiv> RGEnd C"

primrec cobegin :: "('a, 'b) rg_block \<Rightarrow> ('a, 'b) stmt" ("COBEGIN _" [30] 30) where
  "cobegin (RGPar c rg) = Par c (cobegin rg)"
| "cobegin (RGEnd c) = c"

abbreviation triple' :: "mem set \<Rightarrow> (atoms, mem) stmt \<Rightarrow> mem set \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>// _// \<lbrace>_\<rbrace>" [20,20,20] 100) where
  "\<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<equiv> {}, UNIV \<turnstile>\<^bsub>atoms_interp\<^esub> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace>"

lemma COBEGIN:
  assumes "r1, g1 \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1\<rbrace> C1 \<lbrace>q1\<rbrace>"
  and "r2, g2 \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p2\<rbrace> C2 \<lbrace>q2\<rbrace>"
  and "g1 \<subseteq> r2" and "g2 \<subseteq> r1"
  and "r \<subseteq> r1 \<inter> r2" and "g1 \<union> g2 \<subseteq> g"
  shows "r, g \<turnstile>\<^bsub>\<Gamma>\<^esub> \<lbrace>p1 \<inter> p2\<rbrace> COBEGIN RELY r1 DO C1 GUAR g1; RELY r2 DO C2 GUAR g2 COEND \<lbrace>q1 \<inter> q2\<rbrace>"
  apply (rule WEAKEN[OF assms(5) assms(6) subset_refl subset_refl])
  using assms
  by (auto simp add: rg_block_def rg_block_end_def intro: PAR)

definition PAR_ASSIGN :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (atoms, mem) stmt" ("_, _ := _, _" [96,96,96,96] 95) where
  "PAR_ASSIGN x y n m \<equiv>
    COBEGIN
      RELY unchanged {x}
      DO x := n
      GUAR unchanged (- {x});
      RELY unchanged {y}
      DO y := m
      GUAR unchanged (- {y})
    COEND"

lemma PAR_ASSIGN:
  "x \<noteq> y \<Longrightarrow> unchanged {x, y}, unchanged (- {x, y}) \<turnstile> \<lbrace>x \<mapsto> - \<inter> y \<mapsto> -\<rbrace> x, y :=  n, m \<lbrace>x \<mapsto> n \<inter> y \<mapsto> m\<rbrace>"
  apply (simp add: PAR_ASSIGN_def)
  apply (rule COBEGIN)
  apply (rule WEAKEN[OF _ _ subset_refl subset_refl])
  prefer 3
  apply (rule ASSIGN)
  prefer 3
  apply (rule WEAKEN[OF _ _ subset_refl subset_refl])
  prefer 3
  apply (rule ASSIGN)
  by (auto simp add: unchanged_def)

lemma PAR_ASSIGN: "x \<noteq> y \<Longrightarrow> {}, UNIV \<turnstile> \<lbrace>x \<mapsto> - \<inter> y \<mapsto> -\<rbrace> Par (x := n) (y := m) \<lbrace>x \<mapsto> n \<inter> y \<mapsto> m\<rbrace>"
  apply (rule STRENGTHEN_GUAR[of "unchanged (- {x}) \<union> unchanged (- {y})"])
  apply simp
  apply (rule WEAKEN_RELY[of _ "unchanged (- {y}) \<inter> unchanged (- {x})"])
  apply simp
  apply (rule PAR)
  apply simp
  apply (rule WEAKEN[OF _ _ subset_refl subset_refl])
  prefer 3
  apply (rule ASSIGN)
  apply (force simp add: unchanged_def)+
  apply (rule WEAKEN[OF _ _ subset_refl subset_refl])
  prefer 3
  apply (rule ASSIGN)
  by (force simp add: unchanged_def)+

end


(*  Title:      HOL/MicroJava/DFA/Opt.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

section {* More about Options *}

theory Opt
imports Err
begin

definition le :: "'a ord \<Rightarrow> 'a option ord" where
"le r o1 o2 == case o2 of None \<Rightarrow> o1=None |
                              Some y \<Rightarrow> (case o1 of None \<Rightarrow> True
                                                  | Some x \<Rightarrow> x <=_r y)"

definition opt :: "'a set \<Rightarrow> 'a option set" where
"opt A == insert None {x . ? y:A. x = Some y}"

definition sup :: "'a ebinop \<Rightarrow> 'a option ebinop" where
"sup f o1 o2 ==
 case o1 of None \<Rightarrow> OK o2 | Some x \<Rightarrow> (case o2 of None \<Rightarrow> OK o1
     | Some y \<Rightarrow> (case f x y of Err \<Rightarrow> Err | OK z \<Rightarrow> OK (Some z)))"

definition esl :: "'a esl \<Rightarrow> 'a option esl" where
"esl == %(A,r,f). (opt A, le r, sup f)"

lemma unfold_le_opt:
  "o1 <=_(le r) o2 =
  (case o2 of None \<Rightarrow> o1=None |
              Some y \<Rightarrow> (case o1 of None \<Rightarrow> True | Some x \<Rightarrow> x <=_r y))"
apply (unfold lesub_def le_def)
apply (rule refl)
done

lemma le_opt_refl:
  "order r \<Longrightarrow> o1 <=_(le r) o1"
by (simp add: unfold_le_opt split: option.split)

lemma le_opt_trans [rule_format]:
  "order r \<Longrightarrow>
   o1 <=_(le r) o2 \<longrightarrow> o2 <=_(le r) o3 \<longrightarrow> o1 <=_(le r) o3"
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_trans)
done

lemma le_opt_antisym [rule_format]:
  "order r \<Longrightarrow> o1 <=_(le r) o2 \<longrightarrow> o2 <=_(le r) o1 \<longrightarrow> o1=o2"
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_antisym)
done

lemma order_le_opt [intro!,simp]:
  "order r \<Longrightarrow> order(le r)"
apply (subst Semilat.order_def)
apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
done

lemma None_bot [iff]:
  "None <=_(le r) ox"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done

lemma Some_le [iff]:
  "(Some x <=_(le r) ox) = (? y. ox = Some y & x <=_r y)"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done

lemma le_None [iff]:
  "(ox <=_(le r) None) = (ox = None)"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done

lemma OK_None_bot [iff]:
  "OK None <=_(Err.le (le r)) x"
  by (simp add: lesub_def Err.le_def le_def split: option.split err.split)

lemma sup_None1 [iff]:
  "x +_(sup f) None = OK x"
  by (simp add: plussub_def sup_def split: option.split)

lemma sup_None2 [iff]:
  "None +_(sup f) x = OK x"
  by (simp add: plussub_def sup_def split: option.split)

lemma None_in_opt [iff]:
  "None : opt A"
by (simp add: opt_def)

lemma Some_in_opt [iff]:
  "(Some x : opt A) = (x:A)"
apply (unfold opt_def)
apply auto
done

lemma semilat_opt [intro, simp]:
  "\<And>L. err_semilat L \<Longrightarrow> err_semilat (Opt.esl L)"
proof (unfold Opt.esl_def Err.sl_def, simp add: split_tupled_all)

  fix A r f
  assume s: "semilat (err A, Err.le r, lift2 f)"

  let ?A0 = "err A"
  let ?r0 = "Err.le r"
  let ?f0 = "lift2 f"

  from s
  obtain
    ord: "order ?r0" and
    clo: "closed ?A0 ?f0" and
    ub1: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. x <=_?r0 x +_?f0 y" and
    ub2: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. y <=_?r0 x +_?f0 y" and
    lub: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. \<forall>z\<in>?A0. x <=_?r0 z \<and> y <=_?r0 z \<longrightarrow> x +_?f0 y <=_?r0 z"
    by (unfold semilat_def) simp

  let ?A = "err (opt A)"
  let ?r = "Err.le (Opt.le r)"
  let ?f = "lift2 (Opt.sup f)"

  from ord
  have "order ?r"
    by simp

  moreover

  have "closed ?A ?f"
  proof (unfold closed_def, intro strip)
    fix x y
    assume x: "x : ?A"
    assume y: "y : ?A"

    { fix a b
      assume ab: "x = OK a" "y = OK b"

      with x
      have a: "\<And>c. a = Some c \<Longrightarrow> c : A"
        by (clarsimp simp add: opt_def)

      from ab y
      have b: "\<And>d. b = Some d \<Longrightarrow> d : A"
        by (clarsimp simp add: opt_def)

      { fix c d assume "a = Some c" "b = Some d"
        with ab x y
        have "c:A & d:A"
          by (simp add: err_def opt_def Bex_def)
        with clo
        have "f c d : err A"
          by (simp add: closed_def plussub_def err_def lift2_def)
        moreover
        fix z assume "f c d = OK z"
        ultimately
        have "z : A" by simp
      } note f_closed = this

      have "sup f a b : ?A"
      proof (cases a)
        case None
        thus ?thesis
          by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
      next
        case Some
        thus ?thesis
          by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
      qed
    }

    thus "x +_?f y : ?A"
      by (simp add: plussub_def lift2_def split: err.split)
  qed

  moreover

  { fix a b c
    assume "a \<in> opt A" "b \<in> opt A" "a +_(sup f) b = OK c"
    moreover
    from ord have "order r" by simp
    moreover
    { fix x y z
      assume "x \<in> A" "y \<in> A"
      hence "OK x \<in> err A \<and> OK y \<in> err A" by simp
      with ub1 ub2
      have "(OK x) <=_(Err.le r) (OK x) +_(lift2 f) (OK y) \<and>
            (OK y) <=_(Err.le r) (OK x) +_(lift2 f) (OK y)"
        by blast
      moreover
      assume "x +_f y = OK z"
      ultimately
      have "x <=_r z \<and> y <=_r z"
        by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
    }
    ultimately
    have "a <=_(le r) c \<and> b <=_(le r) c"
      by (auto simp add: sup_def le_def lesub_def plussub_def
               dest: order_refl split: option.splits err.splits)
  }

  hence "(\<forall>x\<in>?A. \<forall>y\<in>?A. x <=_?r x +_?f y) \<and> (\<forall>x\<in>?A. \<forall>y\<in>?A. y <=_?r x +_?f y)"
    by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)

  moreover

  have "\<forall>x\<in>?A. \<forall>y\<in>?A. \<forall>z\<in>?A. x <=_?r z \<and> y <=_?r z \<longrightarrow> x +_?f y <=_?r z"
  proof (intro strip, elim conjE)
    fix x y z
    assume xyz: "x : ?A" "y : ?A" "z : ?A"
    assume xz: "x <=_?r z"
    assume yz: "y <=_?r z"

    { fix a b c
      assume ok: "x = OK a" "y = OK b" "z = OK c"

      { fix d e g
        assume some: "a = Some d" "b = Some e" "c = Some g"

        with ok xyz
        obtain "OK d:err A" "OK e:err A" "OK g:err A"
          by simp
        with lub
        have "\<lbrakk> (OK d) <=_(Err.le r) (OK g); (OK e) <=_(Err.le r) (OK g) \<rbrakk>
          \<Longrightarrow> (OK d) +_(lift2 f) (OK e) <=_(Err.le r) (OK g)"
          by blast
        hence "\<lbrakk> d <=_r g; e <=_r g \<rbrakk> \<Longrightarrow> \<exists>y. d +_f e = OK y \<and> y <=_r g"
          by simp

        with ok some xyz xz yz
        have "x +_?f y <=_?r z"
          by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
      } note this [intro!]

      from ok xyz xz yz
      have "x +_?f y <=_?r z"
        by - (cases a, simp, cases b, simp, cases c, simp, blast)
    }

    with xyz xz yz
    show "x +_?f y <=_?r z"
      by - (cases x, simp, cases y, simp, cases z, simp+)
  qed

  ultimately

  show "semilat (?A,?r,?f)"
    by (unfold semilat_def) simp
qed

lemma top_le_opt_Some [iff]:
  "top (le r) (Some T) = top r T"
apply (unfold top_def)
apply (rule iffI)
 apply blast
apply (rule allI)
apply (case_tac "x")
apply simp+
done

lemma Top_le_conv:
  "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T <=_r x) = (x = T)"
apply (unfold top_def)
apply (blast intro: order_antisym)
done

lemma acc_le_optI [intro!]:
  "acc r \<Longrightarrow> acc(le r)"
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: option.split)
apply clarify
apply (case_tac "? a. Some a : Q")
 apply (erule_tac x = "{a . Some a : Q}" in allE)
 apply blast
apply (case_tac "x")
 apply blast
apply blast
done

lemma option_map_in_optionI:
  "\<lbrakk> ox : opt S; !x:S. ox = Some x \<longrightarrow> f x : S \<rbrakk>
  \<Longrightarrow> map_option f ox : opt S"
apply (unfold map_option_case)
apply (simp split: option.split)
apply blast
done

end


theory ex3_01 imports Main "~~/src/IMP/AExp" begin

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N _) = True" |
"optimal (V _) = True" |
"optimal (Plus (N _) (N _)) = False" |
"optimal (Plus l r) = (optimal l \<and> optimal r)"

theorem "optimal (asimp_const a)"
apply(induction a)
apply auto
apply (simp split: aexp.split)
apply auto
done

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_weird_nat_mul3_rrot
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

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

theorem property0 :
  "((mul3 x y z) = (mul3 z x y))"
  oops

end


theory prop_28
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster equal2 elem append *)
lemma lemma_a [thy_expl]: "equal2 x4 y4 = equal2 y4 x4"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes equal2.simps)

  theorem x0 :
    "elem x (append xs (Cons2 x (Nil2)))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Ex4_1
  imports Main
begin

lemma helper1[simp] : "op = a b = ((a \<longrightarrow> b) \<and> (b \<longrightarrow> a))" by blast

lemma helper2[simp] : "op \<or> a b = ((a \<longrightarrow> False) \<longrightarrow> b)" by blast

lemma helper3[simp] : "(\<not>a) = (a \<longrightarrow> False)" by blast

lemma "(A \<or> (B \<and> C) = A) = ((A \<longrightarrow> False) \<longrightarrow> (B \<and> C \<longrightarrow> A) \<and> (A \<longrightarrow> B \<and> C))" by blast


theory Datatype_Selectors
imports Main
begin

text\<open>
  Running Example: @{text "datatype_new iptrule_match = is_Src: Src (src_range: ipt_iprange)"}

  A discriminator @{text disc} tells whether a value is of a certain constructor.
    Example: @{text "is_Src"}

  A selector @{text sel} select the inner value.
    Example: @{text "src_range"}

  A constructor @{text C} constructs a value
    Example: @{text "Src"}

  The are well-formed if the belong together.
\<close>
fun wf_disc_sel :: "(('a \<Rightarrow> bool) \<times> ('a \<Rightarrow> 'b)) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" where
  "wf_disc_sel (disc, sel) C \<longleftrightarrow> (\<forall>a. disc a \<longrightarrow> C (sel a) = a) \<and> (\<forall>a. (*disc (C a) \<longrightarrow>*) sel (C a) = a)"

(* should the following be added to the definition?
 the discriminator is true for all C independent of the a
 for example: is_Src_IP is true for all Src_IPs, independent of the numberic value of the ip.
lemma "wf_disc_sel (disc, sel) C \<Longrightarrow> (\<exists>a. disc (C a)) \<longrightarrow> (\<forall>a. disc (C a))"
*)

declare wf_disc_sel.simps[simp del]

end


(*  Title:      HOL/Library/Type_Length.thy
    Author:     John Matthews, Galois Connections, Inc., Copyright 2006
*)

section \<open>Assigning lengths to types by type classes\<close>

theory Type_Length
imports Numeral_Type
begin

text \<open>
  The aim of this is to allow any type as index type, but to provide a
  default instantiation for numeral types. This independence requires
  some duplication with the definitions in \<^file>\<open>Numeral_Type.thy\<close>.
\<close>

class len0 =
  fixes len_of :: "'a itself \<Rightarrow> nat"

syntax "_type_length" :: "type \<Rightarrow> nat" (\<open>(1LENGTH/(1'(_')))\<close>)

translations "LENGTH('a)" \<rightharpoonup>
  "CONST len_of (CONST Pure.type :: 'a itself)"

print_translation \<open>
  let
    fun len_of_itself_tr' ctxt [Const (\<^const_syntax>\<open>Pure.type\<close>, Type (_, [T]))] =
      Syntax.const \<^syntax_const>\<open>_type_length\<close> $ Syntax_Phases.term_of_typ ctxt T
  in [(\<^const_syntax>\<open>len_of\<close>, len_of_itself_tr')] end
\<close>

text \<open>Some theorems are only true on words with length greater 0.\<close>

class len = len0 +
  assumes len_gt_0 [iff]: "0 < LENGTH('a)"
begin

lemma len_not_eq_0 [simp]:
  "LENGTH('a) \<noteq> 0"
  by simp

end

instantiation num0 and num1 :: len0
begin

definition len_num0: "len_of (_ :: num0 itself) = 0"
definition len_num1: "len_of (_ :: num1 itself) = 1"

instance ..

end

instantiation bit0 and bit1 :: (len0) len0
begin

definition len_bit0: "len_of (_ :: 'a::len0 bit0 itself) = 2 * LENGTH('a)"
definition len_bit1: "len_of (_ :: 'a::len0 bit1 itself) = 2 * LENGTH('a) + 1"

instance ..

end

lemmas len_of_numeral_defs [simp] = len_num0 len_num1 len_bit0 len_bit1

instance num1 :: len
  by standard simp
instance bit0 :: (len) len
  by standard simp
instance bit1 :: (len0) len
  by standard simp

instantiation Enum.finite_1 :: len
begin

definition
  "len_of_finite_1 (x :: Enum.finite_1 itself) \<equiv> (1 :: nat)"

instance
  by standard (auto simp: len_of_finite_1_def)

end

instantiation Enum.finite_2 :: len
begin

definition
  "len_of_finite_2 (x :: Enum.finite_2 itself) \<equiv> (2 :: nat)"

instance
  by standard (auto simp: len_of_finite_2_def)

end

instantiation Enum.finite_3 :: len
begin

definition
  "len_of_finite_3 (x :: Enum.finite_3 itself) \<equiv> (4 :: nat)"

instance
  by standard (auto simp: len_of_finite_3_def)

end

lemma length_not_greater_eq_2_iff [simp]:
  \<open>\<not> 2 \<le> LENGTH('a::len) \<longleftrightarrow> LENGTH('a) = 1\<close>
  by (auto simp add: not_le dest: less_2_cases)

context linordered_idom
begin

lemma two_less_eq_exp_length [simp]:
  \<open>2 \<le> 2 ^ LENGTH('b::len)\<close>
  using mult_left_mono [of 1 \<open>2 ^ (LENGTH('b::len) - 1)\<close> 2]
  by (cases \<open>LENGTH('b::len)\<close>) simp_all

end

lemma less_eq_decr_length_iff [simp]:
  \<open>n \<le> LENGTH('a::len) - Suc 0 \<longleftrightarrow> n < LENGTH('a)\<close>
  by (cases \<open>LENGTH('a)\<close>) (simp_all add: less_Suc_eq le_less)

lemma decr_length_less_iff [simp]:
  \<open>LENGTH('a::len) - Suc 0 < n \<longleftrightarrow> LENGTH('a) \<le> n\<close>
  by (cases \<open>LENGTH('a)\<close>) auto

end